cgit.sxemacs.org Git - packages/blob - xemacs-packages/vm/lisp/vm-page.el

   1 ;;; vm-page.el ---  Commands to move around within a VM message
   2 ;
   3 ;; Copyright (C) 1989-1997 Kyle E. Jones
   4 ;; Copyright (C) 2003-2006 Robert Widhopf-Fenk
   5 ;;
   6 ;; This program is free software; you can redistribute it and/or modify
   7 ;; it under the terms of the GNU General Public License as published by
   8 ;; the Free Software Foundation; either version 2 of the License, or
   9 ;; (at your option) any later version.
  10 ;;
  11 ;; This program is distributed in the hope that it will be useful,
  12 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;; GNU General Public License for more details.
  15 ;;
  16 ;; You should have received a copy of the GNU General Public License along
  17 ;; with this program; if not, write to the Free Software Foundation, Inc.,
  18 ;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
  19
  20 ;;; Code:
  21
  22 ;;;###autoload
  23 (defun vm-scroll-forward (&optional arg)
  24   "Scroll forward a screenful of text.
  25 If the current message is being previewed, the message body is revealed.
  26 If at the end of the current message, moves to the next message iff the
  27 value of vm-auto-next-message is non-nil.
  28 Prefix argument N means scroll forward N lines."
  29   (interactive "P")
  30   (let ((mp-changed (vm-follow-summary-cursor))
  31         needs-decoding
  32         (was-invisible nil))
  33     (vm-select-folder-buffer)
  34     (vm-check-for-killed-summary)
  35     (vm-check-for-killed-presentation)
  36     (vm-error-if-folder-empty)
  37     (setq needs-decoding (and vm-display-using-mime
  38                               (not vm-mime-decoded)
  39                               (not (vm-mime-plain-message-p
  40                                     (car vm-message-pointer)))
  41                               vm-auto-decode-mime-messages
  42                               (eq vm-system-state 'previewing)))
  43     (and vm-presentation-buffer
  44          (set-buffer vm-presentation-buffer))
  45     (let ((point (point))
  46           (w (vm-get-visible-buffer-window (current-buffer))))
  47       (if (or (null w)
  48               (not (vm-frame-totally-visible-p (vm-window-frame w))))
  49           (progn
  50             (vm-display (current-buffer) t
  51                         '(vm-scroll-forward vm-scroll-backward)
  52                         (list this-command 'reading-message))
  53             ;; window start sticks to end of clip region when clip
  54             ;; region moves back past it in the buffer.  fix it.
  55             (setq w (vm-get-visible-buffer-window (current-buffer)))
  56             (if (= (window-start w) (point-max))
  57                 (set-window-start w (point-min)))
  58             (setq was-invisible t))))
  59     (if (or mp-changed was-invisible needs-decoding
  60             (and (eq vm-system-state 'previewing)
  61                  (pos-visible-in-window-p
  62                   (point-max)
  63                   (vm-get-visible-buffer-window (current-buffer)))))
  64         (progn
  65           (if (not was-invisible)
  66               (let ((w (vm-get-visible-buffer-window (current-buffer)))
  67                     old-w-start)
  68                 (setq old-w-start (window-start w))
  69                 ;; save-excursion to avoid possible buffer change
  70                 (save-excursion (vm-select-frame (window-frame w)))
  71                 (vm-raise-frame (window-frame w))
  72                 (vm-display nil nil '(vm-scroll-forward vm-scroll-backward)
  73                             (list this-command 'reading-message))
  74                 (setq w (vm-get-visible-buffer-window (current-buffer)))
  75                 (and w (set-window-start w old-w-start))))
  76           (cond ((eq vm-system-state 'previewing)
  77                  (vm-show-current-message)
  78                  ;; The window start marker sometimes drifts forward
  79                  ;; because of something that vm-show-current-message
  80                  ;; does.  In Emacs 20, replacing ASCII chars with
  81                  ;; multibyte chars seems to cause it, but I _think_
  82                  ;; the drift can happen in Emacs 19 and even
  83                  ;; XEmacs for different reasons.  So we reset the
  84                  ;; start marker here, since it is an easy fix.
  85                  (let ((w (vm-get-visible-buffer-window (current-buffer))))
  86                    (set-window-start w (point-min)))))
  87           (vm-howl-if-eom))
  88       (let ((vmp vm-message-pointer)
  89             (msg-buf (current-buffer))
  90             (h-diff 0)
  91             w old-w old-w-height old-w-start result)
  92         (if (eq vm-system-state 'previewing)
  93             (vm-show-current-message))
  94         (setq vm-system-state 'reading)
  95         (setq old-w (vm-get-visible-buffer-window msg-buf)
  96               old-w-height (window-height old-w)
  97               old-w-start (window-start old-w))
  98         (setq w (vm-get-visible-buffer-window msg-buf))
  99         (vm-select-frame (window-frame w))
 100         (vm-raise-frame (window-frame w))
 101         (vm-display nil nil '(vm-scroll-forward vm-scroll-backward)
 102                     (list this-command 'reading-message))
 103         (setq w (vm-get-visible-buffer-window msg-buf))
 104         (if (null w)
 105             (error "current window configuration hides the message buffer.")
 106           (setq h-diff (- (window-height w) old-w-height)))
 107         ;; must restore this since it gets clobbered by window
 108         ;; teardown and rebuild done by the window config stuff.
 109         (set-window-start w old-w-start)
 110         (setq old-w (selected-window))
 111         (unwind-protect
 112             (progn
 113               (select-window w)
 114               (let ((next-screen-context-lines
 115                      (+ next-screen-context-lines h-diff)))
 116                 (while (eq (setq result (vm-scroll-forward-internal arg))
 117                            'tryagain))
 118                 (cond ((and (not (eq result 'next-message))
 119                             vm-honor-page-delimiters)
 120                        (vm-narrow-to-page)
 121                        (goto-char (max (window-start w)
 122                                        (vm-text-of (car vmp))))
 123                        ;; This is needed because in some cases
 124                        ;; the scroll-up call in vm-howl-if-emo
 125                        ;; does not signal end-of-buffer when
 126                        ;; it should unless we do this.  This
 127                        ;; sit-for most likely removes the need
 128                        ;; for the (scroll-up 0) below, but
 129                        ;; since the voodoo has worked this
 130                        ;; long, it's probably best to let it
 131                        ;; be.
 132                        (sit-for 0)
 133                        ;; This voodoo is required!  For some
 134                        ;; reason the 18.52 emacs display
 135                        ;; doesn't immediately reflect the
 136                        ;; clip region change that occurs
 137                        ;; above without this mantra.
 138                        (scroll-up 0)))))
 139           (select-window old-w))
 140         (set-buffer msg-buf)
 141         (cond ((eq result 'next-message)
 142                (vm-next-message))
 143               ((eq result 'end-of-message)
 144                (let ((vm-message-pointer vmp))
 145                  (vm-emit-eom-blurb)))
 146               (t
 147                (and (> (prefix-numeric-value arg) 0)
 148                     (vm-howl-if-eom)))))))
 149   (if (not vm-startup-message-displayed)
 150       (vm-display-startup-message)))
 151
 152 (defun vm-scroll-forward-internal (arg)
 153   (let ((direction (prefix-numeric-value arg))
 154         (w (selected-window)))
 155     (condition-case error-data
 156         (progn (scroll-up arg) nil)
 157 ;; this looks like it should work, but doesn't because the
 158 ;; redisplay code is schizophrenic when it comes to updates.  A
 159 ;; window position may no longer be visible but
 160 ;; pos-visible-in-window-p will still say it is because it was
 161 ;; visible before some window size change happened.
 162 ;;      (progn
 163 ;;        (if (and (> direction 0)
 164 ;;                 (pos-visible-in-window-p
 165 ;;                  (vm-text-end-of (car vm-message-pointer))))
 166 ;;            (signal 'end-of-buffer nil)
 167 ;;          (scroll-up arg))
 168 ;;        nil )
 169       (error
 170        (if (or (and (< direction 0)
 171                     (> (point-min) (vm-text-of (car vm-message-pointer))))
 172                (and (>= direction 0)
 173                     (/= (point-max)
 174                         (vm-text-end-of (car vm-message-pointer)))))
 175            (progn
 176              (vm-widen-page)
 177              (if (>= direction 0)
 178                  (progn
 179                    (forward-page 1)
 180                    (set-window-start w (point))
 181                    nil )
 182                (if (or (bolp)
 183                        (not (save-excursion
 184                               (beginning-of-line)
 185                               (looking-at page-delimiter))))
 186                    (forward-page -1))
 187                (beginning-of-line)
 188                (set-window-start w (point))
 189                'tryagain))
 190          (if (eq (car error-data) 'end-of-buffer)
 191              (if vm-auto-next-message
 192                  'next-message
 193                (set-window-point w (point))
 194                'end-of-message)))))))
 195
 196 ;; exploratory scrolling, what a concept.
 197 ;;
 198 ;; we do this because pos-visible-in-window-p checks the current
 199 ;; window configuration, while this exploratory scrolling forces
 200 ;; Emacs to recompute the display, giving us an up to the moment
 201 ;; answer about where the end of the message is going to be
 202 ;; visible when redisplay finally does occur.
 203 (defun vm-howl-if-eom ()
 204   (let ((w (get-buffer-window (current-buffer))))
 205     (and w
 206          (save-excursion
 207            (save-window-excursion
 208              (condition-case ()
 209                  (let ((next-screen-context-lines 0))
 210                    (select-window w)
 211                    (save-excursion
 212                      (save-window-excursion
 213                        ;; scroll-fix.el replaces scroll-up and
 214                        ;; doesn't behave properly when it hits
 215                        ;; end of buffer.  It does this!
 216                        ;; (ding)
 217                        ;; (message (get 'beginning-of-buffer 'error-message))
 218                        (let ((scroll-in-place-replace-original nil))
 219                          (scroll-up nil))))
 220                    nil)
 221                (error t))))
 222          (= (vm-text-end-of (car vm-message-pointer)) (point-max))
 223          (vm-emit-eom-blurb))))
 224
 225 (defun vm-emit-eom-blurb ()
 226   (interactive)
 227   (let ((vm-summary-uninteresting-senders-arrow "")
 228         (case-fold-search nil))
 229     (message (if (and (stringp vm-summary-uninteresting-senders)
 230                       (string-match vm-summary-uninteresting-senders
 231                                     (vm-su-from (car vm-message-pointer))))
 232                  "End of message %s to %s"
 233                "End of message %s from %s")
 234              (vm-number-of (car vm-message-pointer))
 235              (vm-summary-sprintf "%F" (car vm-message-pointer)))))
 236
 237 ;;;###autoload
 238 (defun vm-scroll-backward (&optional arg)
 239   "Scroll backward a screenful of text.
 240 Prefix N scrolls backward N lines."
 241   (interactive "P")
 242   (vm-scroll-forward (cond ((null arg) '-)
 243                            ((consp arg) (list (- (car arg))))
 244                            ((numberp arg) (- arg))
 245                            ((symbolp arg) nil)
 246                            (t arg))))
 247
 248 ;;;###autoload
 249 (defun vm-scroll-forward-one-line (&optional count)
 250   "Scroll forward one line.
 251 Prefix arg N means scroll forward N lines.
 252 Negative arg means scroll backward."
 253   (interactive "p")
 254   (vm-scroll-forward count))
 255
 256 ;;;###autoload
 257 (defun vm-scroll-backward-one-line (&optional count)
 258   "Scroll backward one line.
 259 Prefix arg N means scroll backward N lines.
 260 Negative arg means scroll forward."
 261   (interactive "p")
 262   (vm-scroll-forward (- count)))
 263
 264 (defun vm-highlight-headers ()
 265   (cond
 266    ((and vm-xemacs-p vm-use-lucid-highlighting)
 267     (require 'highlight-headers)
 268     ;; disable the url marking stuff, since VM has its own interface.
 269     (let ((highlight-headers-mark-urls nil)
 270           (highlight-headers-regexp (or vm-highlighted-header-regexp
 271                                         highlight-headers-regexp)))
 272       (highlight-headers (point-min) (point-max) t)))
 273    (vm-xemacs-p
 274     (let (e)
 275       (map-extents (function
 276                     (lambda (e ignore)
 277                       (if (extent-property e 'vm-highlight)
 278                           (delete-extent e))
 279                       nil))
 280                    (current-buffer) (point-min) (point-max))
 281       (goto-char (point-min))
 282       (while (vm-match-header)
 283         (cond ((vm-match-header vm-highlighted-header-regexp)
 284                (setq e (make-extent (vm-matched-header-contents-start)
 285                                     (vm-matched-header-contents-end)))
 286                (set-extent-property e 'face vm-highlighted-header-face)
 287                (set-extent-property e 'vm-highlight t)))
 288         (goto-char (vm-matched-header-end)))))
 289    ((fboundp 'overlay-put)
 290     (let (o-lists p)
 291       (setq o-lists (overlay-lists)
 292             p (car o-lists))
 293       (while p
 294         (and (overlay-get (car p) 'vm-highlight)
 295              (delete-overlay (car p)))
 296         (setq p (cdr p)))
 297       (setq p (cdr o-lists))
 298       (while p
 299         (and (overlay-get (car p) 'vm-highlight)
 300              (delete-overlay (car p)))
 301         (setq p (cdr p)))
 302       (goto-char (point-min))
 303       (while (vm-match-header)
 304         (cond ((vm-match-header vm-highlighted-header-regexp)
 305                (setq p (make-overlay (vm-matched-header-contents-start)
 306                                      (vm-matched-header-contents-end)))
 307                (overlay-put p 'face vm-highlighted-header-face)
 308                (overlay-put p 'vm-highlight t)))
 309         (goto-char (vm-matched-header-end)))))))
 310
 311 ;;;###autoload
 312 (defun vm-energize-urls (&optional clean-only)
 313   (interactive "P")
 314   ;; Don't search too long in large regions.  If the region is
 315   ;; large, search just the head and the tail of the region since
 316   ;; they tend to contain the interesting text.
 317   (let ((search-limit vm-url-search-limit)
 318         search-pairs n)
 319     (if (and search-limit (> (- (point-max) (point-min)) search-limit))
 320         (setq search-pairs (list (cons (point-min)
 321                                        (+ (point-min) (/ search-limit 2)))
 322                                  (cons (- (point-max) (/ search-limit 2))
 323                                        (point-max))))
 324       (setq search-pairs (list (cons (point-min) (point-max)))))
 325     (cond
 326      (vm-xemacs-p
 327       (let (e)
 328         (map-extents (function
 329                       (lambda (e ignore)
 330                         (if (extent-property e 'vm-url)
 331                             (delete-extent e))
 332                         nil))
 333                      (current-buffer) (point-min) (point-max))
 334         (if clean-only (message "Energy from urls removed!")
 335         (while search-pairs
 336           (goto-char (car (car search-pairs)))
 337           (while (re-search-forward vm-url-regexp (cdr (car search-pairs)) t)
 338             (setq n 1)
 339             (while (null (match-beginning n))
 340               (vm-increment n))
 341             (setq e (make-extent (match-beginning n) (match-end n)))
 342             (set-extent-property e 'vm-url t)
 343             (if vm-highlight-url-face
 344                 (set-extent-property e 'face vm-highlight-url-face))
 345             (if vm-url-browser
 346                 (let ((keymap (make-sparse-keymap))
 347                       (popup-function
 348                        (if (save-excursion
 349                              (goto-char (match-beginning n))
 350                              (looking-at "mailto:"))
 351                            'vm-menu-popup-mailto-url-browser-menu
 352                          'vm-menu-popup-url-browser-menu)))
 353                   (define-key keymap 'button2 'vm-mouse-send-url-at-event)
 354                   (if vm-popup-menu-on-mouse-3
 355                       (define-key keymap 'button3 popup-function))
 356                   (define-key keymap "\r"
 357                     (function (lambda () (interactive)
 358                                 (vm-mouse-send-url-at-position (point)))))
 359                   (set-extent-property e 'vm-button t)
 360                   (set-extent-property e 'keymap keymap)
 361                   (set-extent-property e 'balloon-help 'vm-url-help)
 362                   (set-extent-property e 'highlight t)
 363                   ;; for vm-continue-postponed-message
 364 ;                 (set-extent-property e 'duplicable t)
 365                   )))
 366           (setq search-pairs (cdr search-pairs))))))
 367      ((and vm-fsfemacs-p
 368            (fboundp 'overlay-put))
 369       (let (o-lists o p)
 370         (setq o-lists (overlay-lists)
 371               p (car o-lists))
 372         (while p
 373           (and (overlay-get (car p) 'vm-url)
 374                (delete-overlay (car p)))
 375           (setq p (cdr p)))
 376         (setq p (cdr o-lists))
 377         (while p
 378           (and (overlay-get (car p) 'vm-url)
 379                (delete-overlay (car p)))
 380           (setq p (cdr p)))
 381         (while search-pairs
 382           (goto-char (car (car search-pairs)))
 383           (while (re-search-forward vm-url-regexp (cdr (car search-pairs)) t)
 384             (setq n 1)
 385             (while (null (match-beginning n))
 386               (vm-increment n))
 387             (setq o (make-overlay (match-beginning n) (match-end n)))
 388             (overlay-put o 'vm-url t)
 389             (if vm-highlight-url-face
 390                 (overlay-put o 'face vm-highlight-url-face))
 391             (if vm-url-browser
 392                 (let ((keymap (make-sparse-keymap))
 393                       (popup-function
 394                        (if (save-excursion
 395                              (goto-char (match-beginning n))
 396                              (looking-at "mailto:"))
 397                            'vm-menu-popup-mailto-url-browser-menu
 398                          'vm-menu-popup-url-browser-menu)))
 399                   (overlay-put o 'vm-button t)
 400                   (overlay-put o 'mouse-face 'highlight)
 401                   (setq keymap (nconc keymap (current-local-map)))
 402                   (if vm-popup-menu-on-mouse-3
 403                       (define-key keymap [mouse-3] popup-function))
 404                   (define-key keymap "\r"
 405                     (function (lambda () (interactive)
 406                                 (vm-mouse-send-url-at-position (point)))))
 407                   (overlay-put o 'local-map keymap))))
 408           (setq search-pairs (cdr search-pairs))))))))
 409
 410 (defun vm-energize-headers ()
 411   (cond
 412    (vm-xemacs-p
 413     (let ((search-tuples '(("^From:" vm-menu-author-menu)
 414                            ("^Subject:" vm-menu-subject-menu)))
 415           regexp menu keymap e)
 416       (map-extents (function
 417                     (lambda (e ignore)
 418                       (if (extent-property e 'vm-header)
 419                           (delete-extent e))
 420                       nil))
 421                    (current-buffer) (point-min) (point-max))
 422       (while search-tuples
 423         (goto-char (point-min))
 424         (setq regexp (nth 0 (car search-tuples))
 425               menu (symbol-value (nth 1 (car search-tuples))))
 426         (while (re-search-forward regexp nil t)
 427           (save-excursion (goto-char (match-beginning 0)) (vm-match-header))
 428           (setq e (make-extent (vm-matched-header-contents-start)
 429                                (vm-matched-header-contents-end)))
 430           (set-extent-property e 'vm-header t)
 431           (setq keymap (make-sparse-keymap))
 432           ;; Might as well make button2 do what button3 does in
 433           ;; this case, since there is no default 'select'
 434           ;; action.
 435           (define-key keymap 'button2
 436             (list 'lambda () '(interactive)
 437                   (list 'popup-menu (list 'quote menu))))
 438           (if vm-popup-menu-on-mouse-3
 439               (define-key keymap 'button3
 440                 (list 'lambda () '(interactive)
 441                       (list 'popup-menu (list 'quote menu)))))
 442           (set-extent-property e 'keymap keymap)
 443           (set-extent-property e 'balloon-help 'vm-mouse-3-help)
 444           (set-extent-property e 'highlight t))
 445         (setq search-tuples (cdr search-tuples)))))
 446    ((and vm-fsfemacs-p
 447          (fboundp 'overlay-put))
 448     (let ((search-tuples '(("^From:" vm-menu-fsfemacs-author-menu)
 449                            ("^Subject:" vm-menu-fsfemacs-subject-menu)))
 450           regexp menu
 451           o-lists o p)
 452       (setq o-lists (overlay-lists)
 453             p (car o-lists))
 454       (while p
 455         (and (overlay-get (car p) 'vm-header)
 456              (delete-overlay (car p)))
 457         (setq p (cdr p)))
 458       (setq p (cdr o-lists))
 459       (while p
 460         (and (overlay-get (car p) 'vm-header)
 461              (delete-overlay (car p)))
 462         (setq p (cdr p)))
 463       (while search-tuples
 464         (goto-char (point-min))
 465         (setq regexp (nth 0 (car search-tuples))
 466               menu (symbol-value (nth 1 (car search-tuples))))
 467         (while (re-search-forward regexp nil t)
 468           (goto-char (match-end 0))
 469           (save-excursion (goto-char (match-beginning 0)) (vm-match-header))
 470           (setq o (make-overlay (vm-matched-header-contents-start)
 471                                 (vm-matched-header-contents-end)))
 472           (overlay-put o 'vm-header menu)
 473           (overlay-put o 'mouse-face 'highlight))
 474         (setq search-tuples (cdr search-tuples)))))))
 475
 476 (defun vm-display-xface ()
 477   (cond (vm-xemacs-p (vm-display-xface-xemacs))
 478         ((and vm-fsfemacs-p
 479               (and (stringp vm-uncompface-program)
 480                    (fboundp 'create-image)))
 481          (vm-display-xface-fsfemacs))))
 482
 483 (defun vm-display-xface-xemacs ()
 484   (let ((case-fold-search t) e g h)
 485     (if (map-extents (function
 486                       (lambda (e ignore)
 487                         (if (extent-property e 'vm-xface)
 488                             t
 489                           nil)))
 490                      (current-buffer) (point-min) (point-max))
 491         nil
 492       (goto-char (point-min))
 493       (if (find-face 'vm-xface)
 494           nil
 495         (make-face 'vm-xface)
 496         (set-face-background 'vm-xface "white")
 497         (set-face-foreground 'vm-xface "black"))
 498       (if (re-search-forward "^X-Face:" nil t)
 499           (progn
 500             (goto-char (match-beginning 0))
 501             (vm-match-header)
 502             (setq h (concat "X-Face: " (vm-matched-header-contents)))
 503             (setq g (intern h vm-xface-cache))
 504             (if (boundp g)
 505                 (setq g (symbol-value g))
 506               (set g (make-glyph
 507                       (list
 508                        (list 'global (cons '(tty) [nothing]))
 509                        (list 'global (cons '(win) (vector 'xface ':data h))))))
 510               (setq g (symbol-value g))
 511               ;; XXX broken.  Gives extra pixel lines at the
 512               ;; bottom of the glyph in 19.12
 513               ;;(set-glyph-baseline g 100)
 514               (set-glyph-face g 'vm-xface))
 515             (setq e (make-extent (vm-vheaders-of (car vm-message-pointer))
 516                                  (vm-vheaders-of (car vm-message-pointer))))
 517             (set-extent-property e 'vm-xface t)
 518             (set-extent-begin-glyph e g))))))
 519
 520 (defun vm-display-xface-fsfemacs ()
 521   (catch 'done
 522     (let ((case-fold-search t) i g h ooo)
 523       (setq ooo (overlays-in (point-min) (point-max)))
 524       (while ooo
 525         (if (overlay-get (car ooo) 'vm-xface)
 526             (delete-overlay (car ooo)))
 527         (setq ooo (cdr ooo)))
 528       (goto-char (point-min))
 529       (if (re-search-forward "^X-Face:" nil t)
 530           (progn
 531             (goto-char (match-beginning 0))
 532             (vm-match-header)
 533             (setq h (vm-matched-header-contents))
 534             (setq g (intern h vm-xface-cache))
 535             (if (boundp g)
 536                 (setq g (symbol-value g))
 537               (setq i (vm-convert-xface-to-fsfemacs-image-instantiator h))
 538               (cond (i
 539                      (set g i)
 540                      (setq g (symbol-value g)))
 541                     (t (throw 'done nil))))
 542             (let ((pos (vm-vheaders-of (car vm-message-pointer)))
 543                   o )
 544               ;; An image must replace the normal display of at
 545               ;; least one character.  Since we want to put the
 546               ;; image at the beginning of the visible headers
 547               ;; section, it will obscure the first character of
 548               ;; that section.  To display that character we add
 549               ;; an after-string that contains the character.
 550               ;; Kludge city, but it works.
 551               (setq o (make-overlay (+ 0 pos) (+ 1 pos)))
 552               (overlay-put o 'vm-xface t)
 553               (overlay-put o 'evaporate t)
 554               (overlay-put o 'after-string
 555                            (char-to-string (char-after pos)))
 556               (overlay-put o 'display g)))))))
 557
 558 (defun vm-convert-xface-to-fsfemacs-image-instantiator (data)
 559   (let ((work-buffer nil)
 560         retval)
 561     (catch 'done
 562       (unwind-protect
 563           (save-excursion
 564             (if (not (stringp vm-uncompface-program))
 565                 (throw 'done nil))
 566             (setq work-buffer (vm-make-work-buffer))
 567             (set-buffer work-buffer)
 568             (insert data)
 569             (setq retval
 570                   (apply 'call-process-region
 571                          (point-min) (point-max)
 572                          vm-uncompface-program t t nil
 573                          (if vm-uncompface-accepts-dash-x '("-X") nil)))
 574             (if (not (eq retval 0))
 575                 (throw 'done nil))
 576             (if vm-uncompface-accepts-dash-x
 577                 (throw 'done
 578                        (list 'image ':type 'xbm
 579                              ':ascent 80
 580                              ':foreground "black"
 581                              ':background "white"
 582                              ':data (buffer-string))))
 583             (if (not (stringp vm-icontopbm-program))
 584                 (throw 'done nil))
 585             (goto-char (point-min))
 586             (insert "/* Width=48, Height=48 */\n");
 587             (setq retval
 588                   (call-process-region
 589                    (point-min) (point-max)
 590                    vm-icontopbm-program t t nil))
 591             (if (not (eq retval 0))
 592                 nil
 593               (list 'image ':type 'pbm
 594                     ':ascent 80
 595                     ':foreground "black"
 596                     ':background "white"
 597                     ':data (buffer-string))))
 598         (and work-buffer (kill-buffer work-buffer))))))
 599
 600 (defun vm-url-help (object)
 601   (format
 602    "Use mouse button 2 to send the URL to %s.
 603 Use mouse button 3 to choose a Web browser for the URL."
 604    (cond ((stringp vm-url-browser) vm-url-browser)
 605          ((eq vm-url-browser 'w3-fetch)
 606           "Emacs W3")
 607          ((eq vm-url-browser 'w3-fetch-other-frame)
 608           "Emacs W3")
 609          ((eq vm-url-browser 'vm-mouse-send-url-to-mosaic)
 610           "Mosaic")
 611          ((eq vm-url-browser 'vm-mouse-send-url-to-netscape)
 612           "Netscape")
 613          (t (symbol-name vm-url-browser)))))
 614
 615 ;;;###autoload
 616 (defun vm-energize-urls-in-message-region (&optional start end)
 617   (interactive "r")
 618   (save-excursion
 619     (or start (setq start (vm-headers-of (car vm-message-pointer))))
 620     (or end (setq end (vm-text-end-of (car vm-message-pointer))))
 621     ;; energize the URLs
 622     (if (or vm-highlight-url-face vm-url-browser)
 623         (save-restriction
 624           (widen)
 625           (narrow-to-region start end)
 626           (vm-energize-urls)))))
 627
 628 (defun vm-highlight-headers-maybe ()
 629   ;; highlight the headers
 630   (if (or vm-highlighted-header-regexp
 631           (and vm-xemacs-p vm-use-lucid-highlighting))
 632       (save-restriction
 633         (widen)
 634         (narrow-to-region (vm-headers-of (car vm-message-pointer))
 635                           (vm-text-end-of (car vm-message-pointer)))
 636         (vm-highlight-headers))))
 637
 638 (defun vm-energize-headers-and-xfaces ()
 639   ;; energize certain headers
 640   (if (and vm-use-menus (vm-menu-support-possible-p))
 641       (save-restriction
 642         (widen)
 643         (narrow-to-region (vm-headers-of (car vm-message-pointer))
 644                           (vm-text-of (car vm-message-pointer)))
 645         (vm-energize-headers)))
 646   ;; display xfaces, if we can
 647   (if (and vm-display-xfaces
 648            (or (and vm-xemacs-p (featurep 'xface))
 649                (and vm-fsfemacs-p (fboundp 'create-image)
 650                     (stringp vm-uncompface-program))))
 651       (save-restriction
 652         (widen)
 653         (narrow-to-region (vm-headers-of (car vm-message-pointer))
 654                           (vm-text-of (car vm-message-pointer)))
 655         (vm-display-xface))))
 656
 657 (defun vm-narrow-for-preview (&optional just-passing-through)
 658   (widen)
 659   ;; hide as much of the message body as vm-preview-lines specifies
 660   (narrow-to-region
 661    (vm-vheaders-of (car vm-message-pointer))
 662    (cond ((not (eq vm-preview-lines t))
 663           (min
 664            (vm-text-end-of (car vm-message-pointer))
 665            (save-excursion
 666              (goto-char (vm-text-of (car vm-message-pointer)))
 667              (forward-line (if (natnump vm-preview-lines) vm-preview-lines 0))
 668              ;; KLUDGE CITY: Under XEmacs, an extent's begin-glyph
 669              ;; will be displayed even if the extent is at the end
 670              ;; of a narrowed region.  Thus a message containing
 671              ;; only an image will have the image displayed at
 672              ;; preview time even if vm-preview-lines is 0 provided
 673              ;; vm-mime-decode-for-preview is non-nil.  We kludge
 674              ;; a fix for this by moving everything on the preview
 675              ;; cutoff line one character forward, but only if
 676              ;; we're doing MIME decode for preview.
 677              (if (and (not just-passing-through)
 678                       vm-xemacs-p
 679                       vm-mail-buffer ; in presentation buffer
 680                       vm-auto-decode-mime-messages
 681                       vm-mime-decode-for-preview
 682                       ;; can't do the kludge unless we know that
 683                       ;; when the message is exposed it will be
 684                       ;; decoded and thereby remove the kludge.
 685                       (not (vm-mime-plain-message-p (car vm-message-pointer))))
 686                  (let ((buffer-read-only nil))
 687                    (insert " ")
 688                    (forward-char -1)))
 689              (point))))
 690          (t (vm-text-end-of (car vm-message-pointer))))))
 691
 692 (defun vm-preview-current-message ()
 693   ;; Set just-passing-through if the user will never see the
 694   ;; message in the previewed state.  Save some time later by not
 695   ;; doing preview action that the user will never see anyway.
 696   (let ((just-passing-through
 697          (or (null vm-preview-lines)
 698              (and (not vm-preview-read-messages)
 699                   (not (vm-new-flag (car vm-message-pointer)))
 700                   (not (vm-unread-flag (car vm-message-pointer)))))))
 701     (vm-save-buffer-excursion
 702      (setq vm-system-state 'previewing
 703            vm-mime-decoded nil)
 704      (if vm-real-buffers
 705          (vm-make-virtual-copy (car vm-message-pointer)))
 706
 707      ;; run the message select hooks.
 708      (save-excursion
 709        (vm-select-folder-buffer)
 710        (and vm-select-new-message-hook (vm-new-flag (car vm-message-pointer))
 711             (vm-run-message-hook (car vm-message-pointer)
 712                                  'vm-select-new-message-hook))
 713        (and vm-select-unread-message-hook
 714             (vm-unread-flag (car vm-message-pointer))
 715             (vm-run-message-hook (car vm-message-pointer)
 716                                  'vm-select-unread-message-hook)))
 717
 718      (vm-narrow-for-preview just-passing-through)
 719      (if (or vm-always-use-presentation-buffer
 720              vm-mime-display-function
 721              (or (natnump vm-fill-paragraphs-containing-long-lines)
 722                  (eq 'window-width vm-fill-paragraphs-containing-long-lines))
 723              (and vm-display-using-mime
 724                   (not (vm-mime-plain-message-p (car vm-message-pointer)))))
 725          (let ((layout (vm-mm-layout (car vm-message-pointer))))
 726            (vm-make-presentation-copy (car vm-message-pointer))
 727            (vm-save-buffer-excursion
 728             (vm-replace-buffer-in-windows (current-buffer)
 729                                           vm-presentation-buffer))
 730            (set-buffer vm-presentation-buffer)
 731            (setq vm-system-state 'previewing)
 732            (vm-narrow-for-preview))
 733        (setq vm-presentation-buffer nil)
 734        (and vm-presentation-buffer-handle
 735             (vm-replace-buffer-in-windows vm-presentation-buffer-handle
 736                                           (current-buffer))))
 737
 738      ;; at this point the current buffer is the presentation buffer
 739      ;; if we're using one for this message.
 740      (vm-unbury-buffer (current-buffer))
 741
 742      (if (and vm-display-using-mime
 743               vm-auto-decode-mime-messages
 744               vm-mime-decode-for-preview
 745               (not just-passing-through)
 746               (if vm-mail-buffer
 747                   (not (vm-buffer-variable-value vm-mail-buffer
 748                                                  'vm-mime-decoded))
 749                 (not vm-mime-decoded))
 750               (not (vm-mime-plain-message-p (car vm-message-pointer))))
 751          (if (eq vm-preview-lines 0)
 752              (progn
 753                (vm-decode-mime-message-headers (car vm-message-pointer))
 754                (vm-energize-urls)
 755                (vm-highlight-headers-maybe)
 756                (vm-energize-headers-and-xfaces))
 757            ;; restrict the things that are auto-displayed, since
 758            ;; decode-for-preview is meant to allow a numeric
 759            ;; vm-preview-lines to be useful in the face of multipart
 760            ;; messages.
 761            (let ((vm-auto-displayed-mime-content-type-exceptions
 762                   (cons "message/external-body"
 763                         vm-auto-displayed-mime-content-type-exceptions))
 764                  (vm-mime-external-content-types-alist nil))
 765              (condition-case data
 766                  (progn
 767                    (vm-decode-mime-message)
 768                    ;; reset vm-mime-decoded so that when the user
 769                    ;; opens the message completely, the full MIME
 770                    ;; display will happen.
 771                    (and vm-mail-buffer
 772                         (vm-set-buffer-variable vm-mail-buffer
 773                                                 'vm-mime-decoded nil)))
 774                (vm-mime-error (vm-set-mime-layout-of (car vm-message-pointer)
 775                                                      (car (cdr data)))
 776                               (message "%s" (car (cdr data)))))
 777              (vm-narrow-for-preview)))
 778        (vm-energize-urls-in-message-region)
 779        (vm-highlight-headers-maybe)
 780        (vm-energize-headers-and-xfaces))
 781
 782      (if (and vm-honor-page-delimiters (not just-passing-through))
 783          (vm-narrow-to-page))
 784      (goto-char (vm-text-of (car vm-message-pointer)))
 785      ;; If we have a window, set window start appropriately.
 786      (let ((w (vm-get-visible-buffer-window (current-buffer))))
 787        (if w
 788            (progn (set-window-start w (point-min))
 789                   (set-window-point w (vm-text-of (car vm-message-pointer))))))
 790      (if just-passing-through
 791          (vm-show-current-message)
 792        (vm-update-summary-and-mode-line))))
 793
 794   (vm-run-message-hook (car vm-message-pointer) 'vm-select-message-hook))
 795
 796 (defun vm-show-current-message ()
 797   (and vm-display-using-mime
 798        vm-auto-decode-mime-messages
 799        (if vm-mail-buffer
 800            (not (vm-buffer-variable-value vm-mail-buffer 'vm-mime-decoded))
 801          (not vm-mime-decoded))
 802        (not (vm-mime-plain-message-p (car vm-message-pointer)))
 803        (condition-case data
 804            (vm-decode-mime-message)
 805          (vm-mime-error (vm-set-mime-layout-of (car vm-message-pointer)
 806                                                (car (cdr data)))
 807                         (message "%s" (car (cdr data))))))
 808   (if (and (or (natnump vm-fill-paragraphs-containing-long-lines)
 809                (eq 'window-width vm-fill-paragraphs-containing-long-lines))
 810            (vm-mime-plain-message-p (car vm-message-pointer)))
 811       (let ((needmsg (> (- (vm-text-end-of (car vm-message-pointer))
 812                            (vm-text-of (car vm-message-pointer)))
 813                         12000)))
 814         (if needmsg
 815             (message "Searching for paragraphs to fill..."))
 816         (vm-fill-paragraphs-containing-long-lines
 817          vm-fill-paragraphs-containing-long-lines
 818          (vm-text-of (car vm-message-pointer))
 819          (vm-text-end-of (car vm-message-pointer)))
 820         (if needmsg
 821             (message "Searching for paragraphs to fill... done"))))
 822   (vm-save-buffer-excursion
 823    (save-excursion
 824      (save-excursion
 825        (goto-char (point-min))
 826        (widen)
 827        (narrow-to-region (point) (vm-text-end-of (car vm-message-pointer))))
 828      (if vm-honor-page-delimiters
 829          (progn
 830            (if (looking-at page-delimiter)
 831                (forward-page 1))
 832            (vm-narrow-to-page))))
 833    ;; don't mark the message as read if the user can't see it!
 834    (if (vm-get-visible-buffer-window (current-buffer))
 835        (progn
 836          (save-excursion
 837            (setq vm-system-state 'showing)
 838            (if vm-mail-buffer
 839                (vm-set-buffer-variable vm-mail-buffer 'vm-system-state
 840                                        'showing))
 841            ;; We could be in the presentation buffer here.  Since
 842            ;; the presentation buffer's message pointer and sole
 843            ;; message are a mockup, they will cause trouble if
 844            ;; passed into the undo/update system.  So we switch
 845            ;; into the real message buffer to do attribute
 846            ;; updates.
 847            (vm-select-folder-buffer)
 848            (cond ((vm-new-flag (car vm-message-pointer))
 849                   (vm-set-new-flag (car vm-message-pointer) nil)))
 850            (cond ((vm-unread-flag (car vm-message-pointer))
 851                   (vm-set-unread-flag (car vm-message-pointer) nil)))
 852
 853            (vm-run-message-hook (car vm-message-pointer)
 854                                 'vm-showing-message-hook)
 855            )
 856          (vm-update-summary-and-mode-line)
 857          (vm-howl-if-eom))
 858      (vm-update-summary-and-mode-line))))
 859
 860 ;;;###autoload
 861 (defun vm-expose-hidden-headers ()
 862   "Toggle exposing and hiding message headers that are normally not visible."
 863   (interactive)
 864   (vm-follow-summary-cursor)
 865   (vm-select-folder-buffer)
 866   (vm-check-for-killed-summary)
 867   (vm-check-for-killed-presentation)
 868   (vm-error-if-folder-empty)
 869   (and vm-presentation-buffer
 870        (set-buffer vm-presentation-buffer))
 871   (vm-display (current-buffer) t '(vm-expose-hidden-headers)
 872               '(vm-expose-hidden-headers reading-message))
 873   (let* ((exposed (= (point-min) (vm-start-of (car vm-message-pointer)))))
 874     (vm-widen-page)
 875     (goto-char (point-max))
 876     (widen)
 877     (if exposed
 878         (narrow-to-region (point) (vm-vheaders-of (car vm-message-pointer)))
 879       (narrow-to-region (point) (vm-start-of (car vm-message-pointer))))
 880     (goto-char (point-min))
 881     (let (w)
 882       (setq w (vm-get-visible-buffer-window (current-buffer)))
 883       (and w (set-window-point w (point-min)))
 884       (and w
 885            (= (window-start w) (vm-vheaders-of (car vm-message-pointer)))
 886            (not exposed)
 887            (set-window-start w (vm-start-of (car vm-message-pointer)))))
 888     (if vm-honor-page-delimiters
 889         (vm-narrow-to-page))))
 890
 891 (defun vm-widen-page ()
 892   (if (or (> (point-min) (vm-text-of (car vm-message-pointer)))
 893           (/= (point-max) (vm-text-end-of (car vm-message-pointer))))
 894       (narrow-to-region (vm-vheaders-of (car vm-message-pointer))
 895                         (if (or (vm-new-flag (car vm-message-pointer))
 896                                 (vm-unread-flag (car vm-message-pointer)))
 897                             (vm-text-of (car vm-message-pointer))
 898                           (vm-text-end-of (car vm-message-pointer))))))
 899
 900 (defun vm-narrow-to-page ()
 901   (cond (vm-fsfemacs-p
 902          (if (not (and vm-page-end-overlay
 903                        (overlay-buffer vm-page-end-overlay)))
 904              (let ((g vm-page-continuation-glyph))
 905                (setq vm-page-end-overlay (make-overlay (point) (point)))
 906                (vm-set-extent-property vm-page-end-overlay 'vm-glyph g)
 907                (vm-set-extent-property vm-page-end-overlay 'before-string g)
 908                (overlay-put vm-page-end-overlay 'evaporate nil))))
 909         (vm-xemacs-p
 910          (if (not (and vm-page-end-overlay
 911                        (extent-end-position vm-page-end-overlay)))
 912              (let ((g vm-page-continuation-glyph))
 913                (cond ((not (glyphp g))
 914                       (setq g (make-glyph g))
 915                       (set-glyph-face g 'italic)))
 916                (setq vm-page-end-overlay (make-extent (point) (point)))
 917                (vm-set-extent-property vm-page-end-overlay 'vm-glyph g)
 918                (vm-set-extent-property vm-page-end-overlay 'begin-glyph g)
 919                (set-extent-property vm-page-end-overlay 'detachable nil)))))
 920   (save-excursion
 921     (let (min max (e vm-page-end-overlay))
 922       (if (or (bolp) (not (save-excursion
 923                             (beginning-of-line)
 924                             (looking-at page-delimiter))))
 925           (forward-page -1))
 926       (setq min (point))
 927       (forward-page 1)
 928       (if (not (eobp))
 929           (beginning-of-line))
 930       (cond ((/= (point) (vm-text-end-of (car vm-message-pointer)))
 931              (vm-set-extent-property e vm-begin-glyph-property
 932                                      (vm-extent-property e 'vm-glyph))
 933              (vm-set-extent-endpoints e (point) (point)))
 934             (t
 935              (vm-set-extent-property e vm-begin-glyph-property nil)))
 936       (setq max (point))
 937       (narrow-to-region min max))))
 938
 939 ;;;###autoload
 940 (defun vm-beginning-of-message ()
 941   "Moves to the beginning of the current message."
 942   (interactive)
 943   (vm-follow-summary-cursor)
 944   (vm-select-folder-buffer)
 945   (vm-check-for-killed-summary)
 946   (vm-check-for-killed-presentation)
 947   (vm-error-if-folder-empty)
 948   (and vm-presentation-buffer
 949        (set-buffer vm-presentation-buffer))
 950   (vm-widen-page)
 951   (push-mark)
 952   (vm-display (current-buffer) t '(vm-beginning-of-message)
 953               '(vm-beginning-of-message reading-message))
 954   (vm-save-buffer-excursion
 955     (let ((osw (selected-window)))
 956       (unwind-protect
 957           (progn
 958             (select-window (vm-get-visible-buffer-window (current-buffer)))
 959             (goto-char (point-min)))
 960         (if (not (eq osw (selected-window)))
 961             (select-window osw)))))
 962   (if vm-honor-page-delimiters
 963       (vm-narrow-to-page)))
 964
 965 ;;;###autoload
 966 (defun vm-end-of-message ()
 967   "Moves to the end of the current message, exposing and flagging it read
 968 as necessary."
 969   (interactive)
 970   (vm-follow-summary-cursor)
 971   (vm-select-folder-buffer)
 972   (vm-check-for-killed-summary)
 973   (vm-check-for-killed-presentation)
 974   (vm-error-if-folder-empty)
 975   (and vm-presentation-buffer
 976        (set-buffer vm-presentation-buffer))
 977   (if (eq vm-system-state 'previewing)
 978       (vm-show-current-message))
 979   (setq vm-system-state 'reading)
 980   (vm-widen-page)
 981   (push-mark)
 982   (vm-display (current-buffer) t '(vm-end-of-message)
 983               '(vm-end-of-message reading-message))
 984   (vm-save-buffer-excursion
 985     (let ((osw (selected-window)))
 986       (unwind-protect
 987           (progn
 988             (select-window (vm-get-visible-buffer-window (current-buffer)))
 989             (goto-char (point-max)))
 990         (if (not (eq osw (selected-window)))
 991             (select-window osw)))))
 992   (if vm-honor-page-delimiters
 993       (vm-narrow-to-page)))
 994
 995 ;;;###autoload
 996 (defun vm-move-to-next-button (count)
 997   "Moves to the next button in the current message.
 998 Prefix argument N means move to the Nth next button.
 999 Negative N means move to the Nth previous button.
1000 If there is no next button, an error is signaled and point is not moved.
1001
1002 A button is a highlighted region of text where pressing RETURN
1003 will produce an action.  If the message is being previewed, it is
1004 exposed and marked as read."
1005   (interactive "p")
1006   (vm-follow-summary-cursor)
1007   (vm-select-folder-buffer)
1008   (vm-check-for-killed-summary)
1009   (vm-check-for-killed-presentation)
1010   (vm-error-if-folder-empty)
1011   (and vm-presentation-buffer
1012        (set-buffer vm-presentation-buffer))
1013   (if (eq vm-system-state 'previewing)
1014       (vm-show-current-message))
1015   (setq vm-system-state 'reading)
1016   (vm-widen-page)
1017   (vm-display (current-buffer) t '(vm-move-to-next-button)
1018               '(vm-move-to-next-button reading-message))
1019   (select-window (vm-get-visible-buffer-window (current-buffer)))
1020   (unwind-protect
1021       (vm-move-to-xxxx-button (vm-abs count) (>= count 0))
1022     (if vm-honor-page-delimiters
1023         (vm-narrow-to-page))))
1024
1025 ;;;###autoload
1026 (defun vm-move-to-previous-button (count)
1027   "Moves to the previous button in the current message.
1028 Prefix argument N means move to the Nth previous button.
1029 Negative N means move to the Nth next button.
1030 If there is no previous button, an error is signaled and point is not moved.
1031
1032 A button is a highlighted region of text where pressing RETURN
1033 will produce an action.  If the message is being previewed, it is
1034 exposed and marked as read."
1035   (interactive "p")
1036   (vm-follow-summary-cursor)
1037   (vm-select-folder-buffer)
1038   (vm-check-for-killed-summary)
1039   (vm-check-for-killed-presentation)
1040   (vm-error-if-folder-empty)
1041   (and vm-presentation-buffer
1042        (set-buffer vm-presentation-buffer))
1043   (if (eq vm-system-state 'previewing)
1044       (vm-show-current-message))
1045   (setq vm-system-state 'reading)
1046   (vm-widen-page)
1047   (vm-display (current-buffer) t '(vm-move-to-previous-button)
1048               '(vm-move-to-previous-button reading-message))
1049   (select-window (vm-get-visible-buffer-window (current-buffer)))
1050   (unwind-protect
1051       (vm-move-to-xxxx-button (vm-abs count) (< count 0))
1052     (if vm-honor-page-delimiters
1053         (vm-narrow-to-page))))
1054
1055 (defun vm-move-to-xxxx-button (count next)
1056   (let ((old-point (point))
1057         (endp (if next 'eobp 'bobp))
1058         (extent-end-position (if vm-xemacs-p
1059                                  (if next
1060                                      'extent-end-position
1061                                    'extent-start-position)
1062                                (if next
1063                                    'overlay-end
1064                                  'overlay-start)))
1065         (next-extent-change (if vm-xemacs-p
1066                                 (if next
1067                                     'next-extent-change
1068                                   'previous-extent-change)
1069                               (if next
1070                                   'next-overlay-change
1071                                 'previous-overlay-change)))
1072         e)
1073     (while (and (> count 0) (not (funcall endp)))
1074       (goto-char (funcall next-extent-change (+ (point) (if next 0 -1))))
1075       (setq e (vm-extent-at (point)))
1076       (if e
1077           (progn
1078             (if (vm-extent-property e 'vm-button)
1079                 (vm-decrement count))
1080             (goto-char (funcall extent-end-position e)))))
1081     (if e
1082         (goto-char (vm-extent-start-position e))
1083       (goto-char old-point)
1084       (error "No more buttons"))))
1085
1086 (provide 'vm-page)
1087
1088 ;;; vm-page.el ends here