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