mime-view.el

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