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