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