tm-body.el

   1 ;;;
   2 ;;; $Id: tm-body.el,v 0.14 1994/08/03 05:31:33 morioka Exp $
   3 ;;;
   4
   5 (provide 'tm-body)
   6
   7 (require 'tl-list)
   8 (require 'tl-header)
   9 (require 'tiny-mime)
  10
  11 (defun replace-as-filename (str)
  12   (let ((dest "")
  13         (i 0)(len (length str))
  14         chr)
  15     (while (< i len)
  16       (setq chr (elt str i))
  17       (if (or (and (<= ?+ chr)(<= chr ?.))
  18               (and (<= ?0 chr)(<= chr ?:))
  19               (= chr ?=)
  20               (and (<= ?@ chr)(<= chr ?\[))
  21               (and (<= ?\] chr)(<= chr ?_))
  22               (and (<= ?a chr)(<= chr ?{))
  23               (and (<= ?} chr)(<= chr ?~))
  24               )
  25           (setq dest (concat dest
  26                              (char-to-string chr)))
  27         )
  28       (setq i (+ i 1))
  29       )
  30     dest))
  31
  32 (defconst mime/tspecials "\000-\040()<>@,;:\\\"/[\093?.=")
  33 (defconst mime/token-regexp
  34   (concat "[^" mime/tspecials "]*"))
  35 (defconst mime/content-type-subtype-regexp
  36   (concat mime/token-regexp "/" mime/token-regexp))
  37 (defconst mime/content-parameter-value-regexp
  38   (concat "\\("
  39           message/quoted-string-regexp
  40           "\\|[^; \t\n]\\)*"))
  41
  42 (defconst mime/output-buffer-name "*MIME-out*")
  43 (defconst mime/decoding-buffer-name "*MIME-decoding*")
  44
  45 (defvar mime/content-decoding-method-alist
  46   '(("text/plain"   . "tm-plain")
  47     ("text/x-latex" . "tm-latex")
  48     ("audio/basic"  . "tm-au")
  49     ("image/gif"    . "tm-image")
  50     ("image/jpeg"   . "tm-image")
  51     ("image/tiff"   . "tm-image")
  52     ("image/x-tiff" . "tm-image")
  53     ("image/x-pic"  . "tm-image")
  54     ("video/mpeg"   . "tm-mpeg")
  55     ("application/octet-stream" . "tm-file")
  56     ))
  57 ;;; (setq mime/content-decoding-method-alist
  58 ;;;   '(("audio/basic" . "tm-au")
  59 ;;;     ("image/gif"   . "tm-image")
  60 ;;;     ("image/jpeg"  . "tm-image")
  61 ;;;     ("image/x-pic" . "tm-image")
  62 ;;;     ("video/mpeg"  . "tm-mpeg")
  63 ;;;     ("application/octet-stream" . "tm-file")
  64 ;;;     ))
  65 (defvar mime/use-internal-decoder nil)
  66 ;;; (setq mime/use-internal-decoder t)
  67
  68 (defun mime/decode-body ()
  69   (interactive)
  70   (if (get-buffer mime/output-buffer-name)
  71       (kill-buffer mime/output-buffer-name))
  72   (save-excursion
  73     (save-restriction
  74       (goto-char (point-min))
  75       (let ((ctype (mime/Content-Type "^$"))
  76             (encoding (mime/Content-Transfer-Encoding "^$" "7bit"))
  77             )
  78         (if ctype
  79             (cond ((equal (car ctype) "multipart/mixed")
  80                    (mime/decode-multipart/mixed ctype encoding)
  81                    )
  82                   ((equal (car ctype) "message/partial")
  83                    (mime/decode-message/partial ctype encoding)
  84                    )
  85                   (t
  86                    (mime/decode-content nil (car ctype) encoding
  87                                         (mime/get-name ctype))
  88                    ))
  89           )))))
  90
  91 (defun mime/decode-multipart/mixed (ctype default-encoding)
  92   (let ((boundary (cdr (assoc "boundary" (cdr ctype))))
  93         encoding b)
  94     (if (eq (elt boundary 0) ?\")
  95         (setq boundary
  96               (substring boundary 1 (- (length boundary) 1))
  97               ))
  98     (setq boundary (concat "^--" (regexp-quote boundary) "\\(--\\)?$"))
  99     (while (re-search-forward boundary nil t)
 100       (goto-char (point-min))
 101       (setq b (+ (match-end 0) 1))
 102       (goto-char b)
 103       (and (setq ctype (mime/Content-Type))
 104            (setq encoding
 105                  (mime/Content-Transfer-Encoding boundary
 106                                                  default-encoding))
 107            (mime/decode-content boundary
 108                                 (car ctype) encoding
 109                                 (mime/get-name ctype))
 110            )
 111       )))
 112
 113 (defun mime/decode-message/partial (ctype default-encoding)
 114   (let ((root-dir (concat "/tmp/m-prts-" (user-login-name)))
 115         (id (cdr (assoc "id" (cdr ctype))))
 116         (number (cdr (assoc "number" (cdr ctype))))
 117         (total (cdr (assoc "total" (cdr ctype))))
 118         file
 119         (the-buf (current-buffer))
 120         )
 121     (if (not (file-exists-p root-dir))
 122         (shell-command (concat "mkdir " root-dir))
 123       )
 124     (setq id (replace-as-filename id))
 125     (setq root-dir (concat root-dir "/" id))
 126     (if (not (file-exists-p root-dir))
 127         (shell-command (concat "mkdir " root-dir))
 128       )
 129     (setq file (concat root-dir "/FULL"))
 130     (if (not (file-exists-p file))
 131         (progn
 132           (setq file (concat root-dir "/CT"))
 133           (if (not (file-exists-p file))
 134               (progn
 135                 (if (get-buffer "*MIME-temp*")
 136                     (kill-buffer "*MIME-temp*")
 137                   )
 138                 (switch-to-buffer "*MIME-temp*")
 139                 (insert (concat total "\n"))
 140                 (write-file file)
 141                 (switch-to-buffer the-buf)
 142                 ))
 143           (re-search-forward "^$")
 144           (goto-char (+ (match-end 0) 1))
 145           (setq file (concat root-dir "/" number))
 146           (write-region (point)
 147                         (point-max)
 148                         file)
 149           (if (get-buffer "*MIME-temp*")
 150               (kill-buffer "*MIME-temp*")
 151             )
 152           (switch-to-buffer "*MIME-temp*")
 153           (let ((i 1)
 154                 (max (string-to-int total))
 155                 )
 156             (catch 'tag
 157               (while (<= i max)
 158                 (setq file (concat root-dir "/"
 159                                    (int-to-string i)
 160                                    ))
 161                 (if (not (file-exists-p file))
 162                     (throw 'tag nil))
 163                 (insert-file-contents file)
 164                 (goto-char (point-max))
 165                 (setq i (+ i 1))
 166                 )
 167               (write-file (concat root-dir "/FULL"))
 168               (mime/decode-body)
 169               (kill-buffer "FULL")
 170               ))
 171           (switch-to-buffer the-buf)
 172           )
 173       (progn
 174         (find-file file)
 175         (mime/decode-body)
 176         (kill-buffer "FULL")
 177         ))
 178     ))
 179
 180 (defun mime/get-name (ctype)
 181   (replace-as-filename
 182    (or (cdr (assoc "name" (cdr ctype)))
 183        (cdr (assoc "x-name" (cdr ctype)))
 184        (message/get-field-body "Content-Description")
 185        "")))
 186
 187 (defun mime/narrow-to-content (boundary)
 188   (if boundary
 189       (progn
 190         (narrow-to-region (point)
 191                           (progn
 192                             (re-search-forward boundary nil t)
 193                             (match-beginning 0)
 194                             ))
 195         (goto-char (point-min))
 196         )))
 197
 198 (defun mime/Content-Type (&optional boundary)
 199   (save-excursion
 200     (save-restriction
 201       (mime/narrow-to-content boundary)
 202       (if (and (re-search-forward "^Content-Type:[ \t]*" nil t)
 203                  (progn
 204                    (narrow-to-region
 205                     (point)
 206                     (and (re-search-forward ".*\\(\n[ \t].*\\)*" nil t)
 207                          (match-end 0))
 208                     )
 209                    (goto-char (point-min))
 210                    (re-search-forward mime/content-type-subtype-regexp nil t)
 211                    ))
 212             (let ((ctype
 213                    (downcase
 214                     (buffer-substring (match-beginning 0) (match-end 0))
 215                     ))
 216                   dest attribute value)
 217               (while (and (re-search-forward "[ \t\n]*;[ \t\n]*" nil t)
 218                           (re-search-forward mime/token-regexp nil t)
 219                           )
 220                 (setq attribute
 221                       (downcase
 222                        (buffer-substring (match-beginning 0) (match-end 0))
 223                        ))
 224                 (if (and (re-search-forward "=[ \t\n]*" nil t)
 225                          (re-search-forward mime/content-parameter-value-regexp
 226                                             nil t)
 227                          )
 228                     (setq dest
 229                           (put-alist attribute
 230                                      (buffer-substring (match-beginning 0)
 231                                                        (match-end 0))
 232                                      dest))
 233                   )
 234                 )
 235               (cons ctype dest)
 236               )))))
 237
 238 (defun mime/Content-Transfer-Encoding (&optional boundary default-encoding)
 239   (save-excursion
 240     (save-restriction
 241       (mime/narrow-to-content boundary)
 242       (or
 243        (if (and (re-search-forward "^Content-Transfer-Encoding:[ \t]*" nil t)
 244                 (re-search-forward mime/token-regexp nil t)
 245                 )
 246            (downcase (buffer-substring (match-beginning 0) (match-end 0)))
 247          )
 248        default-encoding)
 249       )))
 250
 251 (defun mime/base64-decode-region (beg end &optional buf filename)
 252   (let ((the-buf (current-buffer)) ret)
 253     (if (null buf)
 254         (setq buf (get-buffer-create mime/decoding-buffer-name))
 255       )
 256     (save-excursion
 257       (save-restriction
 258         (switch-to-buffer buf)
 259         (erase-buffer)
 260         (switch-to-buffer the-buf)
 261         (narrow-to-region beg end)
 262         (goto-char (point-min))
 263         (while (re-search-forward
 264                 (concat "^"
 265                         mime/Base64-encoded-text-regexp
 266                         "$") nil t)
 267           (setq ret (mime/base64-decode-string
 268                      (buffer-substring (match-beginning 0)
 269                                        (match-end 0)
 270                                        )))
 271           (switch-to-buffer buf)
 272           (insert ret)
 273           (switch-to-buffer the-buf)
 274           )))
 275     (if filename
 276         (progn
 277           (switch-to-buffer buf)
 278           (let ((kanji-flag nil)
 279                 (mc-flag nil)
 280                 (file-coding-system
 281                  (if (featurep 'mule) *noconv*))
 282                 )
 283             (write-file filename)
 284             (kill-buffer buf)
 285             (switch-to-buffer the-buf)
 286             )))
 287     ))
 288
 289 (defun mime/decode-content (boundary ctype encoding name)
 290   (let ((method (cdr (assoc ctype mime/content-decoding-method-alist))))
 291     (if method
 292         (save-excursion
 293           (save-restriction
 294             (re-search-forward "^$")
 295             (goto-char (+ (match-end 0) 1))
 296             (let ((file (make-temp-name "/tmp/TM"))
 297                   (b (point)) e
 298                   )
 299               (setq e (if boundary
 300                           (and (re-search-forward boundary nil t)
 301                                (match-beginning 0))
 302                         (point-max)
 303                         ))
 304               (if (and (string= encoding "base64")
 305                        mime/use-internal-decoder)
 306                   (progn
 307                     (mime/base64-decode-region b e nil file)
 308                     (setq encoding "binary")
 309                     )
 310                 (write-region b e file)
 311                 )
 312               (start-process method mime/output-buffer-name method file
 313                              ctype (if encoding
 314                                        encoding
 315                                      "7bit")
 316                              (if mime/body-decoding-mode
 317                                  mime/body-decoding-mode
 318                                "decode")
 319                              (replace-as-filename name))
 320               ))))))
 321
 322 (defun mime/show-body-decoded-result ()
 323   (interactive)
 324   (if (get-buffer mime/output-buffer-name)
 325       (set-window-buffer (get-largest-window)
 326                          mime/output-buffer-name)
 327     ))