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