tm-view.el

   1 ;;;
   2 ;;; A MIME viewer for GNU Emacs
   3 ;;;
   4 ;;; by Morioka Tomohiko, 1994/07/13
   5
   6 (provide 'tm-view)
   7
   8
   9 ;;; @ version
  10 ;;;
  11
  12 (defconst mime/viewer-RCS-ID
  13   "$Id: tm-view.el,v 3.1 1994/08/31 07:16:10 morioka Exp $")
  14
  15 (defconst mime/viewer-version
  16   (and (string-match "[0-9][0-9.]*" mime/viewer-RCS-ID)
  17        (substring mime/viewer-RCS-ID (match-beginning 0)(match-end 0))
  18        ))
  19
  20
  21 ;;; @ require modules
  22 ;;;
  23
  24 (require 'outline)
  25 (require 'tl-str)
  26 (require 'tl-list)
  27 (require 'tl-header)
  28 (require 'tiny-mime)
  29
  30
  31 ;;; @ constants
  32 ;;;
  33
  34 (defconst mime/tspecials "\000-\040()<>@,;:\\\"/[\093?.=")
  35 (defconst mime/token-regexp
  36   (concat "[^" mime/tspecials "]*"))
  37 (defconst mime/content-type-subtype-regexp
  38   (concat mime/token-regexp "/" mime/token-regexp))
  39 (defconst mime/content-parameter-value-regexp
  40   (concat "\\("
  41           message/quoted-string-regexp
  42           "\\|[^; \t\n]\\)*"))
  43
  44 (defconst mime/output-buffer-name "*MIME-out*")
  45 (defconst mime/decoding-buffer-name "*MIME-decoding*")
  46
  47
  48 ;;; @ variables
  49 ;;;
  50
  51 (defvar mime/content-decoding-method-alist
  52   '(("text/plain"   . "tm-plain")
  53     ("text/x-latex" . "tm-latex")
  54     ("audio/basic"  . "tm-au")
  55     ("image/gif"    . "tm-image")
  56     ("image/jpeg"   . "tm-image")
  57     ("image/tiff"   . "tm-image")
  58     ("image/x-tiff" . "tm-image")
  59     ("image/x-xbm"  . "tm-image")
  60     ("image/x-pic"  . "tm-image")
  61     ("video/mpeg"   . "tm-mpeg")
  62     ("application/octet-stream" . "tm-file")
  63     ))
  64
  65 (defvar mime/default-showing-Content-Type-list
  66   '("text/plain" "text/x-latex" "message/rfc822"))
  67
  68 (setq mime/default-showing-Content-Type-list
  69       '("text/plain" "text/x-latex" "message/rfc822"))
  70
  71 (defvar mime/go-to-top-node-method-alist
  72   '((gnus-article-mode . (lambda ()
  73                            (gnus-article-show-summary)
  74                            ))
  75     (rmail-mode . (lambda ()
  76                     (mime/exit-view-mode)
  77                     (rmail-summary)
  78                     (delete-other-windows)
  79                     ))
  80     (mh-show-mode . (lambda ()
  81                       (pop-to-buffer
  82                        (let ((name (buffer-name)))
  83                          (string-match "show-" name)
  84                          (substring name (match-end 0))
  85                          ))
  86                       ))
  87     (mime/show-message-mode . (lambda ()
  88                                 (set-window-configuration
  89                                  mime/show-mode-old-window-configuration)
  90                                 (let ((buf (current-buffer)))
  91                                   (pop-to-buffer mime/mother-buffer)
  92                                   (kill-buffer buf)
  93                                   )))
  94     ))
  95
  96 (defvar mime/tmp-dir "/tmp/")
  97
  98 (defvar mime/use-internal-decoder nil)
  99
 100 (defvar mime/body-decoding-mode "play" "MIME body decoding mode")
 101
 102
 103 ;;; @ parser
 104 ;;;
 105
 106 (defun mime/parse-content ()
 107   (save-excursion
 108     (save-restriction
 109       (mime/decode-message-header)
 110       (goto-char (point-min))
 111       (let* ((ctl (mime/Content-Type))
 112              (boundary (assoc "boundary" (cdr ctl)))
 113              beg end dest)
 114         (search-forward "\n\n" nil t)
 115         (cond (boundary
 116                (let ((sep (concat "\n--"
 117                                   (setq boundary (read (cdr boundary)))
 118                                   "\n"))
 119                      cb ce ct ret ncb)
 120                  (setq beg (match-end 0))
 121                  (search-forward (concat "\n--" boundary "--\n") nil t)
 122                  (setq end (match-beginning 0))
 123                  (save-excursion
 124                    (save-restriction
 125                      (narrow-to-region beg end)
 126                      (goto-char (point-min))
 127                      (search-forward (concat "--" boundary "\n") nil t)
 128                      (setq cb (match-end 0))
 129                      (while (search-forward sep nil t)
 130                        (setq ce (match-beginning 0))
 131                        (setq ncb (match-end 0))
 132                        (save-excursion
 133                          (save-restriction
 134                            (narrow-to-region cb ce)
 135                            (setq ret (mime/parse-content))
 136                            ))
 137                        (setq dest (append dest (list ret)))
 138                        (goto-char (nth 1 ret))
 139                        (search-forward (concat "--" boundary "\n") nil t)
 140                        (goto-char (setq cb (match-end 0)))
 141                        )
 142                      (setq ce (point-max))
 143                      (save-excursion
 144                        (save-restriction
 145                          (narrow-to-region cb ce)
 146                          (setq ret (mime/parse-content))
 147                          ))
 148                      (setq dest (append dest (list ret)))
 149                      ))
 150                  (setq beg (point-min))
 151                  (goto-char beg)
 152                  (search-forward (concat "\n--" boundary "--\n") nil t)
 153                  (setq end (match-beginning 0))
 154                  ))
 155               ((string= (car ctl) "message/rfc822")
 156                (save-excursion
 157                  (save-restriction
 158                    (narrow-to-region (match-end 0) (point-max))
 159                    (setq dest (list (mime/parse-content)))
 160                    ))
 161                (setq beg (point-min))
 162                (setq end (point-max))
 163                )
 164               (t
 165                (setq beg (point-min))
 166                (setq end (point-max))
 167                ))
 168         (list beg end dest)
 169         ))))
 170
 171 (defun mime/Content-Type ()
 172   (save-excursion
 173     (save-restriction
 174       (if (and (re-search-forward "^Content-Type:[ \t]*" nil t)
 175                  (progn
 176                    (narrow-to-region
 177                     (point)
 178                     (and (re-search-forward ".*\\(\n[ \t].*\\)*" nil t)
 179                          (match-end 0))
 180                     )
 181                    (goto-char (point-min))
 182                    (re-search-forward mime/content-type-subtype-regexp nil t)
 183                    ))
 184             (let ((ctype
 185                    (downcase
 186                     (buffer-substring (match-beginning 0) (match-end 0))
 187                     ))
 188                   dest attribute value)
 189               (while (and (re-search-forward "[ \t\n]*;[ \t\n]*" nil t)
 190                           (re-search-forward mime/token-regexp nil t)
 191                           )
 192                 (setq attribute
 193                       (downcase
 194                        (buffer-substring (match-beginning 0) (match-end 0))
 195                        ))
 196                 (if (and (re-search-forward "=[ \t\n]*" nil t)
 197                          (re-search-forward mime/content-parameter-value-regexp
 198                                             nil t)
 199                          )
 200                     (setq dest
 201                           (put-alist attribute
 202                                      (buffer-substring (match-beginning 0)
 203                                                        (match-end 0))
 204                                      dest))
 205                   )
 206                 )
 207               (cons ctype dest)
 208               )))))
 209
 210 (defun mime/Content-Transfer-Encoding (&optional default-encoding)
 211   (save-excursion
 212     (save-restriction
 213       (if (and (re-search-forward "^Content-Transfer-Encoding:[ \t]*" nil t)
 214                (re-search-forward mime/token-regexp nil t)
 215                )
 216           (downcase (buffer-substring (match-beginning 0) (match-end 0)))
 217         default-encoding)
 218       )))
 219
 220 (defun mime/get-name (ctype)
 221   (save-excursion
 222     (save-restriction
 223       (replace-as-filename
 224        (let (ret)
 225          (or (and (setq ret (assoc "name" ctype))
 226                   (read (cdr ret))
 227                   )
 228              (and (setq ret (assoc "x-name" ctype))
 229                   (read (cdr ret)))
 230              (message/get-field-body "Content-Description")
 231              ""))
 232        ))))
 233
 234 (defun mime/parse-message ()
 235   (interactive)
 236   (save-excursion
 237     (save-restriction
 238       (setq selective-display t)
 239       (make-variable-buffer-local 'mime/content-list)
 240       (let ((buffer-read-only nil))
 241         (setq mime/content-list (mime/parse-content))
 242         )
 243       (mime/hide-all)
 244       (set-buffer-modified-p nil)
 245       )))
 246
 247
 248 ;;; @ content information
 249 ;;;
 250
 251 (defun mime/get-point-content-number (p &optional cl)
 252   (if (null cl)
 253       (setq cl mime/content-list)
 254     )
 255   (let ((b (car cl))
 256         (e (nth 1 cl))
 257         (c (nth 2 cl))
 258         )
 259     (if (and (<= b p)(<= p e))
 260         (or (let (co ret (sn 0))
 261               (catch 'tag
 262                 (while c
 263                   (setq co (car c))
 264                   (setq ret (mime/get-point-content-number p co))
 265                   (cond ((eq ret t) (throw 'tag (list sn)))
 266                         (ret (throw 'tag (cons sn ret)))
 267                         )
 268                   (setq c (cdr c))
 269                   (setq sn (+ sn 1))
 270                   )))
 271             t))))
 272
 273 (defun mime/get-content-region (cn &optional cl)
 274   (if (null cl)
 275       (setq cl mime/content-list)
 276     )
 277   (if (eq cn t)
 278       cl
 279     (let ((sn (car cn)))
 280       (if (null sn)
 281           cl
 282         (let ((rcl (nth sn (nth 2 cl))))
 283           (if rcl
 284               (mime/get-content-region (cdr cn) rcl)
 285             ))
 286         ))))
 287
 288 (defun mime/make-flat-content-list (&optional cl)
 289   (if (null cl)
 290       (setq cl mime/content-list)
 291     )
 292   (let ((dest (list (car cl)))
 293         (rcl (nth 2 cl))
 294         )
 295     (while rcl
 296       (setq dest (append dest (mime/make-flat-content-list (car rcl))))
 297       (setq rcl (cdr rcl))
 298       )
 299     dest))
 300
 301
 302 ;;; @ decoder
 303 ;;;
 304
 305 (defun mime/base64-decode-region (beg end &optional buf filename)
 306   (let ((the-buf (current-buffer)) ret)
 307     (if (null buf)
 308         (setq buf (get-buffer-create mime/decoding-buffer-name))
 309       )
 310     (save-excursion
 311       (save-restriction
 312         (switch-to-buffer buf)
 313         (erase-buffer)
 314         (switch-to-buffer the-buf)
 315         (narrow-to-region beg end)
 316         (goto-char (point-min))
 317         (while (re-search-forward
 318                 (concat "^"
 319                         mime/Base64-encoded-text-regexp
 320                         "$") nil t)
 321           (setq ret (mime/base64-decode-string
 322                      (buffer-substring (match-beginning 0)
 323                                        (match-end 0)
 324                                        )))
 325           (switch-to-buffer buf)
 326           (insert ret)
 327           (switch-to-buffer the-buf)
 328           )))
 329     (if filename
 330         (progn
 331           (switch-to-buffer buf)
 332           (let ((kanji-flag nil)
 333                 (mc-flag nil)
 334                 (file-coding-system
 335                  (if (featurep 'mule) *noconv*))
 336                 )
 337             (write-file filename)
 338             (kill-buffer buf)
 339             (switch-to-buffer the-buf)
 340             )))
 341     ))
 342
 343 (defun mime/start-external-method-region (beg end ctype ctl encoding)
 344   (goto-char beg)
 345   (let ((method (cdr (assoc ctype mime/content-decoding-method-alist)))
 346         (name (mime/get-name ctl))
 347         )
 348     (if method
 349         (progn
 350           (search-forward "\n\n" nil t)
 351           (let ((file (make-temp-name
 352                        (expand-file-name "TM" mime/tmp-dir)))
 353                 (b (match-end 0))
 354                 (e end))
 355             (goto-char b)
 356             (if (and (string= encoding "base64")
 357                      mime/use-internal-decoder)
 358                 (progn
 359                   (mime/base64-decode-region b e nil file)
 360                   (setq encoding "binary")
 361                   )
 362               (write-region b e file)
 363               )
 364             (start-process method mime/output-buffer-name method file
 365                            ctype encoding
 366                            (if mime/body-decoding-mode
 367                                mime/body-decoding-mode
 368                              "play")
 369                            (replace-as-filename name)
 370                            )
 371             (if (null (get-buffer-window mime/output-buffer-name))
 372                 (let ((the-buf (current-buffer)))
 373                   (split-window-vertically (/ (* (window-height) 3) 4))
 374                   (pop-to-buffer mime/output-buffer-name)
 375                   (pop-to-buffer the-buf)
 376                   ))
 377             )))))
 378
 379 (defun mime/decode-message/partial-region (beg end ctype default-encoding)
 380   (goto-char beg)
 381   (let ((root-dir (expand-file-name
 382                    (concat "m-prts-" (user-login-name)) mime/tmp-dir))
 383         (id (cdr (assoc "id" ctype)))
 384         (number (cdr (assoc "number" ctype)))
 385         (total (cdr (assoc "total" ctype)))
 386         (the-buf (current-buffer))
 387         file)
 388     (if (not (file-exists-p root-dir))
 389         (shell-command (concat "mkdir " root-dir))
 390       )
 391     (setq id (replace-as-filename id))
 392     (setq root-dir (concat root-dir "/" id))
 393     (if (not (file-exists-p root-dir))
 394         (shell-command (concat "mkdir " root-dir))
 395       )
 396     (setq file (concat root-dir "/FULL"))
 397     (if (not (file-exists-p file))
 398         (progn
 399           (re-search-forward "^$")
 400           (goto-char (+ (match-end 0) 1))
 401           (setq file (concat root-dir "/" number))
 402           (write-region (point) (point-max) file)
 403           (if (get-buffer "*MIME-temp*")
 404               (kill-buffer "*MIME-temp*")
 405             )
 406           (switch-to-buffer "*MIME-temp*")
 407           (let ((i 1)
 408                 (max (string-to-int total))
 409                 )
 410             (catch 'tag
 411               (while (<= i max)
 412                 (setq file (concat root-dir "/" (int-to-string i)))
 413                 (if (not (file-exists-p file))
 414                     (progn
 415                       (switch-to-buffer the-buf)
 416                       (throw 'tag nil)
 417                       ))
 418                 (insert-file-contents file)
 419                 (goto-char (point-max))
 420                 (setq i (+ i 1))
 421                 )
 422               (write-file (concat root-dir "/FULL"))
 423               (delete-other-windows)
 424               (pop-to-buffer (current-buffer))
 425               (goto-char (point-min))
 426               (mime/show-message-mode the-buf)
 427               ))
 428           )
 429       (progn
 430         (delete-other-windows)
 431         (find-file file)
 432         (mime/show-message-mode the-buf)
 433         ))
 434     ))
 435
 436 (defun mime/decode-content-region (beg end)
 437   (interactive "*r")
 438   (save-excursion
 439     (save-restriction
 440       (narrow-to-region beg end)
 441       (outline-flag-region beg end ?\n)
 442       (goto-char beg)
 443       (let ((ctl (mime/Content-Type)))
 444         (if ctl
 445             (let ((ctype (downcase (car ctl)))
 446                   (encoding (mime/Content-Transfer-Encoding "7bit"))
 447                   )
 448               (setq ctl (cdr ctl))
 449               (cond ((string= ctype "message/partial")
 450                      (mime/decode-message/partial-region beg end ctl encoding)
 451                      )
 452                     (t (mime/start-external-method-region beg end
 453                                                           ctype ctl encoding)
 454                        (if (not (member
 455                                  ctype
 456                                  mime/default-showing-Content-Type-list))
 457                            (mime/hide-region beg end)
 458                          )
 459                        ))
 460               ))))))
 461
 462
 463 ;;; @ hide
 464 ;;;
 465
 466 (defun mime/hide-region (beg end)
 467   (save-excursion
 468     (save-restriction
 469       (goto-char beg)
 470       (search-forward "\n\n" nil t)
 471       (setq beg (match-end 0))
 472       (outline-flag-region beg end ?\^M)
 473       )))
 474
 475 (defun mime/hide-all ()
 476   (let ((fl (mime/make-flat-content-list))
 477         p c)
 478     (while fl
 479       (setq p (car fl))
 480       (setq c (mime/get-content-region (mime/get-point-content-number p)))
 481       (if (null (nth 2 c))
 482           (save-excursion
 483             (save-restriction
 484               (narrow-to-region (car c)(nth 1 c))
 485               (goto-char (car c))
 486               (let ((ctl (mime/Content-Type)))
 487                 (if (and ctl
 488                          (not (member
 489                                (car ctl)
 490                                mime/default-showing-Content-Type-list)))
 491                     (mime/hide-region (car c)(nth 1 c))
 492                   )))))
 493       (setq fl (cdr fl))
 494       )))
 495
 496
 497 ;;; @ MIME show message mode (major-mode)
 498 ;;;
 499 (defun mime/show-message-mode (mother)
 500   (kill-all-local-variables)
 501   (make-variable-buffer-local 'mime/show-mode-old-window-configuration)
 502   (setq mime/show-mode-old-window-configuration
 503         (current-window-configuration))
 504   (make-variable-buffer-local 'mime/mother-buffer)
 505   (setq mime/mother-buffer mother)
 506   (setq major-mode 'mime/show-message-mode)
 507   (setq mode-name "MIME-View")
 508   (mime/view-mode)
 509   (run-hooks 'mime/show-message-mode-hook)
 510   )
 511
 512
 513 ;;; @ MIME view message mode (minor-mode)
 514 ;;;
 515
 516 (defun mime/view-mode ()
 517   (interactive)
 518   (make-local-variable 'mime/view-mode-old-local-map)
 519   (let ((keymap (current-local-map)))
 520     (if (null keymap)
 521         (setq keymap (make-sparse-keymap))
 522       (progn
 523         (setq mime/view-mode-old-local-map keymap)
 524         (setq keymap (copy-keymap keymap))
 525         ))
 526     (let ((buf (get-buffer mime/output-buffer-name)))
 527       (if buf
 528           (let ((the-buf (current-buffer)))
 529             (switch-to-buffer buf)
 530             (erase-buffer)
 531             (switch-to-buffer the-buf)
 532             )))
 533     (use-local-map keymap)
 534     (define-key keymap "u" 'mime/up-content)
 535     (define-key keymap "p" 'mime/previous-content)
 536     (define-key keymap "n" 'mime/next-content)
 537     (define-key keymap "v" 'mime/play-content)
 538     (define-key keymap "e" 'mime/extract-content)
 539     (define-key keymap "\C-c\C-p" 'mime/print-content)
 540     (define-key keymap "\C-c\C-x" 'mime/exit-view-mode)
 541     )
 542   (mime/parse-message)
 543   (search-forward "\n\n" nil t)
 544   )
 545
 546 (defun mime/decode-content ()
 547   (interactive)
 548   (let ((cr (mime/get-content-region
 549              (mime/get-point-content-number (point))))
 550         )
 551     (and cr
 552          (null (nth 2 cr))
 553          (mime/decode-content-region (car cr)(nth 1 cr))
 554          )))
 555
 556 (defun mime/play-content ()
 557   (interactive)
 558   (let ((mime/body-decoding-mode "play"))
 559     (mime/decode-content)
 560     ))
 561
 562 (defun mime/extract-content ()
 563   (interactive)
 564   (let ((mime/body-decoding-mode "extract"))
 565     (mime/decode-content)
 566     ))
 567
 568 (defun mime/print-content ()
 569   (interactive)
 570   (let ((mime/body-decoding-mode "print"))
 571     (mime/decode-content)
 572     ))
 573
 574 (defun mime/up-content ()
 575   (interactive)
 576   (let ((cn (mime/get-point-content-number (point)))
 577         r)
 578     (if (eq cn t)
 579         (and (setq r (assoc major-mode mime/go-to-top-node-method-alist))
 580              (funcall (cdr r))
 581              )
 582       (if (setq r (mime/get-content-region (butlast cn)))
 583           (goto-char (car r))
 584         )
 585       )))
 586
 587 (defun mime/previous-content ()
 588   (interactive)
 589   (let* ((fcl (mime/make-flat-content-list))
 590          (p (point))
 591          (i (- (length fcl) 1))
 592          )
 593     (catch 'tag
 594       (while (>= i 0)
 595         (if (> p (nth i fcl))
 596             (throw 'tag (goto-char (nth i fcl)))
 597           )
 598         (setq i (- i 1))
 599         ))
 600     ))
 601
 602 (defun mime/next-content ()
 603   (interactive)
 604   (let ((fcl (mime/make-flat-content-list))
 605         (p (point))
 606         )
 607     (catch 'tag
 608       (while fcl
 609         (if (< p (car fcl))
 610             (throw 'tag (goto-char (car fcl)))
 611           )
 612         (setq fcl (cdr fcl))
 613         ))
 614     ))
 615
 616 (defun mime/exit-view-mode ()
 617   (interactive)
 618   (if (and (boundp 'mime/view-mode-old-local-map)
 619            (keymapp mime/view-mode-old-local-map))
 620       (use-local-map mime/view-mode-old-local-map)
 621     )
 622   (show-all)
 623   )