tiny-mime.el

   1 ;;;
   2 ;;; A multilingual MIME message header encoder/decoder.
   3 ;;;     by Morioka Tomohiko (morioka@jaist.ac.jp)
   4 ;;;
   5 ;;; original MIME decoder is
   6 ;;;     mime.el,v 1.5 1992/07/18 07:52:08 by Enami Tsugutomo
   7 ;;;
   8
   9 (provide 'tiny-mime)
  10
  11
  12 ;;; @ require modules
  13 ;;;
  14 (require 'tl-header)
  15 (require 'tl-str)
  16 (if (not (fboundp 'member))
  17     (require 'tl-18)
  18   )
  19
  20
  21 ;;; @ version
  22 ;;;
  23 (defconst mime/RCS-ID
  24   "$Id: tiny-mime.el,v 5.3 1994/10/25 11:51:05 morioka Exp $")
  25
  26 (defconst mime/tiny-mime-version (get-version-string mime/RCS-ID))
  27
  28
  29 ;;; @ MIME encoded-word definition
  30 ;;;
  31
  32 (defconst mime/charset-regexp "[A-Za-z0-9!#$%&'*+---^_`{}|~]")
  33 (defconst mime/encoded-text-regexp "[!->@-~]+")
  34
  35 (defconst mime/Base64-token-regexp "[A-Za-z0-9+/=]")
  36 (defconst mime/Base64-encoded-text-regexp
  37   (concat "\\("
  38               mime/Base64-token-regexp
  39               mime/Base64-token-regexp
  40               mime/Base64-token-regexp
  41               mime/Base64-token-regexp
  42               "\\)+"))
  43 (defconst mime/Base64-encoding-and-encoded-text-regexp
  44   (concat "\\(B\\)\\?" mime/Base64-encoded-text-regexp))
  45
  46 (defconst mime/Quoted-Printable-hex-char "[0123456789ABCDEF]")
  47 (defconst mime/Quoted-Printable-encoded-text-regexp
  48   (concat "\\([^=?_]\\|="
  49               mime/Quoted-Printable-hex-char
  50               mime/Quoted-Printable-hex-char
  51               "\\)+"))
  52 (defconst mime/Quoted-Printable-encoding-and-encoded-text-regexp
  53   (concat "\\(Q\\)\\?" mime/Quoted-Printable-encoded-text-regexp))
  54
  55 (defconst mime/encoded-word-regexp (concat (regexp-quote "=?")
  56                                            "\\("
  57                                            mime/charset-regexp
  58                                            "+\\)"
  59                                            (regexp-quote "?")
  60                                            "\\(B\\|Q\\)"
  61                                            (regexp-quote "?")
  62                                            "\\("
  63                                            mime/encoded-text-regexp
  64                                            "\\)"
  65                                            (regexp-quote "?=")))
  66
  67 (defun mime/nth-string (s n)
  68   (if (stringp s)
  69       (substring s (match-beginning n) (match-end n))
  70     (buffer-substring (match-beginning n) (match-end n))))
  71
  72 (defun mime/encoded-word-charset (str)
  73   (mime/nth-string str 1))
  74
  75 (defun mime/encoded-word-encoding (str)
  76   (mime/nth-string str 2))
  77
  78 (defun mime/encoded-word-encoded-text (str)
  79   (mime/nth-string str 3))
  80
  81 (defun mime/rest-of-string (str)
  82   (if (stringp str)
  83       (substring str (match-end 0))
  84     (buffer-substring (match-end 0))))
  85
  86 ;;; @ variables
  87 ;;;
  88
  89 (defvar mime/no-encoding-header-fields '("X-Nsubject"))
  90
  91 (defvar mime/use-X-Nsubject nil)
  92
  93
  94 ;;; @ compatible module among Mule, NEmacs and NEpoch
  95 ;;;
  96 (cond ((boundp 'MULE)  (require 'tm-mule))
  97       ((boundp 'NEMACS)(require 'tm-nemacs))
  98       (t               (require 'tm-orig))
  99       )
 100
 101
 102 ;;; @ Application Interface
 103 ;;;
 104
 105 ;;; @@ MIME header decoders
 106 ;;;
 107
 108 ;; by mol. 1993/10/4
 109 (defun mime/decode-encoded-word (word)
 110   (if (string-match mime/encoded-word-regexp word)
 111       (let ((charset (upcase (mime/encoded-word-charset word)))
 112             (encoding (mime/encoded-word-encoding word))
 113             (text (mime/encoded-word-encoded-text word)))
 114         (mime/decode-encoded-text charset encoding text))
 115     word))
 116
 117 (defun mime/decode-region (beg end)
 118   (interactive "*r")
 119   (save-excursion
 120     (save-restriction
 121       (narrow-to-region beg end)
 122       (goto-char (point-min))
 123       (let (charset encoding text)
 124         (while (re-search-forward mime/encoded-word-regexp nil t)
 125           (insert (mime/decode-encoded-word
 126                    (prog1
 127                        (buffer-substring (match-beginning 0) (match-end 0))
 128                      (delete-region (match-beginning 0) (match-end 0))
 129                      )
 130                   ))
 131           ))
 132       )))
 133
 134 (defun mime/decode-message-header ()
 135   (interactive "*")
 136   (save-excursion
 137     (save-restriction
 138       (narrow-to-region (goto-char (point-min))
 139                         (progn (re-search-forward "^$" nil t) (point)))
 140       (mime/prepare-decode-message-header)
 141       (mime/decode-region (point-min) (point-max))
 142       )))
 143
 144 (defun mime/decode-string (str)
 145   (let ((dest "")(ew nil)
 146         beg end)
 147     (while (setq beg (string-match mime/encoded-word-regexp str))
 148       (if (> beg 0)
 149           (if (not (and (eq ew t) (string= (substring str 0 beg) " ")))
 150               (setq dest (concat dest (substring str 0 beg)
 151                                  ))
 152             )
 153         )
 154       (setq end (match-end 0))
 155       (setq dest (concat dest (mime/decode-encoded-word (substring str beg end))
 156                          ))
 157       (setq str (substring str end))
 158       (setq ew t)
 159       )
 160     (concat dest str)
 161     ))
 162
 163 ;;; @@ MIME header encoders
 164 ;;;
 165
 166 (defun mime/encode-string (string encoding &optional mode)
 167   (cond ((equal encoding "B") (mime/base64-encode-string string))
 168         ((equal encoding "Q") (mime/Quoted-Printable-encode-string string mode))
 169         (t nil)
 170         ))
 171
 172 (defun mime/encode-field (str)
 173   (setq str (message/unfolding-string str))
 174   (let ((ret (message/divide-field str))
 175         field-name field-body)
 176     (setq field-name (car ret))
 177     (setq field-body (nth 1 ret))
 178     (concat field-name " "
 179             (cond ((string= field-body "") "")
 180                   ((or (string-match "^Reply-To:$" field-name)
 181                        (string-match "^From:$" field-name)
 182                        (string-match "^Sender:$" field-name)
 183                        (string-match "^Resent-Reply-To:$" field-name)
 184                        (string-match "^Resent-From:$" field-name)
 185                        (string-match "^Resent-Sender:$" field-name)
 186                        (string-match "^To:$" field-name)
 187                        (string-match "^Resent-To:$" field-name)
 188                        (string-match "^cc:$" field-name)
 189                        (string-match "^Resent-cc:$" field-name)
 190                        (string-match "^bcc:$" field-name)
 191                        (string-match "^Resent-bcc:$" field-name)
 192                        )
 193                    (mime/encode-address-list
 194                     (+ (length field-name) 1) field-body)
 195                    )
 196                   (t
 197                    (catch 'tag
 198                      (let ((r mime/no-encoding-header-fields) fn)
 199                        (while r
 200                          (setq fn (car r))
 201                          (if (string-match (concat "^" fn ":$") field-name)
 202                              (throw 'tag field-body)
 203                            )
 204                          (setq r (cdr r))
 205                          ))
 206                      (nth 1 (mime/encode-header-string
 207                              (+ (length field-name) 1) field-body))
 208                      ))
 209                   ))
 210     ))
 211
 212 (defun mime/encode-message-header ()
 213   (interactive "*")
 214   (save-excursion
 215     (save-restriction
 216       (narrow-to-region (goto-char (point-min))
 217                         (progn
 218                           (re-search-forward
 219                            (concat "^" (regexp-quote mail-header-separator) "$")
 220                            nil t)
 221                           (match-beginning 0)
 222                           ))
 223       (goto-char (point-min))
 224       (let (beg end field)
 225         (while (re-search-forward "^.+:.*\\(\n\\s +.*\\)*" nil t)
 226           (setq beg (match-beginning 0))
 227           (setq end  (match-end 0))
 228           (setq field (buffer-substring beg end))
 229           (insert (mime/encode-field
 230                    (prog1
 231                        (buffer-substring beg end)
 232                      (delete-region beg end)
 233                      )))
 234           ))
 235       (if mime/use-X-Nsubject
 236           (progn
 237             (goto-char (point-min))
 238             (if (re-search-forward "^Subject:.*\\(\n\\s +.*\\)*" nil t)
 239                 (let ((str (buffer-substring (match-beginning 0)(match-end 0))))
 240                   (if (string-match mime/encoded-word-regexp str)
 241                       (insert (concat
 242                                "\nX-Nsubject: "
 243                                (nth 1 (message/divide-field
 244                                        (mime/decode-string
 245                                         (message/unfolding-string str))
 246                                        ))))
 247                     ))
 248               )))
 249       )))
 250
 251 ;;; @ Base64 (B-encode) decoder/encoder
 252 ;;;     by Enami Tsugutomo
 253 ;;;     modified by mol.
 254
 255 (defun mime/base64-decode-string (string)
 256   (mime/base64-mapconcat (function mime/base64-decode-chars) 4 string))
 257
 258 ;; (mime/base64-encode-string (mime/base64-decode-string "GyRAOjRGI0stGyhK"))
 259 (defun mime/base64-encode-string (string &optional mode)
 260   (let ((es (mime/base64-mapconcat (function mime/base64-encode-chars) 3 string))
 261         m)
 262     (setq m (mod (length es) 4))
 263     (concat es
 264             (cond ((= m 3) "=")
 265                   ((= m 2) "==")
 266                   ))
 267     ))
 268
 269 ;; (char-to-string (mime/base64-bit-to-char 26))
 270 (defun mime/base64-bit-to-char (n)
 271   (cond ((eq n nil) ?=)
 272         ((< n 26) (+ ?A n))
 273         ((< n 52) (+ ?a (- n 26)))
 274         ((< n 62) (+ ?0 (- n 52)))
 275         ((= n 62) ?+)
 276         ((= n 63) ?/)
 277         (t (error "not a base64 integer %d" n))))
 278
 279 (defun mime/base64-char-to-bit (c)
 280   (cond ((and (<= ?A c) (<= c ?Z)) (- c ?A))
 281         ((and (<= ?a c) (<= c ?z)) (+ (- c ?a) 26))
 282         ((and (<= ?0 c) (<= c ?9)) (+ (- c ?0) 52))
 283         ((= c ?+) 62)
 284         ((= c ?/) 63)
 285         ((= c ?=) nil)
 286         (t (error "not a base64 character %c" c))))
 287
 288 (defun mime/mask (i n) (logand i (1- (ash 1 n))))
 289
 290 (defun mime/base64-encode-1 (a &optional b &optional c)
 291   (cons (ash a -2)
 292         (cons (logior (ash (mime/mask a 2) (- 6 2))
 293                       (if b (ash b -4) 0))
 294               (if b
 295                   (cons (logior (ash (mime/mask b 4) (- 6 4))
 296                                 (if c (ash c -6) 0))
 297                         (if c
 298                             (cons (mime/mask c (- 6 0))
 299                                   nil)))))))
 300
 301 (defun mime/base64-decode-1 (a b &optional c &optional d)
 302   (cons (logior (ash a 2) (ash b (- 2 6)))
 303         (if c (cons (logior (ash (mime/mask b 4) 4)
 304                             (mime/mask (ash c (- 4 6)) 4))
 305                     (if d (cons (logior (ash (mime/mask c 2) 6) d)
 306                                 nil))))))
 307
 308 ;; (mime/base64-decode-chars ?G ?y ?R ?A)
 309 (defun mime/base64-decode-chars (a b c d)
 310   (apply (function mime/base64-decode-1)
 311          (mapcar (function mime/base64-char-to-bit)
 312                  (list a b c d))))
 313
 314 ;; (mapcar (function char-to-string) (mime/base64-encode-chars 27 36 64))
 315 (defun mime/base64-encode-chars (a b c)
 316   (mapcar (function mime/base64-bit-to-char) (mime/base64-encode-1 a b c)))
 317
 318 (defun mime/base64-fecth-from (func from pos len)
 319   (let (ret)
 320     (while (< 0 len)
 321       (setq len (1- len)
 322             ret (cons (funcall func from (+ pos len)) ret)))
 323     ret))
 324
 325 (defun mime/base64-fecth-from-buffer (from pos len)
 326   (mime/base64-fecth-from (function (lambda (f p) (char-after p)))
 327                           from pos len))
 328
 329 (defun mime/base64-fecth-from-string (from pos len)
 330   (mime/base64-fecth-from (function (lambda (f p)
 331                                       (if (< p (length f)) (aref f p))))
 332                           from pos len))
 333
 334 (defun mime/base64-fecth (source pos len)
 335   (cond ((stringp source) (mime/base64-fecth-from-string source pos len))
 336         (t (mime/base64-fecth-from-buffer source pos len))))
 337
 338 (defun mime/base64-mapconcat (func unit string)
 339   (let ((i 0) ret)
 340     (while (< i (length string))
 341       (setq ret
 342             (apply (function concat)
 343                    ret
 344                    (mapcar (function char-to-string)
 345                            (apply func (mime/base64-fecth string i unit)))))
 346       (setq i (+ i unit)))
 347     ret))
 348
 349 ;;; @ Quoted-Printable (Q-encode) encoder/decoder
 350 ;;;
 351
 352 (defun mime/Quoted-Printable-decode-string (str)
 353   (let ((dest "")
 354         (len (length str))
 355         (i 0) chr num h l)
 356     (while (< i len)
 357       (setq chr (elt str i))
 358       (cond ((eq chr ?=)
 359              (if (< (+ i 2) len)
 360                  (progn
 361                    (setq h (hex-char-to-number (elt str (+ i 1))))
 362                    (setq l (hex-char-to-number (elt str (+ i 2))))
 363                    (setq num (+ (* h 16) l))
 364                    (setq dest (concat dest (char-to-string num)))
 365                    (setq i (+ i 3))
 366                    )
 367                (progn
 368                  (setq dest (concat dest (char-to-string chr)))
 369                  (setq i (+ i 1))
 370                  )))
 371             ((eq chr ?_)
 372              (setq dest (concat dest (char-to-string 32)))
 373              (setq i (+ i 1))
 374              )
 375             (t
 376              (setq dest (concat dest (char-to-string chr)))
 377              (setq i (+ i 1))
 378              ))
 379       )
 380     dest))
 381
 382 (defun mime/Quoted-Printable-encode-string (str &optional mode)
 383   (if (null mode)
 384       (setq mode 'phrase))
 385   (let ((dest "")
 386         (len (length str))
 387         (i 0) chr)
 388     (while (< i len)
 389       (setq chr (elt str i))
 390       (cond ((eq chr 32)
 391              (setq dest (concat dest "_"))
 392              )
 393             ((or (eq chr ?=)
 394                  (eq chr ??)
 395                  (eq chr ?_)
 396                  (and (eq mode 'comment)
 397                       (or (eq chr ?\()
 398                           (eq chr ?\))
 399                           (eq chr ?\\)
 400                           ))
 401                  (and (eq mode 'phrase)
 402                       (not (string-match "[A-Za-z0-9!*+/=_---]"
 403                                          (char-to-string chr)))
 404                       )
 405                  (< chr 32)
 406                  (> chr 126))
 407              (setq dest (concat dest
 408                                 "="
 409                                 (char-to-string (number-to-hex-char (/ chr 16)))
 410                                 (char-to-string (number-to-hex-char (% chr 16)))
 411                                 ))
 412              )
 413             (t (setq dest (concat dest (char-to-string chr)))
 414                ))
 415       (setq i (+ i 1))
 416       )
 417     dest))
 418
 419 ;;; @ functions for message header encoding
 420 ;;;
 421
 422 (defun mime/encode-and-split-string (n string charset encoding)
 423   (let ((i 0) (j 0)
 424         (len (length string))
 425         (js (mime/convert-string-from-emacs string charset))
 426         (cesl (+ (length charset) (length encoding) 6 ))
 427         ewl m rest)
 428     (setq ewl (mime/encoded-word-length js encoding))
 429     (if (null ewl) nil
 430       (progn
 431         (setq m (+ n ewl cesl))
 432         (if (> m 76)
 433             (progn
 434               (while (and (< i len)
 435                           (setq js (mime/convert-string-from-emacs
 436                                     (substring string 0 i) charset))
 437                           (setq m (+ n (mime/encoded-word-length js encoding) cesl))
 438                           (< m 76))
 439                 (setq j i)
 440                 (setq i (+ i (char-bytes (elt string i))))
 441                 )
 442               (setq js (mime/convert-string-from-emacs
 443                         (substring string 0 j) charset))
 444               (setq m (+ n (mime/encoded-word-length js encoding) cesl))
 445               (setq rest (substring string j))
 446               )
 447           (setq rest nil))
 448         (if (string= js "")
 449             (list 1 "" string)
 450           (list m (concat "=?" charset "?" encoding "?"
 451                           (mime/encode-string js encoding)
 452                           "?=") rest))
 453         ))
 454     ))
 455
 456 (defun mime/encode-header-word (n string charset encoding)
 457   (let (dest str ret m)
 458     (if (null (setq ret (mime/encode-and-split-string n string charset encoding)))
 459         nil
 460       (progn
 461         (setq dest (nth 1 ret))
 462         (setq m (car ret))
 463         (setq str (nth 2 ret))
 464         (while (and (stringp str)
 465                     (setq ret (mime/encode-and-split-string 1 str charset encoding))
 466                     )
 467           (setq dest (concat dest "\n " (nth 1 ret)))
 468           (setq m (car ret))
 469           (setq str (nth 2 ret))
 470           )
 471         (list m dest)
 472         ))
 473     ))
 474
 475 (defun mime/encode-header-string (n string &optional mode)
 476   (let ((ssl (mime/separate-string-for-encoder string))
 477         i len cell et w ew (dest "") b l)
 478     (setq len (length ssl))
 479     (setq cell (nth 0 ssl))
 480     (setq et (car cell))
 481     (setq w (cdr cell))
 482     (if (eq et nil)
 483         (progn
 484           (if (> (+ n (string-width w)) 76)
 485               (progn
 486                 (setq dest (concat dest "\n "))
 487                 (setq b 1)
 488                 )
 489             (setq b n))
 490           (setq dest (concat dest w))
 491           (setq b (+ b (string-width w)))
 492           )
 493       (progn
 494         (setq ew (mime/encode-header-word n (cdr cell) (car et) (cdr et)))
 495         (setq dest (nth 1 ew))
 496         (setq b (car ew))
 497         ))
 498     (setq i 1)
 499     (while (< i len)
 500       (setq cell (nth i ssl))
 501       (setq et (car cell))
 502       (setq w (cdr cell))
 503       (cond ((string-match "^[ \t]*$" w)
 504              (setq b (+ b (string-width (cdr cell))))
 505              (setq dest (concat dest (cdr cell)))
 506              )
 507             ((eq et nil)
 508              (if (> (+ b (string-width w)) 76)
 509                  (progn
 510                    (if (eq (elt dest (- (length dest) 1)) 32)
 511                        (setq dest (substring dest 0 (- (length dest) 1)))
 512                      )
 513                    (setq dest (concat dest "\n " w))
 514                    (setq b (+ (length w) 1))
 515                    )
 516                (setq l (length dest))
 517                (if (and (>= l 2)
 518                         (eq (elt dest (- l 2)) ?\?)
 519                         (eq (elt dest (- l 1)) ?=)
 520                         )
 521                    (progn
 522                      (setq dest (concat dest " "))
 523                      (setq b (+ b 1))
 524                      ))
 525                (setq dest (concat dest w))
 526                (setq b (+ b (string-width w)))
 527                ))
 528             (t
 529              (if (not (eq (elt dest (- (length dest) 1)) 32))
 530                  (progn
 531                    (setq dest (concat dest " "))
 532                    (setq b (+ b 1))
 533                    ))
 534              (setq ew (mime/encode-header-word b (cdr cell) (car et) (cdr et)))
 535              (setq b (car ew))
 536              (if (string-match "^\n" (nth 1 ew))
 537                  (setq dest (concat (substring dest 0 (- (length dest) 1))
 538                                     (nth 1 ew)))
 539                (setq dest (concat dest (nth 1 ew)))
 540                )
 541              ))
 542       (setq i (+ i 1))
 543       )
 544     (list b dest)))
 545
 546 (defun mime/encode-address-list (n str)
 547   (let ((ret (message/parse-addresses str))
 548         len (i 0) cell en-ret j cl (dest "") s)
 549     (setq len (length ret))
 550     (while (< i len)
 551       (setq cell (nth i ret))
 552       (cond ((string= (nth 1 cell) "<")
 553              (setq en-ret (mime/encode-header-string n (nth 0 cell) 'phrase))
 554              (setq dest (concat dest (nth 1 en-ret)))
 555              (setq n (car en-ret))
 556              (if (< i (- len 1))
 557                  (setq en-ret
 558                        (mime/encode-header-string
 559                         n (concat (nth 1 cell)(nth 2 cell)(nth 3 cell) ", ")))
 560                (setq en-ret (mime/encode-header-string
 561                              n (concat (nth 1 cell)(nth 2 cell)(nth 3 cell))))
 562                )
 563              (if (and (eq (elt (nth 1 en-ret) 0) ?\n)
 564                       (eq (elt dest (- (length dest) 1)) 32))
 565                  (setq dest (substring dest 0 (- (length dest) 1)))
 566                )
 567              (setq dest (concat dest (nth 1 en-ret)))
 568              (setq n (car en-ret))
 569              )
 570             ((= (length cell) 4)
 571              (setq en-ret (mime/encode-header-string n (nth 0 cell)))
 572              (setq dest (concat dest (nth 1 en-ret)))
 573              (setq n (car en-ret))
 574
 575              (setq en-ret (mime/encode-header-string (+ n 2) (nth 2 cell) 'comment))
 576              (if (eq (elt (nth 1 en-ret) 0) ?\n)
 577                  (progn
 578                    (setq dest (concat dest "\n ("))
 579                    (setq en-ret (mime/encode-header-string 2 (nth 2 cell) 'comment))
 580                    )
 581                (progn
 582                  (setq dest (concat dest " ("))
 583                  ))
 584              (setq dest (concat dest (nth 1 en-ret)))
 585              (setq n (car en-ret))
 586              (if (< i (- len 1))
 587                  (setq en-ret
 588                        (mime/encode-header-string n (concat (nth 3 cell) ", ")))
 589                (setq en-ret (mime/encode-header-string n (nth 3 cell)))
 590                )
 591              (setq dest (concat dest (nth 1 en-ret)))
 592              (setq n (car en-ret))
 593              )
 594             (t
 595              (if (< i (- len 1))
 596                  (setq en-ret
 597                        (mime/encode-header-string n (concat (nth 0 cell) ", ")))
 598                (setq en-ret (mime/encode-header-string n (nth 0 cell)))
 599                )
 600              (setq dest (concat dest (nth 1 en-ret)))
 601              (setq n (car en-ret))
 602              ))
 603       (setq i (+ i 1)) )
 604     dest))
 605
 606 ;;; @ utility functions
 607 ;;;
 608
 609 ;; by mol. 1993/10/4
 610 (defun hex-char-to-number (chr)
 611   (cond ((and (<= ?0 chr)(<= chr ?9)) (- chr ?0))
 612         ((and (<= ?A chr)(<= chr ?F)) (+ (- chr ?A) 10))
 613         ((and (<= ?a chr)(<= chr ?f)) (+ (- chr ?a) 10))
 614         ))
 615
 616 (defun number-to-hex-char (n)
 617   (if (< n 10)
 618       (+ ?0 n)
 619     (+ ?A (- n 10))))
 620
 621
 622 ;;; @ utility for encoder
 623 ;;;
 624
 625 ;;; @@ encoded-word length
 626 ;;;
 627
 628 (defun mime/encoded-word-length (string encoding)
 629   (cond ((equal encoding "B") (mime/base64-length string))
 630         ((equal encoding "Q") (mime/Quoted-Printable-length string))
 631         (t nil)
 632         ))
 633
 634 (defun mime/base64-length (string)
 635   (let ((l (length string))
 636         )
 637     (* (+ (/ l 3)
 638           (if (= (mod l 3) 0) 0 1)
 639           ) 4)
 640     ))
 641
 642 (defun mime/Quoted-Printable-length (string &optional mode)
 643   (let ((l 0)(i 0)(len (length string)) chr)
 644     (while (< i len)
 645       (setq chr (elt string i))
 646       (if (string-match "[A-Za-z0-9!*+/=_---]" (char-to-string chr))
 647           (setq l (+ l 1))
 648         (setq l (+ l 3))
 649         )
 650       (setq i (+ i 1)) )
 651     l))
 652
 653 ;;; @@ separate by character set
 654 ;;;
 655
 656 ;; by mol. 1993/11/2
 657 (defconst LC-space 2)
 658
 659 ;; by mol. 1993/10/16
 660 (defun mime/char-type (chr)
 661   (if (or (= chr 32)(= chr ?\t))
 662       LC-space
 663     (get-lc chr)
 664     ))
 665
 666 (defun mime/separate-string-by-chartype (string)
 667   (let ((len (length string))
 668         (dest nil) (ds "") s
 669         pcs i j cs chr)
 670     (if (= len 0) nil
 671       (progn (setq chr (elt string 0))
 672              (setq pcs (mime/char-type chr))
 673              (setq i (char-bytes chr))
 674              (setq ds (substring string 0 i))
 675              (while (< i len)
 676                (setq chr (elt string i))
 677                (setq cs (mime/char-type chr))
 678                (setq j (+ i (char-bytes chr)))
 679                (setq s (substring string i j))
 680                (setq i j)
 681                (if (= cs pcs)
 682                    (setq ds (concat ds s))
 683                  (progn (setq dest (append dest (list (cons pcs ds))))
 684                         (setq pcs cs)
 685                         (setq ds s)
 686                         ))
 687                )
 688              (if (not (string= ds ""))
 689                  (setq dest (append dest (list (cons pcs ds)))))
 690              dest)
 691       )))
 692
 693 (defun mime/separate-string-by-charset (str)
 694   (let ((rl (mime/separate-string-by-chartype str))
 695         (i 1) len (pcell nil) cell ncell dpcell (dest nil) LC)
 696     (setq len (length rl))
 697     (setq dpcell (list (nth 0 rl)))
 698     (setq cell (nth 1 rl))
 699     (setq ncell (nth 2 rl))
 700     (while (< i len)
 701       (setq LC (car (car dpcell)))
 702       (cond ((and (not (eq LC lc-ascii))
 703                   (eq (car cell) LC-space)
 704                   (not (eq (car ncell) lc-ascii)))
 705              (setq dpcell (list (cons LC
 706                                       (concat (cdr (car dpcell)) (cdr cell))
 707                                       )))
 708              )
 709             ((and (not (eq LC lc-ascii))
 710                   (eq LC (car cell)))
 711              (setq dpcell (list (cons LC
 712                                       (concat (cdr (car dpcell)) (cdr cell))
 713                                       )))
 714              )
 715             ((and (eq LC lc-ascii)
 716                   (member (car cell) mime/latin-lc-list))
 717              (setq dpcell (list (cons (car cell)
 718                                       (concat (cdr (car dpcell)) (cdr cell))
 719                                       )))
 720              )
 721             ((and (member LC mime/latin-lc-list)
 722                   (eq (car cell) lc-ascii))
 723              (setq dpcell (list (cons LC
 724                                       (concat (cdr (car dpcell)) (cdr cell))
 725                                       )))
 726              )
 727             (t
 728              (setq dest (append dest dpcell))
 729              (setq dpcell (list cell))
 730              ))
 731       (setq i (+ i 1))
 732       (setq cell ncell)
 733       (setq ncell (nth (+ i 1) rl))
 734       )
 735     (setq dest (append dest dpcell))
 736     ))
 737
 738 (defun mime/separate-string-for-encoder (string)
 739   (let (lastspace)
 740     (if (string-match "[ \t]+$" string)
 741         (progn
 742           (setq lastspace (substring string
 743                                      (match-beginning 0)
 744                                      (match-end 0)))
 745           (setq string (substring string 0 (match-beginning 0)))
 746           ))
 747     (let ((rl (mime/separate-string-by-charset string))
 748           (i 0) len cell0 cell1 cell2 (dest nil))
 749       (setq len (length rl))
 750       (setq cell0 (nth 0 rl))
 751       (setq cell1 (nth 1 rl))
 752       (setq cell2 (nth 2 rl))
 753       (while (< i len)
 754         (cond ((and (not (eq (car cell0) lc-ascii))
 755                     (eq (car cell1) LC-space)
 756                     (not (eq (car cell2) lc-ascii))
 757                     )
 758                (setq dest
 759                      (append dest (list
 760                                    (cons
 761                                     (cdr (assoc (car cell0)
 762                                                 mime/lc-charset-and-encoding-alist))
 763                                     (concat (cdr cell0) (cdr cell1))
 764                                     ))))
 765                (setq i (+ i 2))
 766                (setq cell0 (nth i rl))
 767                (setq cell1 (nth (+ i 1) rl))
 768                (setq cell2 (nth (+ i 2) rl))
 769                )
 770               (t
 771                (setq dest
 772                      (append dest (list
 773                                    (cons
 774                                     (cdr (assoc (car cell0)
 775                                                 mime/lc-charset-and-encoding-alist))
 776                                     (cdr cell0)))))
 777                (setq i (+ i 1))
 778                (setq cell0 cell1)
 779                (setq cell1 cell2)
 780                (setq cell2 (nth (+ i 2) rl))
 781                ))
 782         )
 783       (append dest
 784               (if lastspace
 785                   (list (cons nil lastspace))))
 786       )))
 787
 788
 789
 790 ;;;
 791 ;;; basic functions for MIME header decoder
 792 ;;;
 793
 794 ;;; @ utility for decoder
 795 ;;;
 796
 797 (defun mime/unfolding ()
 798   (goto-char (point-min))
 799   (let (field beg end)
 800     (while (re-search-forward message/field-regexp nil t)
 801       (setq beg (match-beginning 0))
 802       (setq end  (match-end 0))
 803       (setq field (buffer-substring beg end))
 804       (if (string-match mime/encoded-word-regexp field)
 805           (progn
 806             (save-excursion
 807               (save-restriction
 808                 (narrow-to-region (goto-char beg) end)
 809                 (while (re-search-forward "\n[ \t]+" nil t)
 810                   (replace-match " ")
 811                   )
 812                 ))
 813             ))
 814       ))
 815   )
 816
 817 (defun mime/prepare-decode-message-header ()
 818   (mime/unfolding)
 819   (goto-char (point-min))
 820   (while (re-search-forward
 821           (concat (regexp-quote "?=")
 822                   "\\s +"
 823                   (regexp-quote "=?"))
 824           nil t)
 825     (replace-match "?==?")
 826     )
 827   )
 828
 829 (run-hooks 'mime/tiny-mime-load-hook)
 830
 831 ;;; @
 832 ;;; Local Variables:
 833 ;;; mode: emacs-lisp
 834 ;;; mode: outline-minor
 835 ;;; outline-regexp: ";;; @+\\|(......"
 836 ;;; End: