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