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