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-view-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-view-buffer nil
 323   "MIME View buffer corresponding with the (raw) buffer.")
 324 (make-variable-buffer-local 'mime-view-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-view-original-major-mode nil
 341   "Major-mode in mime-raw-buffer.")
 342 (make-variable-buffer-local 'mime-view-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-view-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-view-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-view-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-view-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 content"      mime-view-move-to-upper)
 669     (previous    "Move to previous content"   mime-view-move-to-previous)
 670     (next        "Move to next content"       mime-view-move-to-next)
 671     (scroll-down "Scroll to previous content" mime-view-scroll-down-entity)
 672     (scroll-up   "Scroll to next content"     mime-view-scroll-up-entity)
 673     (play        "Play Content"               mime-view-play-current-entity)
 674     (extract     "Extract Content"            mime-view-extract-current-entity)
 675     (print       "Print"                      mime-view-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-view-move-to-upper))
 707     (define-key mime-view-mode-map
 708       "p"        (function mime-view-move-to-previous))
 709     (define-key mime-view-mode-map
 710       "n"        (function mime-view-move-to-next))
 711     (define-key mime-view-mode-map
 712       "\e\t"     (function mime-view-move-to-previous))
 713     (define-key mime-view-mode-map
 714       "\t"       (function mime-view-move-to-next))
 715     (define-key mime-view-mode-map
 716       " "        (function mime-view-scroll-up-entity))
 717     (define-key mime-view-mode-map
 718       "\M- "     (function mime-view-scroll-down-entity))
 719     (define-key mime-view-mode-map
 720       "\177"     (function mime-view-scroll-down-entity))
 721     (define-key mime-view-mode-map
 722       "\C-m"     (function mime-view-next-line-content))
 723     (define-key mime-view-mode-map
 724       "\C-\M-m"  (function mime-view-previous-line-content))
 725     (define-key mime-view-mode-map
 726       "v"        (function mime-view-play-current-entity))
 727     (define-key mime-view-mode-map
 728       "e"        (function mime-view-extract-current-entity))
 729     (define-key mime-view-mode-map
 730       "\C-c\C-p" (function mime-view-print-current-entity))
 731     (define-key mime-view-mode-map
 732       "a"        (function mime-view-follow-current-entity))
 733     (define-key mime-view-mode-map
 734       "q"        (function mime-view-quit))
 735     (define-key mime-view-mode-map
 736       "h"        (function mime-view-show-summary))
 737     (define-key mime-view-mode-map
 738       "\C-c\C-x" (function mime-view-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-view-move-to-next))
 747     (define-key mime-view-mode-map
 748       [delete] (function mime-view-scroll-down-entity))
 749     (define-key mime-view-mode-map
 750       [backspace] (function mime-view-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-view-play-current-entity "mime-play" "Play current entity." t)
 851
 852 (defun mime-view-extract-current-entity ()
 853   "Extract current entity into file (maybe).
 854 It decodes current entity to call internal or external method as
 855 \"extract\" mode.  The method is selected from variable
 856 `mime-acting-condition'."
 857   (interactive)
 858   (mime-view-play-current-entity "extract")
 859   )
 860
 861 (defun mime-view-print-current-entity ()
 862   "Print current entity (maybe).
 863 It decodes current entity to call internal or external method as
 864 \"print\" mode.  The method is selected from variable
 865 `mime-acting-condition'."
 866   (interactive)
 867   (mime-view-play-current-entity "print")
 868   )
 869
 870
 871 ;;; @@ following
 872 ;;;
 873
 874 (defun mime-view-get-original-major-mode ()
 875   "Return major-mode of original buffer.
 876 If a current buffer has mime-mother-buffer, return original major-mode
 877 of the mother-buffer."
 878   (if mime-mother-buffer
 879       (save-excursion
 880         (set-buffer mime-mother-buffer)
 881         (mime-view-get-original-major-mode)
 882         )
 883     mime-view-original-major-mode))
 884
 885 (defun mime-view-follow-current-entity ()
 886   "Write follow message to current entity.
 887 It calls following-method selected from variable
 888 `mime-view-following-method-alist'."
 889   (interactive)
 890   (let ((root-cinfo (get-text-property (point-min) 'mime-view-cinfo))
 891         cinfo)
 892     (while (null (setq cinfo (get-text-property (point) 'mime-view-cinfo)))
 893       (backward-char)
 894       )
 895     (let* ((p-beg (previous-single-property-change (point) 'mime-view-cinfo))
 896            p-end
 897            (rcnum (mime-entity-info-rnum cinfo))
 898            (len (length rcnum))
 899            )
 900       (cond ((null p-beg)
 901              (setq p-beg
 902                    (if (eq (next-single-property-change (point-min)
 903                                                         'mime-view-cinfo)
 904                            (point))
 905                        (point)
 906                      (point-min)))
 907              )
 908             ((eq (next-single-property-change p-beg 'mime-view-cinfo)
 909                  (point))
 910              (setq p-beg (point))
 911              ))
 912       (setq p-end (next-single-property-change p-beg 'mime-view-cinfo))
 913       (cond ((null p-end)
 914              (setq p-end (point-max))
 915              )
 916             ((null rcnum)
 917              (setq p-end (point-max))
 918              )
 919             (t
 920              (save-excursion
 921                (goto-char p-end)
 922                (catch 'tag
 923                  (let (e)
 924                    (while (setq e
 925                                 (next-single-property-change
 926                                  (point) 'mime-view-cinfo))
 927                      (goto-char e)
 928                      (let ((rc (mime-entity-info-rnum
 929                                 (get-text-property (point)
 930                                                    'mime-view-cinfo))))
 931                        (or (equal rcnum (nthcdr (- (length rc) len) rc))
 932                            (throw 'tag nil)
 933                            ))
 934                      (setq p-end e)
 935                      ))
 936                  (setq p-end (point-max))
 937                  ))
 938              ))
 939       (let* ((mode (mime-view-get-original-major-mode))
 940              (new-name (format "%s-%s" (buffer-name) (reverse rcnum)))
 941              new-buf
 942              (the-buf (current-buffer))
 943              (a-buf mime-raw-buffer)
 944              fields)
 945         (save-excursion
 946           (set-buffer (setq new-buf (get-buffer-create new-name)))
 947           (erase-buffer)
 948           (insert-buffer-substring the-buf p-beg p-end)
 949           (goto-char (point-min))
 950           (if (mime-view-header-visible-p rcnum root-cinfo)
 951               (delete-region (goto-char (point-min))
 952                              (if (re-search-forward "^$" nil t)
 953                                  (match-end 0)
 954                                (point-min)))
 955             )
 956           (goto-char (point-min))
 957           (insert "\n")
 958           (goto-char (point-min))
 959           (let ((rcnum (mime-entity-info-rnum cinfo)) ci str)
 960             (while (progn
 961                      (setq str
 962                            (save-excursion
 963                              (set-buffer a-buf)
 964                              (setq ci (mime-article/rcnum-to-cinfo rcnum))
 965                              (save-restriction
 966                                (narrow-to-region
 967                                 (mime-entity-info-point-min ci)
 968                                 (mime-entity-info-point-max ci)
 969                                 )
 970                                (std11-header-string-except
 971                                 (concat "^"
 972                                         (apply (function regexp-or) fields)
 973                                         ":") ""))))
 974                      (if (and
 975                           (eq (mime-entity-info-media-type ci) 'message)
 976                           (eq (mime-entity-info-media-subtype ci) 'rfc822))
 977                          nil
 978                        (if str
 979                            (insert str)
 980                          )
 981                        rcnum))
 982               (setq fields (std11-collect-field-names)
 983                     rcnum (cdr rcnum))
 984               )
 985             )
 986           (let ((rest mime-view-following-required-fields-list))
 987             (while rest
 988               (let ((field-name (car rest)))
 989                 (or (std11-field-body field-name)
 990                     (insert
 991                      (format
 992                       (concat field-name
 993                               ": "
 994                               (save-excursion
 995                                 (set-buffer the-buf)
 996                                 (set-buffer mime-mother-buffer)
 997                                 (set-buffer mime-raw-buffer)
 998                                 (std11-field-body field-name)
 999                                 )
1000                               "\n")))
1001                     ))
1002               (setq rest (cdr rest))
1003               ))
1004           (eword-decode-header)
1005           )
1006         (let ((f (cdr (assq mode mime-view-following-method-alist))))
1007           (if (functionp f)
1008               (funcall f new-buf)
1009             (message
1010              (format
1011               "Sorry, following method for %s is not implemented yet."
1012               mode))
1013             ))
1014         ))))
1015
1016
1017 ;;; @@ X-Face
1018 ;;;
1019
1020 (defun mime-view-display-x-face ()
1021   (interactive)
1022   (save-window-excursion
1023     (set-buffer mime-raw-buffer)
1024     (mime-view-x-face-function)
1025     ))
1026
1027
1028 ;;; @@ moving
1029 ;;;
1030
1031 (defun mime-view-move-to-upper ()
1032   "Move to upper entity.
1033 If there is no upper entity, call function `mime-view-quit'."
1034   (interactive)
1035   (let (cinfo)
1036     (while (null (setq cinfo (get-text-property (point) 'mime-view-cinfo)))
1037       (backward-char)
1038       )
1039     (let ((r (mime-article/rcnum-to-cinfo
1040               (cdr (mime-entity-info-rnum cinfo))
1041               (get-text-property 1 'mime-view-cinfo)))
1042           point)
1043       (catch 'tag
1044         (while (setq point (previous-single-property-change
1045                             (point) 'mime-view-cinfo))
1046           (goto-char point)
1047           (if (eq r (get-text-property (point) 'mime-view-cinfo))
1048               (throw 'tag t)
1049             )
1050           )
1051         (mime-view-quit)
1052         ))))
1053
1054 (defun mime-view-move-to-previous ()
1055   "Move to previous entity.
1056 If there is no previous entity, it calls function registered in
1057 variable `mime-view-over-to-previous-method-alist'."
1058   (interactive)
1059   (while (null (get-text-property (point) 'mime-view-cinfo))
1060     (backward-char)
1061     )
1062   (let ((point (previous-single-property-change (point) 'mime-view-cinfo)))
1063     (if point
1064         (goto-char point)
1065       (let ((f (assq mime-view-original-major-mode
1066                      mime-view-over-to-previous-method-alist)))
1067         (if f
1068             (funcall (cdr f))
1069           ))
1070       )))
1071
1072 (defun mime-view-move-to-next ()
1073   "Move to next entity.
1074 If there is no previous entity, it calls function registered in
1075 variable `mime-view-over-to-next-method-alist'."
1076   (interactive)
1077   (let ((point (next-single-property-change (point) 'mime-view-cinfo)))
1078     (if point
1079         (goto-char point)
1080       (let ((f (assq mime-view-original-major-mode
1081                      mime-view-over-to-next-method-alist)))
1082         (if f
1083             (funcall (cdr f))
1084           ))
1085       )))
1086
1087 (defun mime-view-scroll-up-entity (&optional h)
1088   "Scroll up current entity.
1089 If reached to (point-max), it calls function registered in variable
1090 `mime-view-over-to-next-method-alist'."
1091   (interactive)
1092   (or h
1093       (setq h (1- (window-height)))
1094       )
1095   (if (= (point) (point-max))
1096       (let ((f (assq mime-view-original-major-mode
1097                      mime-view-over-to-next-method-alist)))
1098         (if f
1099             (funcall (cdr f))
1100           ))
1101     (let ((point
1102            (or (next-single-property-change (point) 'mime-view-cinfo)
1103                (point-max))))
1104       (forward-line h)
1105       (if (> (point) point)
1106           (goto-char point)
1107         )
1108       )))
1109
1110 (defun mime-view-scroll-down-entity (&optional h)
1111   "Scroll down current entity.
1112 If reached to (point-min), it calls function registered in variable
1113 `mime-view-over-to-previous-method-alist'."
1114   (interactive)
1115   (or h
1116       (setq h (1- (window-height)))
1117       )
1118   (if (= (point) (point-min))
1119       (let ((f (assq mime-view-original-major-mode
1120                      mime-view-over-to-previous-method-alist)))
1121         (if f
1122             (funcall (cdr f))
1123           ))
1124     (let (point)
1125       (save-excursion
1126         (catch 'tag
1127           (while (> (point) 1)
1128             (if (setq point
1129                       (previous-single-property-change (point)
1130                                                        'mime-view-cinfo))
1131                 (throw 'tag t)
1132               )
1133             (backward-char)
1134             )
1135           (setq point (point-min))
1136           ))
1137       (forward-line (- h))
1138       (if (< (point) point)
1139           (goto-char point)
1140         ))))
1141
1142 (defun mime-view-next-line-content ()
1143   (interactive)
1144   (mime-view-scroll-up-entity 1)
1145   )
1146
1147 (defun mime-view-previous-line-content ()
1148   (interactive)
1149   (mime-view-scroll-down-entity 1)
1150   )
1151
1152
1153 ;;; @@ quitting
1154 ;;;
1155
1156 (defun mime-view-quit ()
1157   "Quit from MIME-View buffer.
1158 It calls function registered in variable
1159 `mime-view-quitting-method-alist'."
1160   (interactive)
1161   (let ((r (assq mime-view-original-major-mode
1162                  mime-view-quitting-method-alist)))
1163     (if r
1164         (funcall (cdr r))
1165       )))
1166
1167 (defun mime-view-show-summary ()
1168   "Show summary.
1169 It calls function registered in variable
1170 `mime-view-show-summary-method'."
1171   (interactive)
1172   (let ((r (assq mime-view-original-major-mode
1173                  mime-view-show-summary-method)))
1174     (if r
1175         (funcall (cdr r))
1176       )))
1177
1178 (defun mime-view-kill-buffer ()
1179   (interactive)
1180   (kill-buffer (current-buffer))
1181   )
1182
1183
1184 ;;; @ end
1185 ;;;
1186
1187 (provide 'mime-view)
1188
1189 (run-hooks 'mime-view-load-hook)
1190
1191 ;;; mime-view.el ends here