tm-body.el

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