Mercurial > hg > xemacs-beta

comparison lisp/hyperbole/hvm.el @ 0:376386a54a3c r19-14

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-14
author cvs
date Mon, 13 Aug 2007 08:45:50 +0200
parents
children 4103f0995bd7
comparison
equal deleted inserted replaced
-1:000000000000 0:376386a54a3c
1 ;;!emacs
2 ;;
3 ;; FILE: hvm.el
4 ;; SUMMARY: Support Hyperbole buttons in mail reader: Vm.
5 ;; USAGE: GNU Emacs Lisp Library
6 ;; KEYWORDS: hypermedia, mail
7 ;;
8 ;; AUTHOR: Bob Weiner
9 ;; ORG: Brown U.
10 ;;
11 ;; ORIG-DATE: 10-Oct-91 at 01:51:12
12 ;; LAST-MOD: 23-Jun-95 at 14:55:05 by Bob Weiner
13 ;;
14 ;; This file is part of Hyperbole.
15 ;; Available for use and distribution under the same terms as GNU Emacs.
16 ;;
17 ;; Copyright (C) 1991-1995, Free Software Foundation, Inc.
18 ;; Developed with support from Motorola Inc.
19 ;;
20 ;; DESCRIPTION:
21 ;;
22 ;; Automatically configured for use in "hyperbole.el".
23 ;; If hsite loading fails prior to initializing Hyperbole Vm support,
24 ;;
25 ;; {M-x Vm-init RTN}
26 ;;
27 ;; will do it.
28 ;;
29 ;; DESCRIP-END.
30
31 ;;; ************************************************************************
32 ;;; Other required Elisp libraries
33 ;;; ************************************************************************
34
35 (require 'hmail)
36 (load "hsmail")
37 (require 'vm)
38 (or (and (fboundp 'vm-edit-message) (fboundp 'vm-edit-message-end))
39 (load "vm-edit"))
40 (vm-session-initialization)
41
42 ;;; ************************************************************************
43 ;;; Public variables
44 ;;; ************************************************************************
45
46 ;;; Current versions of VM define this next variable in "vm-vars.el". We
47 ;;; define it here for earlier VM versions.
48 (defvar vm-edit-message-mode nil
49 "*Major mode to use when editing messages in VM.")
50
51 ;;; "hmail.el" procedures will branch improperly if a regular mode, like VM's
52 ;;; default 'text-mode', is used for editing.
53 (setq vm-edit-message-mode 'vm-edit-mode)
54
55 (defun vm-edit-mode ()
56 "Major mode for editing vm mail messages.
57 Special commands:\\{vm-edit-message-map}
58 Turning on vm-edit-mode calls the value of the variable vm-edit-message-hook,
59 if that value is non-nil."
60 (interactive)
61 (kill-all-local-variables)
62 (use-local-map vm-edit-message-map)
63 (setq mode-name "VM Edit")
64 (setq major-mode 'vm-edit-mode)
65 (setq local-abbrev-table text-mode-abbrev-table)
66 (set-syntax-table text-mode-syntax-table)
67 (run-hooks 'vm-edit-message-hook))
68
69 ;;; ************************************************************************
70 ;;; Public functions
71 ;;; ************************************************************************
72
73 (defun Vm-init ()
74 "Initializes Hyperbole support for Vm mail reading."
75 (interactive)
76 (setq hmail:composer 'mail-mode
77 hmail:lister 'vm-summary-mode
78 hmail:modifier 'vm-edit-mode
79 hmail:reader 'vm-mode)
80 ;;
81 ;; Setup public abstract interface to Hyperbole defined mail
82 ;; reader-specific functions used in "hmail.el".
83 ;;
84 (rmail:init)
85 ;;
86 ;; Setup private abstract interface to mail reader-specific functions
87 ;; used in "hmail.el".
88 ;;
89 (fset 'rmail:get-new 'vm-get-new-mail)
90 (fset 'rmail:msg-forward 'vm-forward-message)
91 (fset 'rmail:summ-msg-to 'vm-follow-summary-cursor)
92 (fset 'rmail:summ-new 'vm-summarize)
93 (if (interactive-p)
94 (message "Hyperbole VM mail reader support initialized."))
95 )
96
97 (defun Vm-msg-hdrs-full (toggled)
98 "If TOGGLED is non-nil, toggle full/hidden headers, else show full headers."
99 (save-excursion
100 (if (or toggled
101 (let ((exposed (= (point-min)
102 (vm-start-of (car vm-message-pointer)))))
103 (not exposed)))
104 (progn (vm-expose-hidden-headers)
105 (setq toggled t)))
106 toggled))
107
108 (defun Vm-msg-narrow ()
109 "Narrows mail reader buffer to current message.
110 This includes Hyperbole button data."
111 (save-excursion
112 (vm-select-folder-buffer)
113 (narrow-to-region (point-min) (Vm-msg-end))))
114
115 (defun Vm-msg-next () (vm-next-message 1))
116
117 (defun Vm-msg-num ()
118 "Returns number of vm mail message that point is within, in physical message order."
119 (interactive)
120 (let ((count 1)
121 (case-fold-search))
122 (save-excursion
123 (save-restriction
124 (widen)
125 (while (re-search-backward Vm-msg-start-regexp nil t)
126 (setq count (1+ count)))))
127 count))
128
129 (defun Vm-msg-prev () (vm-previous-message 1))
130
131 (defun Vm-msg-to-p (mail-msg-id mail-file)
132 "Sets current buffer to start of msg with MAIL-MSG-ID in MAIL-FILE.
133 Returns t if successful, else nil or signals error."
134 (if (not (file-readable-p mail-file))
135 nil
136 (vm-visit-folder mail-file)
137 (widen)
138 (goto-char 1)
139 (if (let ((case-fold-search))
140 (re-search-forward (concat rmail:msg-hdr-prefix
141 (regexp-quote mail-msg-id)) nil t))
142 ;; Found matching msg
143 (progn
144 (setq buffer-read-only t)
145 (vm-goto-message-at-point)
146 t))))
147
148 (defun Vm-msg-widen ()
149 "Widens buffer to full current message including Hyperbole button data."
150 (save-excursion
151 (vm-select-folder-buffer)
152 (narrow-to-region (point-min) (Vm-msg-end))))
153
154 (defun Vm-to ()
155 "Sets current buffer to a mail reader buffer."
156 (and (eq major-mode 'vm-summary-mode) (set-buffer vm-mail-buffer)))
157
158 (defun Vm-Summ-delete ()
159 (vm-follow-summary-cursor)
160 (vm-delete-message 1))
161
162 (fset 'Vm-Summ-expunge 'vm-expunge-folder)
163
164 (fset 'Vm-Summ-goto 'vm-follow-summary-cursor)
165
166 (defun Vm-Summ-to ()
167 "Sets current buffer to a mail listing buffer."
168 (and (eq major-mode 'vm-mode) (set-buffer vm-summary-buffer)))
169
170 (defun Vm-Summ-undelete-all ()
171 (message
172 "(Vm-Summ-undelete-all: Vm doesn't have an undelete all msgs function."))
173
174 ;;; ************************************************************************
175 ;;; Private functions
176 ;;; ************************************************************************
177
178 (defun Vm-msg-end ()
179 "Returns end point for current Vm message, including Hyperbole button data.
180 Has side-effect of widening buffer."
181 (save-excursion
182 (goto-char (point-min))
183 (widen)
184 (if (let ((case-fold-search))
185 (re-search-forward Vm-msg-start-regexp nil t))
186 (match-beginning 0)
187 (point-max))))
188
189 ;;; Overlay version of this function from "vm-page.el" to hide any
190 ;;; Hyperbole button data whenever a message is displayed in its entirety.
191 (defun vm-show-current-message ()
192 (save-excursion
193 (save-excursion
194 (goto-char (point-min))
195 (hmail:msg-narrow (point-min) (Vm-msg-end)))
196 (and vm-honor-page-delimiters
197 (save-excursion
198 (if (search-forward page-delimiter nil t)
199 (progn
200 (goto-char (match-beginning 0))
201 (not (looking-at (regexp-quote hmail:hbdata-sep))))))
202 (progn
203 (if (looking-at page-delimiter)
204 (forward-page 1))
205 (vm-narrow-to-page))))
206 ;; don't mark the message as read if the user can't see it!
207 (if (vm-get-buffer-window (current-buffer))
208 (progn
209 (setq vm-system-state 'showing)
210 (cond ((vm-new-flag (car vm-message-pointer))
211 (vm-set-new-flag (car vm-message-pointer) nil)))
212 (cond ((vm-unread-flag (car vm-message-pointer))
213 (vm-set-unread-flag (car vm-message-pointer) nil)))
214 (vm-update-summary-and-mode-line)
215 (vm-howl-if-eom))
216 (if (fboundp 'hproperty:but-create) (hproperty:but-create))
217 (vm-update-summary-and-mode-line)))
218
219 ;;; Overlay version of this function from "vm-page.el" to treat end of
220 ;;; text (excluding Hyperbole button data) as end of message.
221 (defun vm-scroll-forward-internal (arg)
222 (let ((direction (prefix-numeric-value arg))
223 (w (selected-window)))
224 (condition-case error-data
225 (progn (scroll-up arg) nil)
226 (error
227 (if (or (and (< direction 0)
228 (> (point-min) (vm-text-of (car vm-message-pointer))))
229 (and (>= direction 0)
230 (/= (point-max)
231 (save-restriction
232 (hmail:hbdata-start
233 (point-min)
234 (vm-text-end-of
235 (car vm-message-pointer)))))))
236 (progn
237 (vm-widen-page)
238 (if (>= direction 0)
239 (progn
240 (forward-page 1)
241 (set-window-start w (point))
242 nil )
243 (if (or (bolp)
244 (not (save-excursion
245 (beginning-of-line)
246 (looking-at page-delimiter))))
247 (forward-page -1))
248 (beginning-of-line)
249 (set-window-start w (point))
250 'tryagain))
251 (if (eq (car error-data) 'end-of-buffer)
252 (if vm-auto-next-message
253 'next-message
254 (set-window-point w (point))
255 'end-of-message)))))))
256
257 ;;; Overlay version of this function from "vm-page.el" (called by
258 ;;; vm-scroll-* functions). Make it keep Hyperbole button data hidden.
259 (defun vm-widen-page ()
260 (if (or (> (point-min) (vm-text-of (car vm-message-pointer)))
261 (/= (point-max) (vm-text-end-of (car vm-message-pointer))))
262 (hmail:msg-narrow (vm-vheaders-of (car vm-message-pointer))
263 (if (or (vm-new-flag (car vm-message-pointer))
264 (vm-unread-flag (car vm-message-pointer)))
265 (vm-text-of (car vm-message-pointer))
266 (vm-text-end-of (car vm-message-pointer))))))
267
268 ;;; Overlay version of this function from "vm-edit.el" to hide
269 ;;; Hyperbole button data when insert edited message from temporary buffer.
270 (hypb:function-overload 'vm-edit-message nil '(hmail:msg-narrow))
271
272 ;;; Overlay version of this function from "vm-edit.el" to hide
273 ;;; Hyperbole button data when insert edited message from temporary buffer.
274 (defun vm-edit-message-end ()
275 "End the edit of a message and copy the result to its folder."
276 (interactive)
277 (if (null vm-message-pointer)
278 (error "This is not a VM message edit buffer."))
279 (if (null (buffer-name (vm-buffer-of (car vm-message-pointer))))
280 (error "The folder buffer for this message has been killed."))
281 ;; make sure the message ends with a newline
282 (goto-char (point-max))
283 (and (/= (preceding-char) ?\n) (insert ?\n))
284 ;; munge message separators found in the edited message to
285 ;; prevent message from being split into several messages.
286 (vm-munge-message-separators (vm-message-type-of (car vm-message-pointer))
287 (point-min) (point-max))
288 ;; for From_-with-Content-Length recompute the Content-Length header
289 (if (eq (vm-message-type-of (car vm-message-pointer))
290 'From_-with-Content-Length)
291 (let ((buffer-read-only nil)
292 length)
293 (goto-char (point-min))
294 ;; first delete all copies of Content-Length
295 (while (and (re-search-forward vm-content-length-search-regexp nil t)
296 (null (match-beginning 1))
297 (progn (goto-char (match-beginning 0))
298 (vm-match-header vm-content-length-header)))
299 (delete-region (vm-matched-header-start) (vm-matched-header-end)))
300 ;; now compute the message body length
301 (goto-char (point-min))
302 (search-forward "\n\n" nil 0)
303 (setq length (- (point-max) (point)))
304 ;; insert the header
305 (goto-char (point-min))
306 (insert vm-content-length-header " " (int-to-string length) "\n")))
307 (let ((edit-buf (current-buffer))
308 (mp vm-message-pointer))
309 (if (buffer-modified-p)
310 (progn
311 (widen)
312 (save-excursion
313 (set-buffer (vm-buffer-of (vm-real-message-of (car mp))))
314 (if (not (memq (vm-real-message-of (car mp)) vm-message-list))
315 (error "The original copy of this message has been expunged."))
316 (vm-save-restriction
317 (widen)
318 (goto-char (vm-headers-of (vm-real-message-of (car mp))))
319 (let ((vm-message-pointer mp)
320 (buffer-read-only nil))
321 (insert-buffer-substring edit-buf)
322 (delete-region
323 (point) (vm-text-end-of (vm-real-message-of (car mp))))
324 (vm-discard-cached-data)
325 (hmail:msg-narrow))
326 (vm-set-edited-flag-of (car mp) t)
327 (vm-mark-for-summary-update (car mp))
328 (if (eq vm-flush-interval t)
329 (vm-stuff-virtual-attributes (car mp))
330 (vm-set-modflag-of (car mp) t))
331 (vm-set-buffer-modified-p t)
332 (vm-clear-modification-flag-undos)
333 (vm-set-edit-buffer-of (car mp) nil))
334 (set-buffer (vm-buffer-of (car mp)))
335 (if (eq (vm-real-message-of (car mp))
336 (vm-real-message-of (car vm-message-pointer)))
337 (vm-preview-current-message)
338 (vm-update-summary-and-mode-line))))
339 (message "No change."))
340 (vm-display edit-buf nil '(vm-edit-message-end)
341 '(vm-edit-message-end reading-message startup))
342 (set-buffer-modified-p nil)
343 (kill-buffer edit-buf)))
344
345 ;;; Define this function if VM version in use doesn't have it.
346 (or (fboundp 'vm-goto-message-at-point)
347 (defun vm-goto-message-at-point ()
348 "In a VM folder buffer, select the message that contains point."
349 (cond ((fboundp 'vm-update-search-position)
350 (vm-update-search-position t)
351 ;; vm-show-current-message only adjusts (point-max),
352 ;; it doesn't change (point-min).
353 (narrow-to-region
354 (vm-vheaders-of (car vm-message-pointer))
355 (point-max))
356 (vm-show-current-message)
357 (setq vm-system-state 'reading))
358 ((fboundp 'vm-isearch-update)
359 (vm-isearch-update)
360 (narrow-to-region
361 (vm-vheaders-of (car vm-message-pointer))
362 (point-max))
363 (vm-show-current-message)
364 (setq vm-system-state 'reading))
365 (t (error "vm search code is missing, can't continue"))))
366 )
367
368 ;;; Hide any Hyperbole button data when reply to or forward a message.
369 ;;; See "vm-reply.el".
370 (var:append 'vm-mail-mode-hook '(hmail:msg-narrow))
371
372 ;;; Overlay this function from "vm-folder.el" called whenever new mail is
373 ;;; incorporated so that it will highlight Hyperbole buttons when possible.
374 ;; Returns non-nil if there were any new messages.
375 (defun vm-assimilate-new-messages (&optional dont-read-attributes gobble-order)
376 (let ((tail-cons (vm-last vm-message-list))
377 b-list new-messages)
378 (save-excursion
379 (vm-save-restriction
380 (widen)
381 (if (fboundp 'hproperty:but-create)
382 (hproperty:but-create))
383 (vm-build-message-list)
384 (if (or (null tail-cons) (cdr tail-cons))
385 (progn
386 (setq vm-ml-sort-keys nil)
387 (if dont-read-attributes
388 (vm-set-default-attributes (cdr tail-cons))
389 (vm-read-attributes (cdr tail-cons)))
390 ;; Yuck. This has to be done here instead of in the
391 ;; vm function because this needs to be done before
392 ;; any initial thread sort (so that if the thread
393 ;; sort matches the saved order the folder won't be
394 ;; modified) but after the message list is created.
395 ;; Since thread sorting is done here this has to be
396 ;; done here too.
397 (if gobble-order
398 (vm-gobble-message-order))
399 (if vm-thread-obarray
400 (vm-build-threads (cdr tail-cons))))))
401 (setq new-messages (if tail-cons (cdr tail-cons) vm-message-list))
402 (vm-set-numbering-redo-start-point new-messages)
403 (vm-set-summary-redo-start-point new-messages))
404 (if vm-summary-show-threads
405 (progn
406 ;; get numbering and summary of new messages done now
407 ;; so that the sort code only has to worry about the
408 ;; changes it needs to make.
409 (vm-update-summary-and-mode-line)
410 ;; copy the new-messages list because sorting might
411 ;; scramble it. vm-assimilate-new-messages returns
412 ;; this value.
413 (setq new-messages (copy-sequence new-messages))
414 (vm-sort-messages "thread")))
415 (if (and new-messages vm-virtual-buffers)
416 (save-excursion
417 (setq b-list vm-virtual-buffers)
418 (while b-list
419 ;; buffer might be dead
420 (if (buffer-name (car b-list))
421 (let (tail-cons)
422 (set-buffer (car b-list))
423 (setq tail-cons (vm-last vm-message-list))
424 (vm-build-virtual-message-list new-messages)
425 (if (or (null tail-cons) (cdr tail-cons))
426 (progn
427 (setq vm-ml-sort-keys nil)
428 (if vm-thread-obarray
429 (vm-build-threads (cdr tail-cons)))
430 (vm-set-summary-redo-start-point
431 (or (cdr tail-cons) vm-message-list))
432 (vm-set-numbering-redo-start-point
433 (or (cdr tail-cons) vm-message-list))
434 (if (null vm-message-pointer)
435 (progn (setq vm-message-pointer vm-message-list
436 vm-need-summary-pointer-update t)
437 (if vm-message-pointer
438 (vm-preview-current-message))))
439 (if vm-summary-show-threads
440 (progn
441 (vm-update-summary-and-mode-line)
442 (vm-sort-messages "thread")))))))
443 (setq b-list (cdr b-list)))))
444 new-messages ))
445
446 ;;; Overlay version of 'vm-force-mode-line-update' from "vm-folder.el"
447 ;;; to highlight Hyperbole buttons in summary buffers.
448 (defun vm-force-mode-line-update ()
449 "Force a mode line update in all frames."
450 (if vm-summary-buffer
451 (save-excursion
452 (set-buffer vm-summary-buffer)
453 (if (fboundp 'hproperty:but-create) (hproperty:but-create))))
454 (if (fboundp 'force-mode-line-update)
455 (force-mode-line-update t)
456 (save-excursion
457 (set-buffer (other-buffer))
458 (set-buffer-modified-p (buffer-modified-p)))))
459
460 ;;; ************************************************************************
461 ;;; Private variables
462 ;;; ************************************************************************
463
464 (defvar Vm-msg-start-regexp "\n\nFrom \\|\n\001\001\001\001"
465 "Regular expression that begins a Vm mail message.")
466
467 (provide 'hvm)