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