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