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.42 $
  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.42 1997-03-17 13:32:52 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-view-entity-button-function
 284   (rcnum cinfo ctype params subj encoding)
 285   "Insert entity button conditionally."
 286   (if (and (consp rcnum)
 287            (not (member
 288                  ctype
 289                  mime-view-content-button-ignored-ctype-list)))
 290       (mime-view-insert-entity-button
 291        rcnum cinfo ctype params subj encoding)
 292     ))
 293
 294
 295 ;;; @@ content header filter
 296 ;;;
 297
 298 (defun mime-preview/cut-header ()
 299   (goto-char (point-min))
 300   (while (and
 301           (re-search-forward mime-view-ignored-field-regexp nil t)
 302           (let* ((beg (match-beginning 0))
 303                  (end (match-end 0))
 304                  (name (buffer-substring beg end))
 305                  )
 306             (if (not (string-match mime-view-visible-field-regexp name))
 307                 (delete-region
 308                  beg
 309                  (save-excursion
 310                    (and
 311                     (re-search-forward "^\\([^ \t]\\|$\\)" nil t)
 312                     (match-beginning 0)
 313                     )))
 314               )
 315             t)))
 316   )
 317
 318 (defun mime-view-default-content-header-filter ()
 319   (mime-preview/cut-header)
 320   (eword-decode-header)
 321   )
 322
 323 (defvar mime-view-content-header-filter-alist nil)
 324
 325
 326 ;;; @@ content filter
 327 ;;;
 328
 329 (defvar mime-view-content-filter-alist
 330   '(("text/enriched" . mime-preview/filter-for-text/enriched)
 331     ("text/richtext" . mime-preview/filter-for-text/richtext)
 332     (t . mime-preview/filter-for-text/plain)
 333     ))
 334
 335
 336 ;;; @@ content separator
 337 ;;;
 338
 339 (defun mime-preview/default-content-separator (rcnum cinfo ctype params subj)
 340   (if (and (not (mime-view-header-visible-p rcnum cinfo ctype))
 341            (not (mime-view-body-visible-p rcnum cinfo ctype))
 342            )
 343       (progn
 344         (goto-char (point-max))
 345         (insert "\n")
 346         )))
 347
 348
 349 ;;; @@ buffer local variables
 350 ;;;
 351
 352 ;;; @@@ in raw buffer
 353 ;;;
 354
 355 (make-variable-buffer-local 'mime::article/content-info)
 356
 357 (defvar mime::article/preview-buffer nil)
 358 (make-variable-buffer-local 'mime::article/preview-buffer)
 359
 360
 361 ;;; @@@ in view buffer
 362 ;;;
 363
 364 (make-variable-buffer-local 'mime::preview/mother-buffer)
 365 (make-variable-buffer-local 'mime::preview/content-list)
 366
 367 (defvar mime::preview/article-buffer nil)
 368 (make-variable-buffer-local 'mime::preview/article-buffer)
 369
 370 (make-variable-buffer-local 'mime::preview/original-major-mode)
 371 (make-variable-buffer-local 'mime::preview/original-window-configuration)
 372
 373
 374 ;;; @@ quitting method
 375 ;;;
 376
 377 (defvar mime-view-quitting-method-alist
 378   '((mime/show-message-mode
 379      . mime-view-quitting-method-for-mime/show-message-mode)))
 380
 381 (defvar mime-view-over-to-previous-method-alist nil)
 382 (defvar mime-view-over-to-next-method-alist nil)
 383
 384 (defvar mime-view-show-summary-method nil)
 385
 386
 387 ;;; @@ following method
 388 ;;;
 389
 390 (defvar mime-view-following-method-alist nil)
 391
 392 (defvar mime-view-following-required-fields-list
 393   '("From"))
 394
 395
 396 ;;; @@ X-Face
 397 ;;;
 398
 399 ;; hack from Gnus 5.0.4.
 400
 401 (defvar mime-view-x-face-to-pbm-command
 402   "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm")
 403
 404 (defvar mime-view-x-face-command
 405   (concat mime-view-x-face-to-pbm-command
 406           " | xv -quit -")
 407   "String to be executed to display an X-Face field.
 408 The command will be executed in a sub-shell asynchronously.
 409 The compressed face will be piped to this command.")
 410
 411 (defun mime-view-x-face-function ()
 412   "Function to display X-Face field. You can redefine to customize."
 413   ;; 1995/10/12 (c.f. tm-eng:130)
 414   ;;    fixed by Eric Ding <ericding@San-Jose.ate.slb.com>
 415   (save-restriction
 416     (narrow-to-region (point-min) (re-search-forward "^$" nil t))
 417     ;; end
 418     (goto-char (point-min))
 419     (if (re-search-forward "^X-Face:[ \t]*" nil t)
 420         (let ((beg (match-end 0))
 421               (end (std11-field-end))
 422               )
 423           (call-process-region beg end "sh" nil 0 nil
 424                                "-c" mime-view-x-face-command)
 425           ))))
 426
 427
 428 ;;; @@ utility
 429 ;;;
 430
 431 (defun mime-preview/get-original-major-mode ()
 432   (if mime::preview/mother-buffer
 433       (save-excursion
 434         (set-buffer mime::preview/mother-buffer)
 435         (mime-preview/get-original-major-mode)
 436         )
 437     mime::preview/original-major-mode))
 438
 439
 440 ;;; @ data structures
 441 ;;;
 442
 443 ;;; @@ preview-content-info
 444 ;;;
 445
 446 (define-structure mime::preview-content-info
 447   point-min point-max buffer content-info)
 448
 449
 450 ;;; @ buffer setup
 451 ;;;
 452
 453 (defun mime-view-setup-buffer (&optional ctl encoding ibuf obuf)
 454   (if ibuf
 455       (progn
 456         (get-buffer ibuf)
 457         (set-buffer ibuf)
 458         ))
 459   (or mime-view-redisplay
 460       (setq mime::article/content-info (mime-parse-message ctl encoding))
 461       )
 462   (let ((ret (mime-view-make-preview-buffer obuf)))
 463     (setq mime::article/preview-buffer (car ret))
 464     ret))
 465
 466 (defun mime-view-make-preview-buffer (&optional obuf)
 467   (let* ((cinfo mime::article/content-info)
 468          (pcl (mime/flatten-content-info cinfo))
 469          (dest (make-list (length pcl) nil))
 470          (the-buf (current-buffer))
 471          (mode major-mode)
 472          )
 473     (or obuf
 474         (setq obuf (concat "*Preview-" (buffer-name the-buf) "*")))
 475     (set-buffer (get-buffer-create obuf))
 476     (setq buffer-read-only nil)
 477     (widen)
 478     (erase-buffer)
 479     (setq mime::preview/article-buffer the-buf)
 480     (setq mime::preview/original-major-mode mode)
 481     (setq major-mode 'mime-view-mode)
 482     (setq mode-name "MIME-View")
 483     (let ((drest dest))
 484       (while pcl
 485         (setcar drest
 486                 (mime-preview/display-content (car pcl) cinfo the-buf obuf))
 487         (setq pcl (cdr pcl)
 488               drest (cdr drest))
 489         ))
 490     (set-buffer-modified-p nil)
 491     (setq buffer-read-only t)
 492     (set-buffer the-buf)
 493     (list obuf dest)
 494     ))
 495
 496 (defun mime-preview/display-content (content cinfo ibuf obuf)
 497   (let* ((beg (mime::content-info/point-min content))
 498          (end (mime::content-info/point-max content))
 499          (ctype (mime::content-info/type content))
 500          (params (mime::content-info/parameters content))
 501          (encoding (mime::content-info/encoding content))
 502          (rcnum (mime::content-info/rcnum content))
 503          he e nb ne subj)
 504     (set-buffer ibuf)
 505     (goto-char beg)
 506     (setq he (if (re-search-forward "^$" nil t)
 507                  (1+ (match-end 0))
 508                end))
 509     (if (> he end)
 510         (setq he end)
 511       )
 512     (save-restriction
 513       (narrow-to-region beg end)
 514       (setq subj
 515             (eword-decode-string
 516              (mime-article/get-subject params encoding)))
 517       )
 518     (set-buffer obuf)
 519     (setq nb (point))
 520     (narrow-to-region nb nb)
 521     (mime-view-entity-button-function 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