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