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
  10 ;;; @ require modules
  11 ;;;
  12
  13 (require 'emu)
  14 (require 'mel)
  15 (require 'tl-header)
  16 (require 'tl-str)
  17 (require 'tm-def)
  18
  19
  20 ;;; @ version
  21 ;;;
  22
  23 (defconst mime/RCS-ID
  24   "$Id: tiny-mime.el,v 6.7 1995/09/20 12:17:28 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/encoded-text-regexp "[!->@-~]+")
  33 (defconst mime/encoded-word-regexp (concat (regexp-quote "=?")
  34                                            "\\("
  35                                            mime/charset-regexp
  36                                            "\\)"
  37                                            (regexp-quote "?")
  38                                            "\\(B\\|Q\\)"
  39                                            (regexp-quote "?")
  40                                            "\\("
  41                                            mime/encoded-text-regexp
  42                                            "\\)"
  43                                            (regexp-quote "?=")))
  44
  45 (defun mime/nth-string (s n)
  46   (if (stringp s)
  47       (substring s (match-beginning n) (match-end n))
  48     (buffer-substring (match-beginning n) (match-end n))))
  49
  50 (defun mime/encoded-word-charset (str)
  51   (mime/nth-string str 1))
  52
  53 (defun mime/encoded-word-encoding (str)
  54   (mime/nth-string str 2))
  55
  56 (defun mime/encoded-word-encoded-text (str)
  57   (mime/nth-string str 3))
  58
  59 (defun mime/rest-of-string (str)
  60   (if (stringp str)
  61       (substring str (match-end 0))
  62     (buffer-substring (match-end 0)(point-max))
  63     ))
  64
  65
  66 ;;; @ variables
  67 ;;;
  68
  69 (defvar mime/no-encoding-header-fields '("X-Nsubject" "Newsgroups"))
  70
  71 (defvar mime/use-X-Nsubject nil)
  72
  73
  74 ;;; @ Application Interface
  75 ;;;
  76
  77 ;;; @@ MIME header decoders
  78 ;;;
  79
  80 (defun mime/decode-encoded-text (charset encoding str)
  81   (let ((dest
  82          (cond ((string= "B" encoding)
  83                 (base64-decode-string str))
  84                ((string= "Q" encoding)
  85                 (q-encoding-decode-string str))
  86                (t (message "unknown encoding %s" encoding)
  87                   nil))))
  88     (if dest
  89         (mime/convert-string-to-emacs charset dest)
  90       )))
  91
  92 (defun mime/decode-encoded-word (word)
  93   (or (if (string-match mime/encoded-word-regexp word)
  94           (let ((charset (upcase (mime/encoded-word-charset word)))
  95                 (encoding (upcase (mime/encoded-word-encoding word)))
  96                 (text (mime/encoded-word-encoded-text word)))
  97             (mime/decode-encoded-text charset encoding text)
  98             ))
  99       word))
 100
 101 (defun mime/decode-region (beg end)
 102   (interactive "*r")
 103   (save-excursion
 104     (save-restriction
 105       (narrow-to-region beg end)
 106       (goto-char (point-min))
 107       (let (charset encoding text)
 108         (while (re-search-forward mime/encoded-word-regexp nil t)
 109           (insert (mime/decode-encoded-word
 110                    (prog1
 111                        (buffer-substring (match-beginning 0) (match-end 0))
 112                      (delete-region (match-beginning 0) (match-end 0))
 113                      )
 114                   ))
 115           ))
 116       )))
 117
 118 (defun mime/decode-message-header ()
 119   (interactive "*")
 120   (save-excursion
 121     (save-restriction
 122       (narrow-to-region (goto-char (point-min))
 123                         (progn (re-search-forward "^$" nil t) (point)))
 124       (mime/prepare-decode-message-header)
 125       (mime/decode-region (point-min) (point-max))
 126       )))
 127
 128 (defun mime/decode-string (str)
 129   (let ((dest "")(ew nil)
 130         beg end)
 131     (while (setq beg (string-match mime/encoded-word-regexp str))
 132       (if (> beg 0)
 133           (if (not (and (eq ew t) (string= (substring str 0 beg) " ")))
 134               (setq dest (concat dest (substring str 0 beg)
 135                                  ))
 136             )
 137         )
 138       (setq end (match-end 0))
 139       (setq dest (concat dest
 140                          (mime/decode-encoded-word (substring str beg end))
 141                          ))
 142       (setq str (substring str end))
 143       (setq ew t)
 144       )
 145     (concat dest str)
 146     ))
 147
 148 ;;; @@ MIME header encoders
 149 ;;;
 150
 151 (defun mime/encode-string (string encoding &optional mode)
 152   (cond ((string= encoding "B") (base64-encode-string string))
 153         ((string= encoding "Q") (q-encoding-encode-string string mode))
 154         ))
 155
 156 (defun mime/encode-field (str)
 157   (setq str (message/unfolding-string str))
 158   (let ((ret (message/divide-field str))
 159         field-name field-body)
 160     (setq field-name (car ret))
 161     (setq field-body (nth 1 ret))
 162     (concat field-name " "
 163             (cond ((string= field-body "") "")
 164                   ((or (string-match "^Reply-To:$" field-name)
 165                        (string-match "^From:$" field-name)
 166                        (string-match "^Sender:$" field-name)
 167                        (string-match "^Resent-Reply-To:$" field-name)
 168                        (string-match "^Resent-From:$" field-name)
 169                        (string-match "^Resent-Sender:$" field-name)
 170                        (string-match "^To:$" field-name)
 171                        (string-match "^Resent-To:$" field-name)
 172                        (string-match "^cc:$" field-name)
 173                        (string-match "^Resent-cc:$" field-name)
 174                        (string-match "^bcc:$" field-name)
 175                        (string-match "^Resent-bcc:$" field-name)
 176                        )
 177                    (mime/encode-address-list
 178                     (+ (length field-name) 1) field-body)
 179                    )
 180                   (t
 181                    (catch 'tag
 182                      (let ((r mime/no-encoding-header-fields) fn)
 183                        (while r
 184                          (setq fn (car r))
 185                          (if (string-match (concat "^" fn ":$") field-name)
 186                              (throw 'tag field-body)
 187                            )
 188                          (setq r (cdr r))
 189                          ))
 190                      (nth 1 (mime/encode-header-string
 191                              (+ (length field-name) 1) field-body))
 192                      ))
 193                   ))
 194     ))
 195
 196 (defun mime/exist-encoded-word-in-subject ()
 197   (let ((str (message/get-field-body "Subject")))
 198     (if (and str (string-match mime/encoded-word-regexp str))
 199         str)))
 200
 201 (defun mime/encode-message-header ()
 202   (interactive "*")
 203   (save-excursion
 204     (save-restriction
 205       (narrow-to-region (goto-char (point-min))
 206                         (progn
 207                           (re-search-forward
 208                            (concat
 209                             "^" (regexp-quote mail-header-separator) "$")
 210                            nil t)
 211                           (match-beginning 0)
 212                           ))
 213       (goto-char (point-min))
 214       (let (beg end field)
 215         (while (re-search-forward "^.+:.*\\(\n\\s +.*\\)*" nil t)
 216           (setq beg (match-beginning 0))
 217           (setq end  (match-end 0))
 218           (setq field (buffer-substring beg end))
 219           (insert (mime/encode-field
 220                    (prog1
 221                        (buffer-substring beg end)
 222                      (delete-region beg end)
 223                      )))
 224           ))
 225       (if mime/use-X-Nsubject
 226           (let ((str (mime/exist-encoded-word-in-subject)))
 227             (if str
 228                 (insert (concat
 229                          "\nX-Nsubject: "
 230                          (mime/decode-string (message/unfolding-string str))
 231                          )))))
 232       )))
 233
 234
 235 ;;; @ functions for message header encoding
 236 ;;;
 237
 238 (defun mime/encode-and-split-string (n string charset encoding)
 239   (let ((i 0) (j 0)
 240         (len (length string))
 241         (js (mime/convert-string-from-emacs string charset))
 242         (cesl (+ (length charset) (length encoding) 6 ))
 243         ewl m rest)
 244     (setq ewl (mime/encoded-word-length js encoding))
 245     (if (null ewl) nil
 246       (progn
 247         (setq m (+ n ewl cesl))
 248         (if (> m 76)
 249             (progn
 250               (while (and (< i len)
 251                           (setq js (mime/convert-string-from-emacs
 252                                     (substring string 0 i) charset))
 253                           (setq m (+ n
 254                                      (mime/encoded-word-length js encoding)
 255                                      cesl))
 256                           (< m 76))
 257                 (setq j i)
 258                 (setq i (+ i (char-bytes (elt string i))))
 259                 )
 260               (setq js (mime/convert-string-from-emacs
 261                         (substring string 0 j) charset))
 262               (setq m (+ n (mime/encoded-word-length js encoding) cesl))
 263               (setq rest (substring string j))
 264               )
 265           (setq rest nil))
 266         (if (string= js "")
 267             (list 1 "" string)
 268           (list m (concat "=?" charset "?" encoding "?"
 269                           (mime/encode-string js encoding)
 270                           "?=") rest))
 271         ))
 272     ))
 273
 274 (defun mime/encode-header-word (n string charset encoding)
 275   (let (dest str ret m)
 276     (if (null (setq ret
 277                     (mime/encode-and-split-string n string charset encoding)))
 278         nil
 279       (progn
 280         (setq dest (nth 1 ret))
 281         (setq m (car ret))
 282         (setq str (nth 2 ret))
 283         (while (and (stringp str)
 284                     (setq ret
 285                           (mime/encode-and-split-string
 286                            1 str charset encoding))
 287                     )
 288           (setq dest (concat dest "\n " (nth 1 ret)))
 289           (setq m (car ret))
 290           (setq str (nth 2 ret))
 291           )
 292         (list m dest)
 293         ))
 294     ))
 295
 296 (defun mime/encode-header-string (n string &optional mode)
 297   (if (string= string "")
 298       (list n "")
 299     (let ((ssl (mime/separate-string-for-encoder string))
 300           i len cell et w ew (dest "") b l)
 301       (setq len (length ssl))
 302       (setq cell (nth 0 ssl))
 303       (setq et (car cell))
 304       ;; string-width crashes when the argument is nil,
 305       ;; so replace the argument
 306       ;; (original modification by Kenji Rikitake 9-JAN-1995)
 307       (setq w (or (cdr cell) ""))
 308       (if (eq et nil)
 309           (progn
 310             (if (> (+ n (string-width w)) 76)
 311                 (progn
 312                   (setq dest (concat dest "\n "))
 313                   (setq b 1)
 314                   )
 315               (setq b n))
 316             (setq dest (concat dest w))
 317             (setq b (+ b (string-width w)))
 318             )
 319         (progn
 320           (setq ew (mime/encode-header-word n (cdr cell) (car et) (cdr et)))
 321           (setq dest (nth 1 ew))
 322           (setq b (car ew))
 323           ))
 324       (setq i 1)
 325       (while (< i len)
 326         (setq cell (nth i ssl))
 327         (setq et (car cell))
 328         (setq w (cdr cell))
 329         (cond ((string-match "^[ \t]*$" w)
 330                (setq b (+ b (string-width (cdr cell))))
 331                (setq dest (concat dest (cdr cell)))
 332                )
 333               ((eq et nil)
 334                (if (> (+ b (string-width w)) 76)
 335                    (progn
 336                      (if (eq (elt dest (- (length dest) 1)) 32)
 337                          (setq dest (substring dest 0 (- (length dest) 1)))
 338                        )
 339                      (setq dest (concat dest "\n " w))
 340                      (setq b (+ (length w) 1))
 341                      )
 342                  (setq l (length dest))
 343                  (if (and (>= l 2)
 344                           (eq (elt dest (- l 2)) ?\?)
 345                           (eq (elt dest (- l 1)) ?=)
 346                           )
 347                      (progn
 348                        (setq dest (concat dest " "))
 349                        (setq b (+ b 1))
 350                        ))
 351                  (setq dest (concat dest w))
 352                  (setq b (+ b (string-width w)))
 353                  ))
 354               (t
 355                (if (not (eq (elt dest (- (length dest) 1)) 32))
 356                    (progn
 357                      (setq dest (concat dest " "))
 358                      (setq b (+ b 1))
 359                      ))
 360                (setq ew
 361                      (mime/encode-header-word b (cdr cell) (car et) (cdr et)))
 362                (setq b (car ew))
 363                (if (string-match "^\n" (nth 1 ew))
 364                    (setq dest (concat (substring dest 0 (- (length dest) 1))
 365                                       (nth 1 ew)))
 366                  (setq dest (concat dest (nth 1 ew)))
 367                  )
 368                ))
 369         (setq i (+ i 1))
 370         )
 371       (list b dest)
 372       )))
 373
 374 (defun mime/encode-address-list (n str)
 375   (let* ((ret (message/parse-addresses str))
 376          (r ret) cell en-ret j cl (dest "") s)
 377     (while r
 378       (setq cell (car r))
 379       (cond ((string= (nth 1 cell) "<")
 380              (setq en-ret (mime/encode-header-string n (nth 0 cell) 'phrase))
 381              (setq dest (concat dest (nth 1 en-ret)))
 382              (setq n (car en-ret))
 383              (if (> (length r) 1)
 384                  (setq en-ret
 385                        (mime/encode-header-string
 386                         n (concat (nth 1 cell)(nth 2 cell)(nth 3 cell) ", ")))
 387                (setq en-ret (mime/encode-header-string
 388                              n (concat (nth 1 cell)(nth 2 cell)(nth 3 cell))))
 389                )
 390              (if (and (eq (elt (nth 1 en-ret) 0) ?\n)
 391                       (eq (elt dest (- (length dest) 1)) 32))
 392                  (setq dest (substring dest 0 (- (length dest) 1)))
 393                )
 394              (setq dest (concat dest (nth 1 en-ret)))
 395              (setq n (car en-ret))
 396              )
 397             ((= (length cell) 4)
 398              (setq en-ret (mime/encode-header-string n (nth 0 cell)))
 399              (setq dest (concat dest (nth 1 en-ret)))
 400              (setq n (car en-ret))
 401
 402              (setq en-ret (mime/encode-header-string (+ n 2) (nth 2 cell)
 403                                                      'comment))
 404              (if (eq (elt (nth 1 en-ret) 0) ?\n)
 405                  (progn
 406                    (setq dest (concat dest "\n ("))
 407                    (setq en-ret (mime/encode-header-string 2 (nth 2 cell)
 408                                                            'comment))
 409                    )
 410                (progn
 411                  (setq dest (concat dest " ("))
 412                  ))
 413              (setq dest (concat dest (nth 1 en-ret)))
 414              (setq n (car en-ret))
 415              (if (> (length r) 1)
 416                  (setq en-ret
 417                        (mime/encode-header-string n (concat (nth 3 cell) ", "))
 418                        )
 419                (setq en-ret (mime/encode-header-string n (nth 3 cell)))
 420                )
 421              (setq dest (concat dest (nth 1 en-ret)))
 422              (setq n (car en-ret))
 423              )
 424             (t
 425              (if (> (length r) 1)
 426                  (setq en-ret
 427                        (mime/encode-header-string n (concat (nth 0 cell) ", "))
 428                        )
 429                (setq en-ret (mime/encode-header-string n (nth 0 cell)))
 430                )
 431              (setq dest (concat dest (nth 1 en-ret)))
 432              (setq n (car en-ret))
 433              ))
 434       (setq r (cdr r))
 435       )
 436     dest))
 437
 438
 439 ;;; @ utility for encoder
 440 ;;;
 441
 442 ;;; @@ encoded-word length
 443 ;;;
 444
 445 (defun mime/encoded-word-length (string encoding)
 446   (cond ((equal encoding "B") (mime/base64-length string))
 447         ((equal encoding "Q") (mime/Quoted-Printable-length string))
 448         (t nil)
 449         ))
 450
 451 (defun mime/base64-length (string)
 452   (let ((l (length string))
 453         )
 454     (* (+ (/ l 3)
 455           (if (= (mod l 3) 0) 0 1)
 456           ) 4)
 457     ))
 458
 459 (defun mime/Quoted-Printable-length (string &optional mode)
 460   (let ((l 0)(i 0)(len (length string)) chr)
 461     (while (< i len)
 462       (setq chr (elt string i))
 463       (if (string-match "[A-Za-z0-9!*+/=_---]" (char-to-string chr))
 464           (setq l (+ l 1))
 465         (setq l (+ l 3))
 466         )
 467       (setq i (+ i 1)) )
 468     l))
 469
 470 ;;; @@ separate by character set
 471 ;;;
 472
 473 ;; by mol. 1993/11/2
 474 (defconst LC-space 2)
 475
 476 ;; by mol. 1993/10/16
 477 (defun mime/char-type (chr)
 478   (if (or (= chr 32)(= chr ?\t))
 479       LC-space
 480     (get-lc chr)
 481     ))
 482
 483 (defun mime/separate-string-by-chartype (string)
 484   (let ((len (length string))
 485         (dest nil) (ds "") s
 486         pcs i j cs chr)
 487     (if (= len 0) nil
 488       (progn
 489         (setq chr (elt string 0))
 490         (setq pcs (mime/char-type chr))
 491         (setq i (char-bytes chr))
 492         (setq ds (substring string 0 i))
 493         (while (< i len)
 494           (setq chr (elt string i))
 495           (setq cs (mime/char-type chr))
 496           (setq j (+ i (char-bytes chr)))
 497           (setq s (substring string i j))
 498           (setq i j)
 499           (if (= cs pcs)
 500               (setq ds (concat ds s))
 501             (progn (setq dest (append dest (list (cons pcs ds))))
 502                    (setq pcs cs)
 503                    (setq ds s)
 504                    ))
 505           )
 506         (if (not (string= ds ""))
 507             (setq dest (append dest (list (cons pcs ds)))))
 508         dest)
 509       )))
 510
 511 (defun mime/separate-string-by-charset (str)
 512   (let ((rl (mime/separate-string-by-chartype str))
 513         (i 1) len (pcell nil) cell ncell dpcell (dest nil) LC)
 514     (setq len (length rl))
 515     (setq dpcell (list (nth 0 rl)))
 516     (setq cell (nth 1 rl))
 517     (setq ncell (nth 2 rl))
 518     (while (< i len)
 519       (setq LC (car (car dpcell)))
 520       (cond ((and (not (eq LC lc-ascii))
 521                   (eq (car cell) LC-space)
 522                   (not (eq (car ncell) lc-ascii)))
 523              (setq dpcell (list (cons LC
 524                                       (concat (cdr (car dpcell)) (cdr cell))
 525                                       )))
 526              )
 527             ((and (not (eq LC lc-ascii))
 528                   (eq LC (car cell)))
 529              (setq dpcell (list (cons LC
 530                                       (concat (cdr (car dpcell)) (cdr cell))
 531                                       )))
 532              )
 533             ((and (eq LC lc-ascii)
 534                   (member (car cell) mime/latin-lc-list))
 535              (setq dpcell (list (cons (car cell)
 536                                       (concat (cdr (car dpcell)) (cdr cell))
 537                                       )))
 538              )
 539             ((and (member LC mime/latin-lc-list)
 540                   (eq (car cell) lc-ascii))
 541              (setq dpcell (list (cons LC
 542                                       (concat (cdr (car dpcell)) (cdr cell))
 543                                       )))
 544              )
 545             (t
 546              (setq dest (append dest dpcell))
 547              (setq dpcell (list cell))
 548              ))
 549       (setq i (+ i 1))
 550       (setq cell ncell)
 551       (setq ncell (nth (+ i 1) rl))
 552       )
 553     (setq dest (append dest dpcell))
 554     ))
 555
 556 (defun mime/separate-string-for-encoder (string)
 557   (let (lastspace)
 558     (if (string-match "[ \t]+$" string)
 559         (progn
 560           (setq lastspace (substring string
 561                                      (match-beginning 0)
 562                                      (match-end 0)))
 563           (setq string (substring string 0 (match-beginning 0)))
 564           ))
 565     (let ((rl (mime/separate-string-by-charset string))
 566           (i 0) len cell0 cell1 cell2 (dest nil))
 567       (setq len (length rl))
 568       (setq cell0 (nth 0 rl))
 569       (setq cell1 (nth 1 rl))
 570       (setq cell2 (nth 2 rl))
 571       (while (< i len)
 572         (cond ((and (not (eq (car cell0) lc-ascii))
 573                     (eq (car cell1) LC-space)
 574                     (not (eq (car cell2) lc-ascii))
 575                     )
 576                (setq dest
 577                      (append dest (list
 578                                    (cons
 579                                     (cdr (assoc (car cell0)
 580                                                 mime/lc-charset-and-encoding-alist))
 581                                     (concat (cdr cell0) (cdr cell1))
 582                                     ))))
 583                (setq i (+ i 2))
 584                (setq cell0 (nth i rl))
 585                (setq cell1 (nth (+ i 1) rl))
 586                (setq cell2 (nth (+ i 2) rl))
 587                )
 588               (t
 589                (setq dest
 590                      (append dest (list
 591                                    (cons
 592                                     (cdr (assoc (car cell0)
 593                                                 mime/lc-charset-and-encoding-alist))
 594                                     (cdr cell0)))))
 595                (setq i (+ i 1))
 596                (setq cell0 cell1)
 597                (setq cell1 cell2)
 598                (setq cell2 (nth (+ i 2) rl))
 599                ))
 600         )
 601       (append dest
 602               (if lastspace
 603                   (list (cons nil lastspace))))
 604       )))
 605
 606
 607
 608 ;;;
 609 ;;; basic functions for MIME header decoder
 610 ;;;
 611
 612 ;;; @ utility for decoder
 613 ;;;
 614
 615 (defun mime/unfolding ()
 616   (goto-char (point-min))
 617   (let (field beg end)
 618     (while (re-search-forward message/field-name-regexp nil t)
 619       (setq beg (match-beginning 0))
 620       (setq end (message/field-end))
 621       (setq field (buffer-substring beg end))
 622       (if (string-match mime/encoded-word-regexp field)
 623           (save-restriction
 624             (narrow-to-region (goto-char beg) end)
 625             (while (re-search-forward "\n[ \t]+" nil t)
 626               (replace-match " ")
 627               )
 628             (goto-char (point-max))
 629             ))
 630       )))
 631
 632 (defun mime/prepare-decode-message-header ()
 633   (mime/unfolding)
 634   (goto-char (point-min))
 635   (while (re-search-forward
 636           (concat (regexp-quote "?=")
 637                   "\\s +"
 638                   (regexp-quote "=?"))
 639           nil t)
 640     (replace-match "?==?")
 641     )
 642   )
 643
 644 (run-hooks 'mime/tiny-mime-load-hook)
 645
 646 (provide 'tiny-mime)
 647
 648 ;;; @
 649 ;;; Local Variables:
 650 ;;; mode: emacs-lisp
 651 ;;; mode: outline-minor
 652 ;;; outline-regexp: ";;; @+\\|(......"
 653 ;;; End: