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