mime-view.el

   1 ;;; mime-view.el --- interactive MIME viewer for GNU Emacs
   2
   3 ;; Copyright (C) 1995,1996,1997 Free Software Foundation, Inc.
   4
   5 ;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
   6 ;; Created: 1994/7/13
   7 ;;      Renamed: 1994/8/31 from tm-body.el
   8 ;;      Renamed: 1997/02/19 from tm-view.el
   9 ;; Version: $Revision: 0.50 $
  10 ;; Keywords: MIME, multimedia, mail, news
  11
  12 ;; This file is part of SEMI (SEMI is Emacs MIME Interfaces).
  13
  14 ;; This program is free software; you can redistribute it and/or
  15 ;; modify it under the terms of the GNU General Public License as
  16 ;; published by the Free Software Foundation; either version 2, or (at
  17 ;; your option) any later version.
  18
  19 ;; This program is distributed in the hope that it will be useful, but
  20 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  21 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  22 ;; General Public License for more details.
  23
  24 ;; You should have received a copy of the GNU General Public License
  25 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  26 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  27 ;; Boston, MA 02111-1307, USA.
  28
  29 ;;; Code:
  30
  31 (require 'cl)
  32 (require 'std11)
  33 (require 'mel)
  34 (require 'eword-decode)
  35 (require 'mime-parse)
  36 (require 'mime-text)
  37
  38
  39 ;;; @ version
  40 ;;;
  41
  42 (defconst mime-view-RCS-ID
  43   "$Id: mime-view.el,v 0.50 1997-03-17 15:01:11 morioka Exp $")
  44
  45 (defconst mime-view-version (get-version-string mime-view-RCS-ID))
  46
  47
  48 ;;; @ variables
  49 ;;;
  50
  51 (defvar mime/content-decoding-condition
  52   '(((type . "text/plain")
  53      (method "tm-plain" nil 'file 'type 'encoding 'mode 'name)
  54      (mode "play" "print")
  55      )
  56     ((type . "text/html")
  57      (method "tm-html" nil 'file 'type 'encoding 'mode 'name)
  58      (mode . "play")
  59      )
  60     ((type . "text/x-rot13-47")
  61      (method . mime-article/decode-caesar)
  62      (mode . "play")
  63      )
  64     ((type . "audio/basic")
  65      (method "tm-au"    nil 'file 'type 'encoding 'mode 'name)
  66      (mode . "play")
  67      )
  68
  69     ((type . "image/jpeg")
  70      (method "tm-image" nil 'file 'type 'encoding 'mode 'name)
  71      (mode "play" "print")
  72      )
  73     ((type . "image/gif")
  74      (method "tm-image" nil 'file 'type 'encoding 'mode 'name)
  75      (mode "play" "print")
  76      )
  77     ((type . "image/tiff")
  78      (method "tm-image" nil 'file 'type 'encoding 'mode 'name)
  79      (mode "play" "print")
  80      )
  81     ((type . "image/x-tiff")
  82      (method "tm-image" nil 'file 'type 'encoding 'mode 'name)
  83      (mode "play" "print")
  84      )
  85     ((type . "image/x-xbm")
  86      (method "tm-image" nil 'file 'type 'encoding 'mode 'name)
  87      (mode "play" "print")
  88      )
  89     ((type . "image/x-pic")
  90      (method "tm-image" nil 'file 'type 'encoding 'mode 'name)
  91      (mode "play" "print")
  92      )
  93     ((type . "image/x-mag")
  94      (method "tm-image" nil 'file 'type 'encoding 'mode 'name)
  95      (mode "play" "print")
  96      )
  97
  98     ((type . "video/mpeg")
  99      (method "tm-mpeg"  nil 'file 'type 'encoding 'mode 'name)
 100      (mode . "play")
 101      )
 102
 103     ((type . "application/postscript")
 104      (method "tm-ps" nil 'file 'type 'encoding 'mode 'name)
 105      (mode "play" "print")
 106      )
 107     ((type . "application/octet-stream")
 108      (method "tm-file"  nil 'file 'type 'encoding 'mode 'name)
 109      (mode "play" "print")
 110      )
 111
 112     ;;((type . "message/external-body")
 113     ;; (method "xterm" nil
 114     ;;         "-e" "showexternal"
 115     ;;         'file '"access-type" '"name" '"site" '"directory"))
 116     ((type . "message/rfc822")
 117      (method . mime-article/view-message/rfc822)
 118      (mode . "play")
 119      )
 120     ((type . "message/partial")
 121      (method . mime-article/decode-message/partial)
 122      (mode . "play")
 123      )
 124     ((type . "message/external-body")
 125      ("access-type" . "anon-ftp")
 126      (method . mime-article/decode-message/external-ftp)
 127      )
 128
 129     ((method "metamail" t "-m" "tm" "-x" "-d" "-z" "-e" 'file)
 130      (mode . "play")
 131      )
 132     ((method "tm-file"  nil 'file 'type 'encoding 'mode 'name)
 133      (mode . "extract")
 134      )
 135     ))
 136
 137 (defvar mime-view-childrens-header-showing-Content-Type-list
 138   '("message/rfc822" "message/news"))
 139
 140 (defvar mime-view-visible-media-type-list
 141   '("text/plain" nil "text/richtext" "text/enriched"
 142     "text/rfc822-headers"
 143     "text/x-latex" "application/x-latex"
 144     "message/delivery-status"
 145     "application/pgp" "text/x-pgp"
 146     "application/octet-stream"
 147     "application/x-selection" "application/x-comment")
 148   "*List of media-types to be able to display in MIME-View buffer.
 149 Each elements are string of TYPE/SUBTYPE, e.g. \"text/plain\".")
 150
 151 (defvar mime-view-content-button-visible-ctype-list
 152   '("application/pgp"))
 153
 154 (defvar mime-view-uuencode-encoding-name-list '("x-uue" "x-uuencode"))
 155
 156 (defvar mime-view-ignored-field-list
 157   '(".*Received" ".*Path" ".*Id" "References"
 158     "Replied" "Errors-To"
 159     "Lines" "Sender" ".*Host" "Xref"
 160     "Content-Type" "Precedence"
 161     "Status" "X-VM-.*")
 162   "All fields that match this list will be hidden in MIME preview buffer.
 163 Each elements are regexp of field-name. [mime-view.el]")
 164
 165 (defvar mime-view-ignored-field-regexp
 166   (concat "^"
 167           (apply (function regexp-or) mime-view-ignored-field-list)
 168           ":"))
 169
 170 (defvar mime-view-visible-field-list '("Dnas.*" "Message-Id")
 171   "All fields that match this list will be displayed in MIME preview buffer.
 172 Each elements are regexp of field-name.")
 173
 174 (defvar mime-view-redisplay nil)
 175
 176 (defvar mime-view-announcement-for-message/partial
 177   (if (and (>= emacs-major-version 19) window-system)
 178       "\
 179 \[[ This is message/partial style split message. ]]
 180 \[[ Please press `v' key in this buffer          ]]
 181 \[[ or click here by mouse button-2.             ]]"
 182     "\
 183 \[[ This is message/partial style split message. ]]
 184 \[[ Please press `v' key in this buffer.         ]]"
 185     ))
 186
 187
 188 ;;; @@ predicate functions
 189 ;;;
 190
 191 (defun mime-view-header-visible-p (rcnum cinfo)
 192   "Return non-nil if header of current entity is visible."
 193   (or (null rcnum)
 194       (member (mime::content-info/type
 195                (mime-article/rcnum-to-cinfo (cdr rcnum) cinfo))
 196               mime-view-childrens-header-showing-Content-Type-list)
 197       ))
 198
 199 (defun mime-view-body-visible-p (rcnum cinfo &optional ctype)
 200   (let (ccinfo)
 201     (or ctype
 202         (setq ctype
 203               (mime::content-info/type
 204                (setq ccinfo (mime-article/rcnum-to-cinfo rcnum cinfo))
 205                ))
 206         )
 207     (and (member ctype mime-view-visible-media-type-list)
 208          (if (string-equal ctype "application/octet-stream")
 209              (progn
 210                (or ccinfo
 211                    (setq ccinfo (mime-article/rcnum-to-cinfo rcnum cinfo))
 212                    )
 213                (member (mime::content-info/encoding ccinfo)
 214                        '(nil "7bit" "8bit"))
 215                )
 216            t))
 217     ))
 218
 219
 220 ;;; @@ entity button
 221 ;;;
 222
 223 (defun mime-view-insert-entity-button (rcnum cinfo ctype params subj encoding)
 224   "Insert entity-button."
 225   (save-restriction
 226     (narrow-to-region (point)(point))
 227     (let ((access-type (assoc "access-type" params))
 228           (num (or (cdr (assoc "x-part-number" params))
 229                    (if (consp rcnum)
 230                        (mapconcat (function
 231                                    (lambda (num)
 232                                      (format "%s" (1+ num))
 233                                      ))
 234                                   (reverse rcnum) ".")
 235                      "0"))
 236                ))
 237       (cond (access-type
 238              (let ((server (assoc "server" params)))
 239                (setq access-type (cdr access-type))
 240                (if server
 241                    (insert (format "[%s %s ([%s] %s)]\n" num subj
 242                                    access-type (cdr server)))
 243                  (let ((site (cdr (assoc "site" params)))
 244                        (dir (cdr (assoc "directory" params)))
 245                        )
 246                    (insert (format "[%s %s ([%s] %s:%s)]\n" num subj
 247                                    access-type site dir))
 248                    )))
 249              )
 250             (t
 251              (let ((charset (cdr (assoc "charset" params))))
 252                (insert (concat "[" num " " subj))
 253                (let ((rest
 254                       (concat " <" ctype
 255                               (if charset
 256                                   (concat "; " charset)
 257                                 (if encoding (concat " (" encoding ")"))
 258                                 )
 259                               ">]\n")))
 260                  (if (>= (+ (current-column)(length rest))(window-width))
 261                      (insert "\n\t")
 262                    )
 263                  (insert rest)
 264                  ))))
 265       )
 266     (mime-add-button (point-min)(1- (point-max))
 267                      (function mime-view-play-current-entity))
 268     ))
 269
 270 (defun mime-view-entity-button-function
 271   (rcnum cinfo ctype params subj encoding)
 272   "Insert entity button conditionally.
 273 Please redefine this function if you want to change default setting."
 274   (or (null rcnum)
 275       (string= ctype "application/x-selection")
 276       (and (string= ctype "application/octet-stream")
 277            (string= (mime::content-info/type
 278                      (mime-article/rcnum-to-cinfo (cdr rcnum) cinfo))
 279                     "multipart/encrypted"))
 280       (mime-view-insert-entity-button rcnum cinfo ctype params subj encoding)
 281       ))
 282
 283
 284 ;;; @@ content header filter
 285 ;;;
 286
 287 (defsubst mime-view-cut-header ()
 288   (goto-char (point-min))
 289   (while (re-search-forward mime-view-ignored-field-regexp nil t)
 290     (let* ((beg (match-beginning 0))
 291            (end (match-end 0))
 292            (name (buffer-substring beg end))
 293            )
 294       (or (member-if (function
 295                       (lambda (regexp)
 296                         (string-match regexp name)
 297                         )) mime-view-visible-field-list)
 298           (delete-region beg
 299                          (if (re-search-forward "^\\([^ \t]\\|$\\)" nil t)
 300                              (match-beginning 0)
 301                            (point-max)))
 302           ))))
 303
 304 (defun mime-view-default-content-header-filter ()
 305   (mime-view-cut-header)
 306   (eword-decode-header)
 307   )
 308
 309 (defvar mime-view-content-header-filter-alist nil)
 310
 311
 312 ;;; @@ content filter
 313 ;;;
 314
 315 (defvar mime-view-content-filter-alist
 316   '(("text/enriched" . mime-preview/filter-for-text/enriched)
 317     ("text/richtext" . mime-preview/filter-for-text/richtext)
 318     (t . mime-preview/filter-for-text/plain)
 319     ))
 320
 321
 322 ;;; @@ entity separator
 323 ;;;
 324
 325 (defun mime-view-entity-separator-function (rcnum cinfo ctype params subj)
 326   "Insert entity separator conditionally.
 327 Please redefine this function if you want to change default setting."
 328   (or (mime-view-header-visible-p rcnum cinfo)
 329       (mime-view-body-visible-p rcnum cinfo ctype)
 330       (progn
 331         (goto-char (point-max))
 332         (insert "\n")
 333         )))
 334
 335
 336 ;;; @@ buffer local variables
 337 ;;;
 338
 339 ;;; @@@ in raw buffer
 340 ;;;
 341
 342 (make-variable-buffer-local 'mime::article/content-info)
 343
 344 (defvar mime::article/preview-buffer nil)
 345 (make-variable-buffer-local 'mime::article/preview-buffer)
 346
 347
 348 ;;; @@@ in view buffer
 349 ;;;
 350
 351 (make-variable-buffer-local 'mime::preview/mother-buffer)
 352 (make-variable-buffer-local 'mime::preview/content-list)
 353
 354 (defvar mime::preview/article-buffer nil)
 355 (make-variable-buffer-local 'mime::preview/article-buffer)
 356
 357 (make-variable-buffer-local 'mime::preview/original-major-mode)
 358 (make-variable-buffer-local 'mime::preview/original-window-configuration)
 359
 360
 361 ;;; @@ quitting method
 362 ;;;
 363
 364 (defvar mime-view-quitting-method-alist
 365   '((mime/show-message-mode
 366      . mime-view-quitting-method-for-mime/show-message-mode)))
 367
 368 (defvar mime-view-over-to-previous-method-alist nil)
 369 (defvar mime-view-over-to-next-method-alist nil)
 370
 371 (defvar mime-view-show-summary-method nil)
 372
 373
 374 ;;; @@ following method
 375 ;;;
 376
 377 (defvar mime-view-following-method-alist nil)
 378
 379 (defvar mime-view-following-required-fields-list
 380   '("From"))
 381
 382
 383 ;;; @@ X-Face
 384 ;;;
 385
 386 ;; hack from Gnus 5.0.4.
 387
 388 (defvar mime-view-x-face-to-pbm-command
 389   "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm")
 390
 391 (defvar mime-view-x-face-command
 392   (concat mime-view-x-face-to-pbm-command
 393           " | xv -quit -")
 394   "String to be executed to display an X-Face field.
 395 The command will be executed in a sub-shell asynchronously.
 396 The compressed face will be piped to this command.")
 397
 398 (defun mime-view-x-face-function ()
 399   "Function to display X-Face field. You can redefine to customize."
 400   ;; 1995/10/12 (c.f. tm-eng:130)
 401   ;;    fixed by Eric Ding <ericding@San-Jose.ate.slb.com>
 402   (save-restriction
 403     (narrow-to-region (point-min) (re-search-forward "^$" nil t))
 404     ;; end
 405     (goto-char (point-min))
 406     (if (re-search-forward "^X-Face:[ \t]*" nil t)
 407         (let ((beg (match-end 0))
 408               (end (std11-field-end))
 409               )
 410           (call-process-region beg end "sh" nil 0 nil
 411                                "-c" mime-view-x-face-command)
 412           ))))
 413
 414
 415 ;;; @@ utility
 416 ;;;
 417
 418 (defun mime-preview/get-original-major-mode ()
 419   (if mime::preview/mother-buffer
 420       (save-excursion
 421         (set-buffer mime::preview/mother-buffer)
 422         (mime-preview/get-original-major-mode)
 423         )
 424     mime::preview/original-major-mode))
 425
 426
 427 ;;; @ data structures
 428 ;;;
 429
 430 ;;; @@ preview-content-info
 431 ;;;
 432
 433 (define-structure mime::preview-content-info
 434   point-min point-max buffer content-info)
 435
 436
 437 ;;; @ buffer setup
 438 ;;;
 439
 440 (defun mime-view-setup-buffer (&optional ctl encoding ibuf obuf)
 441   (if ibuf
 442       (progn
 443         (get-buffer ibuf)
 444         (set-buffer ibuf)
 445         ))
 446   (or mime-view-redisplay
 447       (setq mime::article/content-info (mime-parse-message ctl encoding))
 448       )
 449   (let ((ret (mime-view-make-preview-buffer obuf)))
 450     (setq mime::article/preview-buffer (car ret))
 451     ret))
 452
 453 (defun mime-view-make-preview-buffer (&optional obuf)
 454   (let* ((cinfo mime::article/content-info)
 455          (pcl (mime/flatten-content-info cinfo))
 456          (dest (make-list (length pcl) nil))
 457          (the-buf (current-buffer))
 458          (mode major-mode)
 459          )
 460     (or obuf
 461         (setq obuf (concat "*Preview-" (buffer-name the-buf) "*")))
 462     (set-buffer (get-buffer-create obuf))
 463     (setq buffer-read-only nil)
 464     (widen)
 465     (erase-buffer)
 466     (setq mime::preview/article-buffer the-buf)
 467     (setq mime::preview/original-major-mode mode)
 468     (setq major-mode 'mime-view-mode)
 469     (setq mode-name "MIME-View")
 470     (let ((drest dest))
 471       (while pcl
 472         (setcar drest
 473                 (mime-preview/display-content (car pcl) cinfo the-buf obuf))
 474         (setq pcl (cdr pcl)
 475               drest (cdr drest))
 476         ))
 477     (set-buffer-modified-p nil)
 478     (setq buffer-read-only t)
 479     (set-buffer the-buf)
 480     (list obuf dest)
 481     ))
 482
 483 (defun mime-preview/display-content (content cinfo ibuf obuf)
 484   (let* ((beg (mime::content-info/point-min content))
 485          (end (mime::content-info/point-max content))
 486          (ctype (mime::content-info/type content))
 487          (params (mime::content-info/parameters content))
 488          (encoding (mime::content-info/encoding content))
 489          (rcnum (mime::content-info/rcnum content))
 490          he e nb ne subj)
 491     (set-buffer ibuf)
 492     (goto-char beg)
 493     (setq he (if (re-search-forward "^$" nil t)
 494                  (1+ (match-end 0))
 495                end))
 496     (if (> he end)
 497         (setq he end)
 498       )
 499     (save-restriction
 500       (narrow-to-region beg end)
 501       (setq subj
 502             (eword-decode-string
 503              (mime-article/get-subject params encoding)))
 504       )
 505     (set-buffer obuf)
 506     (setq nb (point))
 507     (narrow-to-region nb nb)
 508     (mime-view-entity-button-function rcnum cinfo ctype params subj encoding)
 509     (if (mime-view-header-visible-p rcnum cinfo)
 510         (mime-preview/display-header beg he)
 511       )
 512     (if (and (null rcnum)
 513              (member
 514               ctype mime-view-content-button-visible-ctype-list))
 515         (save-excursion
 516           (goto-char (point-max))
 517           (mime-view-insert-entity-button
 518            rcnum cinfo ctype params subj encoding)
 519           ))
 520     (cond ((mime-view-body-visible-p rcnum cinfo ctype)
 521            (mime-preview/display-body he end
 522                                       rcnum cinfo ctype params subj encoding)
 523            )
 524           ((equal ctype "message/partial")
 525            (mime-preview/display-message/partial)
 526            )
 527           ((and (null rcnum)
 528                 (null (mime::content-info/children cinfo))
 529                 )
 530            (goto-char (point-max))
 531            (mime-view-insert-entity-button
 532             rcnum cinfo ctype params subj encoding)
 533            ))
 534     (mime-view-entity-separator-function rcnum cinfo ctype params subj)
 535     (prog1
 536         (progn
 537           (setq ne (point-max))
 538           (widen)
 539           (put-text-property nb ne 'mime-view-raw-buffer ibuf)
 540           (put-text-property nb ne 'mime-view-cinfo content)
 541           (mime::preview-content-info/create nb (1- ne) ibuf content)
 542           )
 543       (goto-char ne)
 544       )))
 545
 546 (defun mime-preview/display-header (beg end)
 547   (save-restriction
 548     (narrow-to-region (point)(point))
 549     (insert-buffer-substring mime::preview/article-buffer beg end)
 550     (let ((f (cdr (assq mime::preview/original-major-mode
 551                         mime-view-content-header-filter-alist))))
 552       (if (functionp f)
 553           (funcall f)
 554         (mime-view-default-content-header-filter)
 555         ))
 556     (run-hooks 'mime-view-content-header-filter-hook)
 557     ))
 558
 559 (defun mime-preview/display-body (beg end
 560                                       rcnum cinfo ctype params subj encoding)
 561   (save-restriction
 562     (narrow-to-region (point-max)(point-max))
 563     (insert-buffer-substring mime::preview/article-buffer beg end)
 564     (let ((f (cdr (or (assoc ctype mime-view-content-filter-alist)
 565                       (assq t mime-view-content-filter-alist)))))
 566       (and (functionp f)
 567            (funcall f ctype params encoding)
 568            )
 569       )))
 570
 571 (defun mime-preview/display-message/partial ()
 572   (save-restriction
 573     (goto-char (point-max))
 574     (if (not (search-backward "\n\n" nil t))
 575         (insert "\n")
 576       )
 577     (let ((be (point-max)))
 578       (narrow-to-region be be)
 579       (insert mime-view-announcement-for-message/partial)
 580       (mime-add-button (point-min)(point-max)
 581                        (function mime-view-play-current-entity))
 582       )))
 583
 584 (defun mime-article/get-uu-filename (param &optional encoding)
 585   (if (member (or encoding
 586                   (cdr (assq 'encoding param))
 587                   )
 588               mime-view-uuencode-encoding-name-list)
 589       (save-excursion
 590         (or (if (re-search-forward "^begin [0-9]+ " nil t)
 591                 (if (looking-at ".+$")
 592                     (buffer-substring (match-beginning 0)(match-end 0))
 593                   ))
 594             ""))
 595     ))
 596
 597 (defun mime-article/get-subject (param &optional encoding)
 598   (or (std11-find-field-body '("Content-Description" "Subject"))
 599       (let (ret)
 600         (if (or (and (setq ret (mime/Content-Disposition))
 601                      (setq ret (assoc "filename" (cdr ret)))
 602                      )
 603                 (setq ret (assoc "name" param))
 604                 (setq ret (assoc "x-name" param))
 605                 )
 606             (std11-strip-quoted-string (cdr ret))
 607           ))
 608       (mime-article/get-uu-filename param encoding)
 609       ""))
 610
 611
 612 ;;; @ content information
 613 ;;;
 614
 615 (defun mime-article/point-content-number (p &optional cinfo)
 616   (or cinfo
 617       (setq cinfo mime::article/content-info)
 618       )
 619   (let ((b (mime::content-info/point-min cinfo))
 620         (e (mime::content-info/point-max cinfo))
 621         (c (mime::content-info/children cinfo))
 622         )
 623     (if (and (<= b p)(<= p e))
 624         (or (let (co ret (sn 0))
 625               (catch 'tag
 626                 (while c
 627                   (setq co (car c))
 628                   (setq ret (mime-article/point-content-number p co))
 629                   (cond ((eq ret t) (throw 'tag (list sn)))
 630                         (ret (throw 'tag (cons sn ret)))
 631                         )
 632                   (setq c (cdr c))
 633                   (setq sn (1+ sn))
 634                   )))
 635             t))))
 636
 637 (defun mime-article/rcnum-to-cinfo (rcnum &optional cinfo)
 638   (or cinfo
 639       (setq cinfo mime::article/content-info)
 640       )
 641   (find-if (function
 642             (lambda (ci)
 643               (equal (mime::content-info/rcnum ci) rcnum)
 644               ))
 645            (mime/flatten-content-info cinfo)
 646            ))
 647
 648 (defun mime-article/cnum-to-cinfo (cn &optional cinfo)
 649   (or cinfo
 650       (setq cinfo mime::article/content-info)
 651       )
 652   (if (eq cn t)
 653       cinfo
 654     (let ((sn (car cn)))
 655       (if (null sn)
 656           cinfo
 657         (let ((rc (nth sn (mime::content-info/children cinfo))))
 658           (if rc
 659               (mime-article/cnum-to-cinfo (cdr cn) rc)
 660             ))
 661         ))))
 662
 663 (defun mime/flatten-content-info (&optional cinfo)
 664   (or cinfo
 665       (setq cinfo mime::article/content-info)
 666       )
 667   (let ((dest (list cinfo))
 668         (rcl (mime::content-info/children cinfo))
 669         )
 670     (while rcl
 671       (setq dest (nconc dest (mime/flatten-content-info (car rcl))))
 672       (setq rcl (cdr rcl))
 673       )
 674     dest))
 675
 676 (defun mime-preview/point-pcinfo (p &optional pcl)
 677   (or pcl
 678       (setq pcl mime::preview/content-list)
 679       )
 680   (catch 'tag
 681     (let ((r pcl) cell)
 682       (while r
 683         (setq cell (car r))
 684         (if (and (<= (mime::preview-content-info/point-min cell) p)
 685                  (<= p (mime::preview-content-info/point-max cell))
 686                  )
 687             (throw 'tag cell)
 688           )
 689         (setq r (cdr r))
 690         ))
 691     (car (last pcl))
 692     ))
 693
 694
 695 ;;; @ MIME viewer mode
 696 ;;;
 697
 698 (defconst mime-view-menu-title "MIME-View")
 699 (defconst mime-view-menu-list
 700   '((up          "Move to upper content"      mime-view-up-content)
 701     (previous    "Move to previous content"   mime-view-previous-content)
 702     (next        "Move to next content"       mime-view-next-content)
 703     (scroll-down "Scroll to previous content" mime-view-scroll-down-content)
 704     (scroll-up   "Scroll to next content"     mime-view-scroll-up-content)
 705     (play        "Play Content"               mime-view-play-current-entity)
 706     (extract     "Extract Content"            mime-view-extract-current-entity)
 707     (print       "Print"                      mime-view-print-current-entity)
 708     (x-face      "Show X Face"                mime-view-display-x-face)
 709     )
 710   "Menu for MIME Viewer")
 711
 712 (cond (running-xemacs
 713        (defvar mime-view-xemacs-popup-menu
 714          (cons mime-view-menu-title
 715                (mapcar (function
 716                         (lambda (item)
 717                           (vector (nth 1 item)(nth 2 item) t)
 718                           ))
 719                        mime-view-menu-list)))
 720        (defun mime-view-xemacs-popup-menu (event)
 721          "Popup the menu in the MIME Viewer buffer"
 722          (interactive "e")
 723          (select-window (event-window event))
 724          (set-buffer (event-buffer event))
 725          (popup-menu 'mime-view-xemacs-popup-menu))
 726        (defvar mouse-button-2 'button2)
 727        )
 728       (t
 729        (defvar mouse-button-2 [mouse-2])
 730        ))
 731
 732 (defun mime-view-define-keymap (&optional default)
 733   (let ((mime-view-mode-map (if (keymapp default)
 734                                 (copy-keymap default)
 735                               (make-sparse-keymap)
 736                               )))
 737     (define-key mime-view-mode-map
 738       "u"        (function mime-view-up-content))
 739     (define-key mime-view-mode-map
 740       "p"        (function mime-view-previous-content))
 741     (define-key mime-view-mode-map
 742       "n"        (function mime-view-next-content))
 743     (define-key mime-view-mode-map
 744       "\e\t"     (function mime-view-previous-content))
 745     (define-key mime-view-mode-map
 746       "\t"       (function mime-view-next-content))
 747     (define-key mime-view-mode-map
 748       " "        (function mime-view-scroll-up-content))
 749     (define-key mime-view-mode-map
 750       "\M- "     (function mime-view-scroll-down-content))
 751     (define-key mime-view-mode-map
 752       "\177"     (function mime-view-scroll-down-content))
 753     (define-key mime-view-mode-map
 754       "\C-m"     (function mime-view-next-line-content))
 755     (define-key mime-view-mode-map
 756       "\C-\M-m"  (function mime-view-previous-line-content))
 757     (define-key mime-view-mode-map
 758       "v"        (function mime-view-play-current-entity))
 759     (define-key mime-view-mode-map
 760       "e"        (function mime-view-extract-current-entity))
 761     (define-key mime-view-mode-map
 762       "\C-c\C-p" (function mime-view-print-current-entity))
 763     (define-key mime-view-mode-map
 764       "a"        (function mime-view-follow-content))
 765     (define-key mime-view-mode-map
 766       "q"        (function mime-view-quit))
 767     (define-key mime-view-mode-map
 768       "h"        (function mime-view-show-summary))
 769     (define-key mime-view-mode-map
 770       "\C-c\C-x" (function mime-view-kill-buffer))
 771     (define-key mime-view-mode-map
 772       "<"        (function beginning-of-buffer))
 773     (define-key mime-view-mode-map
 774       ">"        (function end-of-buffer))
 775     (define-key mime-view-mode-map
 776       "?"        (function describe-mode))
 777     (if (functionp default)
 778         (setq mime-view-mode-map
 779               (append mime-view-mode-map (list (cons t default)))
 780               ))
 781     (if mouse-button-2
 782         (define-key mime-view-mode-map
 783           mouse-button-2 (function mime-button-dispatcher))
 784       )
 785     (cond (running-xemacs
 786            (define-key mime-view-mode-map
 787              mouse-button-3 (function mime-view-xemacs-popup-menu))
 788            )
 789           ((>= emacs-major-version 19)
 790            (define-key mime-view-mode-map [menu-bar mime-view]
 791              (cons mime-view-menu-title
 792                    (make-sparse-keymap mime-view-menu-title)))
 793            (mapcar (function
 794                     (lambda (item)
 795                       (define-key mime-view-mode-map
 796                         (vector 'menu-bar 'mime-view (car item))
 797                         (cons (nth 1 item)(nth 2 item))
 798                         )
 799                       ))
 800                    (reverse mime-view-menu-list)
 801                    )
 802            ))
 803     (use-local-map mime-view-mode-map)
 804     (run-hooks 'mime-view-define-keymap-hook)
 805     ))
 806
 807 (defun mime-view-mode (&optional mother ctl encoding ibuf obuf
 808                                  default-keymap-or-function)
 809   "Major mode for viewing MIME message.
 810
 811 Here is a list of the standard keys for mime-view-mode.
 812
 813 key             feature
 814 ---             -------
 815
 816 u               Move to upper content
 817 p or M-TAB      Move to previous content
 818 n or TAB        Move to next content
 819 SPC             Scroll up or move to next content
 820 M-SPC or DEL    Scroll down or move to previous content
 821 RET             Move to next line
 822 M-RET           Move to previous line
 823 v               Decode current content as `play mode'
 824 e               Decode current content as `extract mode'
 825 C-c C-p         Decode current content as `print mode'
 826 a               Followup to current content.
 827 x               Display X-Face
 828 q               Quit
 829 button-2        Move to point under the mouse cursor
 830                 and decode current content as `play mode'
 831 "
 832   (interactive)
 833   (let ((buf (get-buffer mime/output-buffer-name)))
 834     (if buf
 835         (save-excursion
 836           (set-buffer buf)
 837           (erase-buffer)
 838           )))
 839   (let ((ret (mime-view-setup-buffer ctl encoding ibuf obuf))
 840         (win-conf (current-window-configuration))
 841         )
 842     (prog1
 843         (switch-to-buffer (car ret))
 844       (setq mime::preview/original-window-configuration win-conf)
 845       (if mother
 846           (progn
 847             (setq mime::preview/mother-buffer mother)
 848             ))
 849       (mime-view-define-keymap default-keymap-or-function)
 850       (setq mime::preview/content-list (nth 1 ret))
 851       (goto-char
 852        (let ((ce (mime::preview-content-info/point-max
 853                   (car mime::preview/content-list)
 854                   ))
 855              e)
 856          (goto-char (point-min))
 857          (search-forward "\n\n" nil t)
 858          (setq e (match-end 0))
 859          (if (<= e ce)
 860              e
 861            ce)))
 862       (run-hooks 'mime-view-mode-hook)
 863       )))
 864
 865 (defun mime-preview/point-content-number (point)
 866   (save-window-excursion
 867     (let ((pc (mime-preview/point-pcinfo (point)))
 868           cinfo)
 869       (switch-to-buffer (mime::preview-content-info/buffer pc))
 870       (setq cinfo (mime::preview-content-info/content-info pc))
 871       (mime-article/point-content-number (mime::content-info/point-min cinfo))
 872       )))
 873
 874 (defun mime-preview/cinfo-to-pcinfo (cinfo)
 875   (let ((rpcl mime::preview/content-list) cell)
 876     (catch 'tag
 877       (while rpcl
 878         (setq cell (car rpcl))
 879         (if (eq cinfo (mime::preview-content-info/content-info cell))
 880             (throw 'tag cell)
 881           )
 882         (setq rpcl (cdr rpcl))
 883         ))))
 884
 885 (autoload 'mime-view-play-current-entity "mime-play" "Play current entity." t)
 886
 887 (defun mime-view-extract-current-entity ()
 888   "Extract current entity into file (maybe).
 889 It decodes current entity to call internal or external method as
 890 \"extract\" mode.  The method is selected from variable
 891 `mime/content-decoding-condition'."
 892   (interactive)
 893   (mime-view-play-current-entity "extract")
 894   )
 895
 896 (defun mime-view-print-current-entity ()
 897   "Print current entity (maybe).
 898 It decodes current entity to call internal or external method as
 899 \"print\" mode.  The method is selected from variable
 900 `mime/content-decoding-condition'."
 901   (interactive)
 902   (mime-view-play-current-entity "print")
 903   )
 904
 905 (defun mime-view-follow-content ()
 906   (interactive)
 907   (let ((root-cinfo
 908          (mime::preview-content-info/content-info
 909           (car mime::preview/content-list)))
 910         pc p-beg p-end cinfo rcnum)
 911     (let ((rest mime::preview/content-list)
 912           b e cell len rc)
 913       (if (catch 'tag
 914             (while (setq cell (car rest))
 915               (setq b (mime::preview-content-info/point-min cell)
 916                     e (mime::preview-content-info/point-max cell))
 917               (setq rest (cdr rest))
 918               (if (and (<= b (point))(<= (point) e))
 919                   (throw 'tag cell)
 920                 )
 921               ))
 922           (progn
 923             (setq pc cell
 924                   cinfo (mime::preview-content-info/content-info pc)
 925                   rcnum (mime::content-info/rcnum cinfo))
 926             (setq len (length rcnum))
 927             (setq p-beg (mime::preview-content-info/point-min pc)
 928                   p-end (mime::preview-content-info/point-max pc))
 929             (while (and (setq cell (car rest))
 930                         (progn
 931                           (setq rc
 932                                 (mime::content-info/rcnum
 933                                  (mime::preview-content-info/content-info
 934                                   cell)))
 935                           (equal rcnum
 936                                  (nthcdr (- (length rc) len) rc))
 937                           ))
 938               (setq p-end (mime::preview-content-info/point-max cell))
 939               (setq rest (cdr rest))
 940               ))))
 941     (if pc
 942         (let* ((mode (mime-preview/get-original-major-mode))
 943                (new-name (format "%s-%s" (buffer-name) (reverse rcnum)))
 944                new-buf
 945                (the-buf (current-buffer))
 946                (a-buf mime::preview/article-buffer)
 947                fields)
 948           (save-excursion
 949             (set-buffer (setq new-buf (get-buffer-create new-name)))
 950             (erase-buffer)
 951             (insert-buffer-substring the-buf p-beg p-end)
 952             (goto-char (point-min))
 953             (if (mime-view-header-visible-p rcnum root-cinfo)
 954                 (delete-region (goto-char (point-min))
 955                                (if (re-search-forward "^$" nil t)
 956                                    (match-end 0)
 957                                  (point-min)))
 958               )
 959             (goto-char (point-min))
 960             (insert "\n")
 961             (goto-char (point-min))
 962             (let ((rcnum (mime::content-info/rcnum cinfo)) ci str)
 963               (while (progn
 964                        (setq str
 965                              (save-excursion
 966                                (set-buffer a-buf)
 967                                (setq ci (mime-article/rcnum-to-cinfo rcnum))
 968                                (save-restriction
 969                                  (narrow-to-region
 970                                   (mime::content-info/point-min ci)
 971                                   (mime::content-info/point-max ci)
 972                                   )
 973                                  (std11-header-string-except
 974                                   (concat "^"
 975                                           (apply (function regexp-or) fields)
 976                                           ":") ""))))
 977                        (if (string= (mime::content-info/type ci)
 978                                     "message/rfc822")
 979                            nil
 980                          (if str
 981                              (insert str)
 982                            )
 983                          rcnum))
 984                 (setq fields (std11-collect-field-names)
 985                       rcnum (cdr rcnum))
 986                 )
 987               )
 988             (let ((rest mime-view-following-required-fields-list))
 989               (while rest
 990                 (let ((field-name (car rest)))
 991                   (or (std11-field-body field-name)
 992                       (insert
 993                        (format
 994                         (concat field-name
 995                                 ": "
 996                                 (save-excursion
 997                                   (set-buffer the-buf)
 998                                   (set-buffer mime::preview/mother-buffer)
 999                                   (set-buffer mime::preview/article-buffer)
1000                                   (std11-field-body field-name)
1001                                   )
1002                                 "\n")))
1003                       ))
1004                 (setq rest (cdr rest))
1005                 ))
1006             (eword-decode-header)
1007             )
1008           (let ((f (cdr (assq mode mime-view-following-method-alist))))
1009             (if (functionp f)
1010                 (funcall f new-buf)
1011               (message
1012                (format
1013                 "Sorry, following method for %s is not implemented yet."
1014                 mode))
1015               ))
1016           ))))
1017
1018 (defun mime-view-display-x-face ()
1019   (interactive)
1020   (save-window-excursion
1021     (set-buffer mime::preview/article-buffer)
1022     (mime-view-x-face-function)
1023     ))
1024
1025 (defun mime-view-up-content ()
1026   (interactive)
1027   (let* ((pc (mime-preview/point-pcinfo (point)))
1028          (cinfo (mime::preview-content-info/content-info pc))
1029          (rcnum (mime::content-info/rcnum cinfo))
1030          )
1031     (if rcnum
1032         (let ((r (save-excursion
1033                    (set-buffer (mime::preview-content-info/buffer pc))
1034                    (mime-article/rcnum-to-cinfo (cdr rcnum))
1035                    ))
1036               (rpcl mime::preview/content-list)
1037               cell)
1038           (while (and
1039                   (setq cell (car rpcl))
1040                   (not (eq r (mime::preview-content-info/content-info cell)))
1041                   )
1042             (setq rpcl (cdr rpcl))
1043             )
1044           (goto-char (mime::preview-content-info/point-min cell))
1045           )
1046       (mime-view-quit)
1047       )))
1048
1049 (defun mime-view-previous-content ()
1050   (interactive)
1051   (let* ((pcl mime::preview/content-list)
1052          (p (point))
1053          (i (- (length pcl) 1))
1054          beg)
1055     (catch 'tag
1056       (while (> i 0)
1057         (setq beg (mime::preview-content-info/point-min (nth i pcl)))
1058         (if (> p beg)
1059             (throw 'tag (goto-char beg))
1060           )
1061         (setq i (- i 1))
1062         )
1063       (let ((f (assq mime::preview/original-major-mode
1064                      mime-view-over-to-previous-method-alist)))
1065         (if f
1066             (funcall (cdr f))
1067           ))
1068       )
1069     ))
1070
1071 (defun mime-view-next-content ()
1072   (interactive)
1073   (let ((pcl mime::preview/content-list)
1074         (p (point))
1075         beg)
1076     (catch 'tag
1077       (while pcl
1078         (setq beg (mime::preview-content-info/point-min (car pcl)))
1079         (if (< p beg)
1080             (throw 'tag (goto-char beg))
1081           )
1082         (setq pcl (cdr pcl))
1083         )
1084       (let ((f (assq mime::preview/original-major-mode
1085                      mime-view-over-to-next-method-alist)))
1086         (if f
1087             (funcall (cdr f))
1088           ))
1089       )
1090     ))
1091
1092 (defun mime-view-scroll-up-content (&optional h)
1093   (interactive)
1094   (or h
1095       (setq h (- (window-height) 1))
1096       )
1097   (if (= (point) (point-max))
1098       (let ((f (assq mime::preview/original-major-mode
1099                      mime-view-over-to-next-method-alist)))
1100         (if f
1101             (funcall (cdr f))
1102           ))
1103     (let ((pcl mime::preview/content-list)
1104           (p (point))
1105           np beg)
1106       (setq np
1107             (or (catch 'tag
1108                   (while pcl
1109                     (setq beg (mime::preview-content-info/point-min (car pcl)))
1110                     (if (< p beg)
1111                         (throw 'tag beg)
1112                       )
1113                     (setq pcl (cdr pcl))
1114                     ))
1115                 (point-max)))
1116       (forward-line h)
1117       (if (> (point) np)
1118           (goto-char np)
1119         )
1120       ;;(show-subtree)
1121       ))
1122   )
1123
1124 (defun mime-view-scroll-down-content (&optional h)
1125   (interactive)
1126   (or h
1127       (setq h (- (window-height) 1))
1128       )
1129   (if (= (point) (point-min))
1130       (let ((f (assq mime::preview/original-major-mode
1131                      mime-view-over-to-previous-method-alist)))
1132         (if f
1133             (funcall (cdr f))
1134           ))
1135     (let ((pcl mime::preview/content-list)
1136           (p (point))
1137           pp beg)
1138       (setq pp
1139             (or (let ((i (- (length pcl) 1)))
1140                   (catch 'tag
1141                     (while (> i 0)
1142                       (setq beg (mime::preview-content-info/point-min
1143                                  (nth i pcl)))
1144                       (if (> p beg)
1145                           (throw 'tag beg)
1146                         )
1147                       (setq i (- i 1))
1148                       )))
1149                 (point-min)))
1150       (forward-line (- h))
1151       (if (< (point) pp)
1152           (goto-char pp)
1153         )))
1154   )
1155
1156 (defun mime-view-next-line-content ()
1157   (interactive)
1158   (mime-view-scroll-up-content 1)
1159   )
1160
1161 (defun mime-view-previous-line-content ()
1162   (interactive)
1163   (mime-view-scroll-down-content 1)
1164   )
1165
1166 (defun mime-view-quit ()
1167   (interactive)
1168   (let ((r (save-excursion
1169              (set-buffer (mime::preview-content-info/buffer
1170                           (mime-preview/point-pcinfo (point))))
1171              (assq major-mode mime-view-quitting-method-alist)
1172              )))
1173     (if r
1174         (funcall (cdr r))
1175       )))
1176
1177 (defun mime-view-show-summary ()
1178   (interactive)
1179   (let ((r (save-excursion
1180              (set-buffer
1181               (mime::preview-content-info/buffer
1182                (mime-preview/point-pcinfo (point)))
1183               )
1184              (assq major-mode mime-view-show-summary-method)
1185              )))
1186     (if r
1187         (funcall (cdr r))
1188       )))
1189
1190 (defun mime-view-kill-buffer ()
1191   (interactive)
1192   (kill-buffer (current-buffer))
1193   )
1194
1195
1196 ;;; @ end
1197 ;;;
1198
1199 (provide 'mime-view)
1200
1201 (run-hooks 'mime-view-load-hook)
1202
1203 ;;; mime-view.el ends here