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