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