/[cmucl]/src/hemlock/mh.lisp
ViewVC logotype

Contents of /src/hemlock/mh.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.2.1.4 - (show annotations) (vendor branch)
Fri Nov 9 23:34:13 1990 UTC (23 years, 5 months ago) by wlott
Changes since 1.2.1.3: +4 -4 lines
Replaced mach:unix-subtestname and lisp::predict-name with
mach:unix-file-kind and ext:unix-namestring.
1 ;;; -*- Package: Hemlock; Log: hemlock.log -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; This code was written as part of the Spice Lisp project at
5 ;;; Carnegie-Mellon University, and has been placed in the public domain.
6 ;;; Spice Lisp is currently incomplete and under active development.
7 ;;; you want to use this code or any part of Spice Lisp, please contact
8 ;;; Scott Fahlman (FAHLMAN@CS.CMU.EDU).
9 ;;; **********************************************************************
10 ;;;
11 ;;; This is a mailer interface to MH.
12 ;;;
13 ;;; Written by Bill Chiles.
14 ;;;
15
16 (in-package "HEMLOCK")
17
18
19
20 ;;;; General stuff.
21
22 (defvar *new-mail-buffer* nil)
23
24 (defvar *mh-utility-bit-bucket* (make-broadcast-stream))
25
26
27 (defattribute "Digit"
28 "This is just a (mod 2) attribute for base 10 digit characters.")
29 ;;;
30 (dotimes (i 10)
31 (setf (character-attribute :digit (digit-char i)) 1))
32
33
34 (defmacro number-string (number)
35 `(let ((*print-base* 10))
36 (prin1-to-string ,number)))
37
38
39 (defmacro do-headers-buffers ((buffer-var folder &optional hinfo-var)
40 &rest forms)
41 "The Forms are evaluated with Buffer-Var bound to each buffer containing
42 headers lines for folder. Optionally Hinfo-Var is bound to the
43 headers-information structure."
44 (let ((folder-var (gensym))
45 (hinfo (gensym)))
46 `(let ((,folder-var ,folder))
47 (declare (simple-string ,folder-var))
48 (dolist (,buffer-var *buffer-list*)
49 (when (hemlock-bound-p 'headers-information :buffer ,buffer-var)
50 (let ((,hinfo (variable-value 'headers-information
51 :buffer ,buffer-var)))
52 (when (string= (the simple-string (headers-info-folder ,hinfo))
53 ,folder-var)
54 ,@(if hinfo-var
55 `((let ((,hinfo-var ,hinfo))
56 ,@forms))
57 forms))))))))
58
59 (defmacro do-headers-lines ((hbuffer &key line-var mark-var) &rest forms)
60 "Forms are evaluated for each non-blank line. When supplied Line-Var and
61 Mark-Var are to the line and a :left-inserting mark at the beginning of the
62 line. This works with DELETE-HEADERS-BUFFER-LINE, but one should be careful
63 using this to modify the hbuffer."
64 (let ((line-var (or line-var (gensym)))
65 (mark-var (or mark-var (gensym)))
66 (id (gensym)))
67 `(with-mark ((,mark-var (buffer-point ,hbuffer) :left-inserting))
68 (buffer-start ,mark-var)
69 (loop
70 (let* ((,line-var (mark-line ,mark-var))
71 (,id (line-message-id ,line-var)))
72 (unless (blank-line-p ,line-var)
73 ,@forms)
74 (if (or (not (eq ,line-var (mark-line ,mark-var)))
75 (string/= ,id (line-message-id ,line-var)))
76 (line-start ,mark-var)
77 (unless (line-offset ,mark-var 1 0) (return))))))))
78
79 (defmacro with-headers-mark ((mark-var hbuffer msg) &rest forms)
80 "Forms are executed with Mark-Var bound to a :left-inserting mark at the
81 beginning of the headers line representing msg. If no such line exists,
82 no execution occurs."
83 (let ((line (gensym)))
84 `(do-headers-lines (,hbuffer :line-var ,line :mark-var ,mark-var)
85 (when (string= (the simple-string (line-message-id ,line))
86 (the simple-string ,msg))
87 ,@forms
88 (return)))))
89
90
91
92 ;;;; Headers Mode.
93
94 (defmode "Headers" :major-p t)
95
96 (defhvar "Headers Information"
97 "This holds the information about the current headers buffer."
98 :value nil)
99
100 (defstruct (headers-info (:print-function print-headers-info))
101 buffer ;Buffer for these headers.
102 folder ;String name of folder with leading MH "+".
103 msg-seq ;MH sequence of messages in buffer.
104 msg-strings ;List of strings representing msg-seq.
105 other-msg-bufs ;List of message buffers referencing this headers buffer.
106 draft-bufs ;List of draft buffers referencing this headers buffer.
107 msg-buffer)
108
109 (defun print-headers-info (obj str n)
110 (declare (ignore n))
111 (format str "#<Headers Info ~S>" (headers-info-folder obj)))
112
113 (defmacro line-message-deleted (line)
114 `(getf (line-plist ,line) 'mh-msg-deleted))
115
116 (defmacro line-message-id (line)
117 `(getf (line-plist ,line) 'mh-msg-id))
118
119 (defun headers-current-message (hinfo)
120 (let* ((point (buffer-point (headers-info-buffer hinfo)))
121 (line (mark-line point)))
122 (unless (blank-line-p line)
123 (values (line-message-id line)
124 (copy-mark point)))))
125
126 (defcommand "Message Headers" (p)
127 "Prompts for a folder and messages, displaying headers in a buffer in the
128 current window. With an argument, prompt for a pick expression."
129 "Show some headers."
130 (let ((folder (prompt-for-folder)))
131 (new-message-headers
132 folder
133 (prompt-for-message :prompt (if p
134 "MH messages to pick from: "
135 "MH messages: ")
136 :folder folder
137 :messages "all")
138 p)))
139
140 (defcommand "Pick Headers" (p)
141 "Further narrow the selection of this folders headers.
142 Prompts for a pick expression to pick over the headers in the current
143 buffer. Entering an empty expression displays all the headers for that
144 folder."
145 "Prompts for a pick expression to pick over the headers in the current
146 buffer."
147 (declare (ignore p))
148 (let ((hinfo (value headers-information)))
149 (unless hinfo
150 (editor-error "Pick Headers only works in a headers buffer."))
151 (pick-message-headers hinfo)))
152
153 ;;; PICK-MESSAGE-HEADERS picks messages from info's messages based on an
154 ;;; expression provided by the user. If the expression is empty, we do
155 ;;; headers on all the messages in folder. The buffer's name is changed to
156 ;;; reflect the messages picked over and the expression used.
157 ;;;
158 (defun pick-message-headers (hinfo)
159 (let ((folder (headers-info-folder hinfo))
160 (msgs (headers-info-msg-strings hinfo)))
161 (multiple-value-bind (pick user-pick)
162 (prompt-for-pick-expression)
163 (let* ((hbuffer (headers-info-buffer hinfo))
164 (new-mail-buf-p (eq hbuffer *new-mail-buffer*))
165 (region (cond (pick
166 (message-headers-to-region
167 folder (pick-messages folder msgs pick)))
168 (new-mail-buf-p
169 (maybe-get-new-mail-msg-hdrs folder))
170 (t (message-headers-to-region folder
171 (list "all"))))))
172 (with-writable-buffer (hbuffer)
173 (revamp-headers-buffer hbuffer hinfo)
174 (when region (insert-message-headers hbuffer hinfo region)))
175 (setf (buffer-modified hbuffer) nil)
176 (buffer-start (buffer-point hbuffer))
177 (setf (buffer-name hbuffer)
178 (cond (pick (format nil "Headers ~A ~A ~A" folder msgs user-pick))
179 (new-mail-buf-p (format nil "Unseen Headers ~A" folder))
180 (t (format nil "Headers ~A (all)" folder))))))))
181
182 ;;; NEW-MESSAGE-HEADERS picks over msgs if pickp is non-nil, or it just scans
183 ;;; msgs. It is important to pick and get the message headers region before
184 ;;; making the buffer and info structures since PICK-MESSAGES and
185 ;;; MESSAGE-HEADERS-TO-REGION will call EDITOR-ERROR if they fail. The buffer
186 ;;; name is chosen based on folder, msgs, and an optional pick expression.
187 ;;;
188 (defun new-message-headers (folder msgs &optional pickp)
189 (multiple-value-bind (pick-exp user-pick)
190 (if pickp (prompt-for-pick-expression))
191 (let* ((pick (if pick-exp (pick-messages folder msgs pick-exp)))
192 (region (message-headers-to-region folder (or pick msgs)))
193 (hbuffer (maybe-make-mh-buffer (format nil "Headers ~A ~A~:[~; ~S~]"
194 folder msgs pick user-pick)
195 :headers))
196 (hinfo (make-headers-info :buffer hbuffer :folder folder)))
197 (insert-message-headers hbuffer hinfo region)
198 (defhvar "Headers Information"
199 "This holds the information about the current headers buffer."
200 :value hinfo :buffer hbuffer)
201 (setf (buffer-modified hbuffer) nil)
202 (setf (buffer-writable hbuffer) nil)
203 (buffer-start (buffer-point hbuffer))
204 (change-to-buffer hbuffer))))
205
206 (defhvar "MH Scan Line Form"
207 "This is a pathname of a file containing an MH format expression for headers
208 lines."
209 :value (pathname "/usr/misc/.cmucl/lib/mh-scan"))
210
211 ;;; MESSAGE-HEADERS-TO-REGION uses the MH "scan" utility output headers into
212 ;;; buffer for folder and msgs.
213 ;;;
214 ;;; (value fill-column) should really be done as if the buffer were current,
215 ;;; but Hemlock doesn't let you do this without the buffer being current.
216 ;;;
217 (defun message-headers-to-region (folder msgs &optional width)
218 (let ((region (make-empty-region)))
219 (with-output-to-mark (*standard-output* (region-end region) :full)
220 (mh "scan"
221 `(,folder ,@msgs
222 "-form" ,(namestring (value mh-scan-line-form))
223 "-width" ,(number-string (or width (value fill-column)))
224 "-noheader")))
225 region))
226
227 (defun insert-message-headers (hbuffer hinfo region)
228 (ninsert-region (buffer-point hbuffer) region)
229 (let ((seq (set-message-headers-ids hbuffer :return-seq)))
230 (setf (headers-info-msg-seq hinfo) seq)
231 (setf (headers-info-msg-strings hinfo) (mh-sequence-strings seq)))
232 (when (value virtual-message-deletion)
233 (note-deleted-headers hbuffer
234 (mh-sequence-list (headers-info-folder hinfo)
235 "hemlockdeleted"))))
236
237 (defun set-message-headers-ids (hbuffer &optional return-seq)
238 (let ((msgs nil))
239 (do-headers-lines (hbuffer :line-var line)
240 (let* ((line-str (line-string line))
241 (num (parse-integer line-str :junk-allowed t)))
242 (declare (simple-string line-str))
243 (unless num
244 (editor-error "MH scan lines must contain the message id as the ~
245 first thing on the line for the Hemlock interface."))
246 (setf (line-message-id line) (number-string num))
247 (when return-seq (setf msgs (mh-sequence-insert num msgs)))))
248 msgs))
249
250 (defun note-deleted-headers (hbuffer deleted-seq)
251 (when deleted-seq
252 (do-headers-lines (hbuffer :line-var line :mark-var hmark)
253 (if (mh-sequence-member-p (line-message-id line) deleted-seq)
254 (note-deleted-message-at-mark hmark)
255 (setf (line-message-deleted line) nil)))))
256
257 ;;; PICK-MESSAGES -- Internal Interface.
258 ;;;
259 ;;; This takes a folder (with a + in front of the name), messages to pick
260 ;;; over, and an MH pick expression (in the form returned by
261 ;;; PROMPT-FOR-PICK-EXPRESSION). Sequence is an MH sequence to set to exactly
262 ;;; those messages chosen by the pick when zerop is non-nil; when zerop is nil,
263 ;;; pick adds the messages to the sequence along with whatever messages were
264 ;;; already in the sequence. This returns a list of message specifications.
265 ;;;
266 (defun pick-messages (folder msgs expression &optional sequence (zerop t))
267 (let* ((temp (with-output-to-string (*standard-output*)
268 (unless
269 ;; If someone bound *signal-mh-errors* to nil around this
270 ;; function, MH pick outputs bogus messages (for example,
271 ;; "0"), and MH would return without calling EDITOR-ERROR.
272 (mh "pick" `(,folder
273 ,@msgs
274 ,@(if sequence `("-sequence" ,sequence))
275 ,@(if zerop '("-zero"))
276 "-list" ; -list must follow -sequence.
277 ,@expression))
278 (return-from pick-messages nil))))
279 (len (length temp))
280 (start 0)
281 (result nil))
282 (declare (simple-string temp))
283 (loop
284 (let ((end (position #\newline temp :start start :test #'char=)))
285 (cond ((not end)
286 (return (nreverse (cons (subseq temp start) result))))
287 ((= start end)
288 (return (nreverse result)))
289 (t
290 (push (subseq temp start end) result)
291 (when (>= (setf start (1+ end)) len)
292 (return (nreverse result)))))))))
293
294
295 (defcommand "Delete Headers Buffer and Message Buffers" (p &optional buffer)
296 "Prompts for a headers buffer to delete along with its associated message
297 buffers. Any associated draft buffers are left alone, but their associated
298 message buffers will be deleted."
299 "Deletes the current headers buffer and its associated message buffers."
300 (declare (ignore p))
301 (let* ((default (cond ((value headers-information) (current-buffer))
302 ((value message-information) (value headers-buffer))))
303 (buffer (or buffer
304 (prompt-for-buffer :default default
305 :default-string
306 (if default (buffer-name default))))))
307 (unless (hemlock-bound-p 'headers-information :buffer buffer)
308 (editor-error "Not a headers buffer -- ~A" (buffer-name buffer)))
309 (let* ((hinfo (variable-value 'headers-information :buffer buffer))
310 ;; Copy list since buffer cleanup hook is destructive.
311 (other-bufs (copy-list (headers-info-other-msg-bufs hinfo)))
312 (msg-buf (headers-info-msg-buffer hinfo)))
313 (when msg-buf (delete-buffer-if-possible msg-buf))
314 (dolist (b other-bufs) (delete-buffer-if-possible b))
315 (delete-buffer-if-possible (headers-info-buffer hinfo)))))
316
317 (defhvar "Expunge Messages Confirm"
318 "When set (the default), \"Expunge Messages\" and \"Quit Headers\" will ask
319 for confirmation before expunging messages and packing the folder's message
320 id's."
321 :value t)
322
323 (defhvar "Temporary Draft Folder"
324 "This is the folder name where MH fcc: messages are kept that are intended
325 to be deleted and expunged when messages are expunged for any other
326 folder -- \"Expunge Messages\" and \"Quit Headers\"."
327 :value nil)
328
329 ;;; "Quit Headers" doesn't expunge or compact unless there is a deleted
330 ;;; sequence. This collapses other headers buffers into the same folder
331 ;;; differently than "Expunge Messages" since the latter assumes there will
332 ;;; always be one remaining headers buffer. This command folds all headers
333 ;;; buffers into the folder that are not the current buffer or the new mail
334 ;;; buffer into one buffer. When the current buffer is the new mail buffer
335 ;;; we do not check for more unseen headers since we are about to delete
336 ;;; the buffer anyway. The other headers buffers must be deleted before
337 ;;; making the new one due to aliasing the buffer structure and
338 ;;; MAYBE-MAKE-MH-BUFFER.
339 ;;;
340 (defcommand "Quit Headers" (p)
341 "Quit headers buffer possibly expunging deleted messages.
342 This affects the current headers buffer. When there are deleted messages
343 the user is asked for confirmation on expunging the messages and packing the
344 folder's message id's. Then the buffer and all its associated message
345 buffers are deleted. Setting \"Quit Headers Confirm\" to nil inhibits
346 prompting. When \"Temporary Draft Folder\" is bound, this folder's messages
347 are deleted and expunged."
348 "This affects the current headers buffer. When there are deleted messages
349 the user is asked for confirmation on expunging the messages and packing
350 the folder. Then the buffer and all its associated message buffers are
351 deleted."
352 (declare (ignore p))
353 (let* ((hinfo (value headers-information))
354 (minfo (value message-information))
355 (hdrs-buf (cond (hinfo (current-buffer))
356 (minfo (value headers-buffer)))))
357 (unless hdrs-buf
358 (editor-error "Not in or associated with any headers buffer."))
359 (let* ((folder (cond (hinfo (headers-info-folder hinfo))
360 (minfo (message-info-folder minfo))))
361 (deleted-seq (mh-sequence-list folder "hemlockdeleted")))
362 (when (and deleted-seq
363 (or (not (value expunge-messages-confirm))
364 (prompt-for-y-or-n
365 :prompt (list "Expunge messages and pack folder ~A? "
366 folder)
367 :default t
368 :default-string "Y")))
369 (message "Deleting messages ...")
370 (mh "rmm" (list folder "hemlockdeleted"))
371 (let ((*standard-output* *mh-utility-bit-bucket*))
372 (message "Compacting folder ...")
373 (mh "folder" (list folder "-fast" "-pack")))
374 (message "Maintaining consistency ...")
375 (let (hbufs)
376 (declare (list hbufs))
377 (do-headers-buffers (b folder)
378 (unless (or (eq b hdrs-buf) (eq b *new-mail-buffer*))
379 (push b hbufs)))
380 (dolist (b hbufs)
381 (delete-headers-buffer-and-message-buffers-command nil b))
382 (when hbufs
383 (new-message-headers folder (list "all"))))
384 (expunge-messages-fix-draft-buffers folder)
385 (unless (eq hdrs-buf *new-mail-buffer*)
386 (expunge-messages-fix-unseen-headers folder))
387 (delete-and-expunge-temp-drafts)))
388 (delete-headers-buffer-and-message-buffers-command nil hdrs-buf)))
389
390 ;;; DELETE-AND-EXPUNGE-TEMP-DRAFTS deletes all the messages in the
391 ;;; temporary draft folder if there is one defined. Any headers buffers
392 ;;; into this folder are deleted with their message buffers. We have to
393 ;;; create a list of buffers to delete since buffer deletion destructively
394 ;;; modifies the same list DO-HEADERS-BUFFERS uses. "rmm" is run without
395 ;;; error reporting since it signals an error if there are no messages to
396 ;;; delete. This function must return; for example, "Quit Headers" would
397 ;;; not complete successfully if this ended up calling EDITOR-ERROR.
398 ;;;
399 (defun delete-and-expunge-temp-drafts ()
400 (let ((temp-draft-folder (value temporary-draft-folder)))
401 (when temp-draft-folder
402 (setf temp-draft-folder (coerce-folder-name temp-draft-folder))
403 (message "Deleting and expunging temporary drafts ...")
404 (when (mh "rmm" (list temp-draft-folder "all") :errorp nil)
405 (let (hdrs)
406 (declare (list hdrs))
407 (do-headers-buffers (b temp-draft-folder)
408 (push b hdrs))
409 (dolist (b hdrs)
410 (delete-headers-buffer-and-message-buffers-command nil b)))))))
411
412
413
414 ;;;; Message Mode.
415
416 (defmode "Message" :major-p t)
417
418 (defhvar "Message Information"
419 "This holds the information about the current message buffer."
420 :value nil)
421
422 (defstruct message/draft-info
423 headers-mark) ;Mark pointing to a headers line in a headers buffer.
424
425 (defstruct (message-info (:include message/draft-info)
426 (:print-function print-message-info))
427 folder ;String name of folder with leading MH "+".
428 msgs ;List of strings representing messages to be shown.
429 draft-buf ;Possible draft buffer reference.
430 keep) ;Whether message buffer may be re-used.
431
432 (defun print-message-info (obj str n)
433 (declare (ignore n))
434 (format str "#<Message Info ~S ~S>"
435 (message-info-folder obj) (message-info-msgs obj)))
436
437
438 (defcommand "Next Message" (p)
439 "Show the next message.
440 When in a message buffer, shows the next message in the associated headers
441 buffer. When in a headers buffer, moves point down a line and shows that
442 message."
443 "When in a message buffer, shows the next message in the associated headers
444 buffer. When in a headers buffer, moves point down a line and shows that
445 message."
446 (declare (ignore p))
447 (show-message-offset 1))
448
449 (defcommand "Previous Message" (p)
450 "Show the previous message.
451 When in a message buffer, shows the previous message in the associated
452 headers buffer. When in a headers buffer, moves point up a line and shows
453 that message."
454 "When in a message buffer, shows the previous message in the associated
455 headers buffer. When in a headers buffer, moves point up a line and
456 shows that message."
457 (declare (ignore p))
458 (show-message-offset -1))
459
460 (defcommand "Next Undeleted Message" (p)
461 "Show the next undeleted message.
462 When in a message buffer, shows the next undeleted message in the associated
463 headers buffer. When in a headers buffer, moves point down to a line
464 without a deleted message and shows that message."
465 "When in a message buffer, shows the next undeleted message in the associated
466 headers buffer. When in a headers buffer, moves point down to a line without
467 a deleted message and shows that message."
468 (declare (ignore p))
469 (show-message-offset 1 :undeleted))
470
471 (defcommand "Previous Undeleted Message" (p)
472 "Show the previous undeleted message.
473 When in a message buffer, shows the previous undeleted message in the
474 associated headers buffer. When in a headers buffer, moves point up a line
475 without a deleted message and shows that message."
476 "When in a message buffer, shows the previous undeleted message in the
477 associated headers buffer. When in a headers buffer, moves point up a line
478 without a deleted message and shows that message."
479 (declare (ignore p))
480 (show-message-offset -1 :undeleted))
481
482 (defun show-message-offset (offset &optional undeleted)
483 (let ((minfo (value message-information)))
484 (cond
485 ((not minfo)
486 (let ((hinfo (value headers-information)))
487 (unless hinfo (editor-error "Not in a message or headers buffer."))
488 (show-message-offset-hdrs-buf hinfo offset undeleted)))
489 ((message-info-keep minfo)
490 (let ((hbuf (value headers-buffer)))
491 (unless hbuf (editor-error "Not associated with a headers buffer."))
492 (let ((hinfo (variable-value 'headers-information :buffer hbuf))
493 (point (buffer-point hbuf)))
494 (move-mark point (message-info-headers-mark minfo))
495 (show-message-offset-hdrs-buf hinfo offset undeleted))))
496 (t
497 (show-message-offset-msg-buf minfo offset undeleted)))))
498
499 (defun show-message-offset-hdrs-buf (hinfo offset undeleted)
500 (unless hinfo (editor-error "Not in a message or headers buffer."))
501 (unless (show-message-offset-mark (buffer-point (headers-info-buffer hinfo))
502 offset undeleted)
503 (editor-error "No ~:[previous~;next~] ~:[~;undeleted ~]message."
504 (plusp offset) undeleted))
505 (show-headers-message hinfo))
506
507 (defun show-message-offset-msg-buf (minfo offset undeleted)
508 (let ((msg-mark (message-info-headers-mark minfo)))
509 (unless msg-mark (editor-error "Not associated with a headers buffer."))
510 (unless (show-message-offset-mark msg-mark offset undeleted)
511 (let ((hbuf (value headers-buffer))
512 (mbuf (current-buffer)))
513 (setf (current-buffer) hbuf)
514 (setf (window-buffer (current-window)) hbuf)
515 (delete-buffer-if-possible mbuf))
516 (editor-error "No ~:[previous~;next~] ~:[~;undeleted ~]message."
517 (plusp offset) undeleted))
518 (move-mark (buffer-point (line-buffer (mark-line msg-mark))) msg-mark)
519 (let* ((next-msg (line-message-id (mark-line msg-mark)))
520 (folder (message-info-folder minfo))
521 (mbuffer (current-buffer)))
522 (with-writable-buffer (mbuffer)
523 (delete-region (buffer-region mbuffer))
524 (setf (buffer-name mbuffer) (get-storable-msg-buf-name folder next-msg))
525 (setf (message-info-msgs minfo) next-msg)
526 (read-mh-file (merge-pathnames next-msg
527 (merge-relative-pathnames
528 (strip-folder-name folder)
529 (mh-directory-pathname)))
530 mbuffer)
531 (let ((unseen-seq (mh-profile-component "unseen-sequence")))
532 (when unseen-seq
533 (mark-one-message folder next-msg unseen-seq :delete))))))
534 (let ((dbuffer (message-info-draft-buf minfo)))
535 (when dbuffer
536 (delete-variable 'message-buffer :buffer dbuffer)
537 (setf (message-info-draft-buf minfo) nil))))
538
539 (defun get-storable-msg-buf-name (folder msg)
540 (let ((name (format nil "Message ~A ~A" folder msg)))
541 (if (not (getstring name *buffer-names*))
542 name
543 (let ((n 2))
544 (loop
545 (setf name (format nil "Message ~A ~A copy ~D" folder msg n))
546 (unless (getstring name *buffer-names*)
547 (return name))
548 (incf n))))))
549
550 (defun show-message-offset-mark (msg-mark offset undeleted)
551 (with-mark ((temp msg-mark))
552 (let ((winp
553 (cond (undeleted
554 (loop
555 (unless (and (line-offset temp offset 0)
556 (not (blank-line-p (mark-line temp))))
557 (return nil))
558 (unless (line-message-deleted (mark-line temp))
559 (return t))))
560 ((and (line-offset temp offset 0)
561 (not (blank-line-p (mark-line temp)))))
562 (t nil))))
563 (if winp (move-mark msg-mark temp)))))
564
565
566 (defcommand "Show Message" (p)
567 "Shows the current message.
568 Prompts for a folder and message(s), displaying this in the current window.
569 When invoked in a headers buffer, shows the message on the current line."
570 "Show a message."
571 (declare (ignore p))
572 (let ((hinfo (value headers-information)))
573 (if hinfo
574 (show-headers-message hinfo)
575 (let ((folder (prompt-for-folder)))
576 (show-prompted-message folder (prompt-for-message :folder folder))))))
577
578 ;;; SHOW-HEADERS-MESSAGE shows the current message for hinfo. If there is a
579 ;;; main message buffer, clobber it, and we don't have to deal with kept
580 ;;; messages or draft associations since those operations should have moved
581 ;;; the message buffer into the others list. Remove the message from the
582 ;;; unseen sequence, and make sure the message buffer is displayed in some
583 ;;; window.
584 ;;;
585 (defun show-headers-message (hinfo)
586 (multiple-value-bind (cur-msg cur-mark)
587 (headers-current-message hinfo)
588 (unless cur-msg (editor-error "Not on a header line."))
589 (let* ((mbuffer (headers-info-msg-buffer hinfo))
590 (folder (headers-info-folder hinfo))
591 (buf-name (get-storable-msg-buf-name folder cur-msg))
592 (writable nil))
593 (cond (mbuffer
594 (setf (buffer-name mbuffer) buf-name)
595 (setf writable (buffer-writable mbuffer))
596 (setf (buffer-writable mbuffer) t)
597 (delete-region (buffer-region mbuffer))
598 (let ((minfo (variable-value 'message-information :buffer mbuffer)))
599 (move-mark (message-info-headers-mark minfo) cur-mark)
600 (delete-mark cur-mark)
601 (setf (message-info-msgs minfo) cur-msg)))
602 (t (setf mbuffer (maybe-make-mh-buffer buf-name :message))
603 (setf (headers-info-msg-buffer hinfo) mbuffer)
604 (defhvar "Message Information"
605 "This holds the information about the current headers buffer."
606 :value (make-message-info :folder folder
607 :msgs cur-msg
608 :headers-mark cur-mark)
609 :buffer mbuffer)
610 (defhvar "Headers Buffer"
611 "This is bound in message and draft buffers to their
612 associated headers buffer."
613 :value (headers-info-buffer hinfo) :buffer mbuffer)))
614 (read-mh-file (merge-pathnames
615 cur-msg
616 (merge-relative-pathnames (strip-folder-name folder)
617 (mh-directory-pathname)))
618 mbuffer)
619 (setf (buffer-writable mbuffer) writable)
620 (let ((unseen-seq (mh-profile-component "unseen-sequence")))
621 (when unseen-seq (mark-one-message folder cur-msg unseen-seq :delete)))
622 (get-message-buffer-window mbuffer))))
623
624 ;;; SHOW-PROMPTED-MESSAGE takes an arbitrary message spec and blasts those
625 ;;; messages into a message buffer. First we pick the message to get them
626 ;;; individually specified as normalized message ID's -- all integers and
627 ;;; no funny names such as "last".
628 ;;;
629 (defun show-prompted-message (folder msgs)
630 (let* ((msgs (pick-messages folder msgs nil))
631 (mbuffer (maybe-make-mh-buffer (format nil "Message ~A ~A" folder msgs)
632 :message)))
633 (defhvar "Message Information"
634 "This holds the information about the current headers buffer."
635 :value (make-message-info :folder folder :msgs msgs)
636 :buffer mbuffer)
637 (let ((*standard-output* (make-hemlock-output-stream (buffer-point mbuffer)
638 :full)))
639 (mh "show" `(,folder ,@msgs "-noshowproc" "-noheader"))
640 (setf (buffer-modified mbuffer) nil))
641 (buffer-start (buffer-point mbuffer))
642 (setf (buffer-writable mbuffer) nil)
643 (get-message-buffer-window mbuffer)))
644
645 ;;; GET-MESSAGE-BUFFER-WINDOW currently just changes to buffer, unless buffer
646 ;;; has any windows, in which case it uses the first one. It could prompt for
647 ;;; a window, split the current window, split the current window or use the
648 ;;; next one if there is one, funcall an Hvar. It could take a couple
649 ;;; arguments to control its behaviour. Whatever.
650 ;;;
651 (defun get-message-buffer-window (mbuffer)
652 (let ((wins (buffer-windows mbuffer)))
653 (cond (wins
654 (setf (current-buffer) mbuffer)
655 (setf (current-window) (car wins)))
656 (t (change-to-buffer mbuffer)))))
657
658
659 (defhvar "Scroll Message Showing Next"
660 "When this is set, \"Scroll Message\" shows the next message when the end
661 of the current message is visible."
662 :value t)
663
664 (defcommand "Scroll Message" (p)
665 "Scroll the current window down through the current message.
666 If the end of the message is visible, then show the next undeleted message
667 if \"Scroll Message Showing Next\" is non-nil."
668 "Scroll the current window down through the current message."
669 (if (and (not p)
670 (displayed-p (buffer-end-mark (current-buffer)) (current-window))
671 (value scroll-message-showing-next))
672 (show-message-offset 1 :undeleted)
673 (scroll-window-down-command p)))
674
675
676 (defcommand "Keep Message" (p)
677 "Keeps the current message buffer from being re-used. Also, if the buffer
678 would be deleted due to a draft completion, it will not be."
679 "Keeps the current message buffer from being re-used. Also, if the buffer
680 would be deleted due to a draft completion, it will not be."
681 (declare (ignore p))
682 (let ((minfo (value message-information)))
683 (unless minfo (editor-error "Not in a message buffer."))
684 (let ((hbuf (value headers-buffer)))
685 (when hbuf
686 (let ((mbuf (current-buffer))
687 (hinfo (variable-value 'headers-information :buffer hbuf)))
688 (when (eq (headers-info-msg-buffer hinfo) mbuf)
689 (setf (headers-info-msg-buffer hinfo) nil)
690 (push mbuf (headers-info-other-msg-bufs hinfo))))))
691 (setf (message-info-keep minfo) t)))
692
693 (defcommand "Edit Message Buffer" (p)
694 "Recursively edit message buffer.
695 Puts the current message buffer into \"Text\" mode allowing modifications in
696 a recursive edit. While in this state, the buffer is associated with the
697 pathname of the message, so saving the file is possible."
698 "Puts the current message buffer into \"Text\" mode allowing modifications in
699 a recursive edit. While in this state, the buffer is associated with the
700 pathname of the message, so saving the file is possible."
701 (declare (ignore p))
702 (let* ((minfo (value message-information)))
703 (unless minfo (editor-error "Not in a message buffer."))
704 (let* ((msgs (message-info-msgs minfo))
705 (mbuf (current-buffer))
706 (mbuf-name (buffer-name mbuf))
707 (writable (buffer-writable mbuf))
708 (abortp t))
709 (when (consp msgs)
710 (editor-error
711 "There appears to be more than one message in this buffer."))
712 (unwind-protect
713 (progn
714 (setf (buffer-writable mbuf) t)
715 (setf (buffer-pathname mbuf)
716 (merge-pathnames
717 msgs
718 (merge-relative-pathnames
719 (strip-folder-name (message-info-folder minfo))
720 (mh-directory-pathname))))
721 (setf (buffer-major-mode mbuf) "Text")
722 (do-recursive-edit)
723 (setf abortp nil))
724 (when (and (not abortp)
725 (buffer-modified mbuf)
726 (prompt-for-y-or-n
727 :prompt "Message buffer modified, save it? "
728 :default t))
729 (save-file-command nil mbuf))
730 (setf (buffer-modified mbuf) nil)
731 ;; "Save File", which the user may have used, changes the buffer's name.
732 (unless (getstring mbuf-name *buffer-names*)
733 (setf (buffer-name mbuf) mbuf-name))
734 (setf (buffer-writable mbuf) writable)
735 (setf (buffer-pathname mbuf) nil)
736 (setf (buffer-major-mode mbuf) "Message")))))
737
738
739
740 ;;;; Draft Mode.
741
742 (defmode "Draft")
743
744 (defhvar "Draft Information"
745 "This holds the information about the current draft buffer."
746 :value nil)
747
748 (defstruct (draft-info (:include message/draft-info)
749 (:print-function print-draft-info))
750 folder ;String name of draft folder with leading MH "+".
751 message ;String id of draft folder message.
752 pathname ;Pathname of draft in the draft folder directory.
753 delivered ;This is set when the draft was really sent.
754 replied-to-folder ;Folder of message draft is in reply to.
755 replied-to-msg) ;Message draft is in reply to.
756
757 (defun print-draft-info (obj str n)
758 (declare (ignore n))
759 (format str "#<Draft Info ~A>" (draft-info-message obj)))
760
761
762 (defhvar "Reply to Message Prefix Action"
763 "This is one of :cc-all, :no-cc-all, or nil. When an argument is supplied to
764 \"Reply to Message\", this value determines how arguments passed to the
765 MH utility."
766 :value nil)
767
768 (defcommand "Reply to Message" (p)
769 "Sets up a draft in reply to the current message.
770 Prompts for a folder and message to reply to. When in a headers buffer,
771 replies to the message on the current line. When in a message buffer,
772 replies to that message. With an argument, regard \"Reply to Message Prefix
773 Action\" for carbon copy arguments to the MH utility."
774 "Prompts for a folder and message to reply to. When in a headers buffer,
775 replies to the message on the current line. When in a message buffer,
776 replies to that message."
777 (let ((hinfo (value headers-information))
778 (minfo (value message-information)))
779 (cond (hinfo
780 (multiple-value-bind (cur-msg cur-mark)
781 (headers-current-message hinfo)
782 (unless cur-msg (editor-error "Not on a header line."))
783 (setup-reply-draft (headers-info-folder hinfo)
784 cur-msg hinfo cur-mark p)))
785 (minfo
786 (setup-message-buffer-draft (current-buffer) minfo :reply p))
787 (t
788 (let ((folder (prompt-for-folder)))
789 (setup-reply-draft folder
790 (car (prompt-for-message :folder folder))
791 nil nil p))))))
792
793 ;;; SETUP-REPLY-DRAFT takes a folder and msg to draft a reply to. Optionally,
794 ;;; a headers buffer and mark are associated with the draft. First, the draft
795 ;;; buffer is associated with the headers buffer if there is one. Then the
796 ;;; message buffer is created and associated with the drafter buffer and
797 ;;; headers buffer. Argument may be used to pass in the argument from the
798 ;;; command.
799 ;;;
800 (defun setup-reply-draft (folder msg &optional hinfo hmark argument)
801 (let* ((dbuffer (sub-setup-message-draft
802 "repl" :end-of-buffer
803 `(,folder ,msg
804 ,@(if argument
805 (case (value reply-to-message-prefix-action)
806 (:no-cc-all '("-nocc" "all"))
807 (:cc-all '("-cc" "all")))))))
808 (dinfo (variable-value 'draft-information :buffer dbuffer))
809 (h-buf (if hinfo (headers-info-buffer hinfo))))
810 (setf (draft-info-replied-to-folder dinfo) folder)
811 (setf (draft-info-replied-to-msg dinfo) msg)
812 (when h-buf
813 (defhvar "Headers Buffer"
814 "This is bound in message and draft buffers to their associated
815 headers buffer."
816 :value h-buf :buffer dbuffer)
817 (setf (draft-info-headers-mark dinfo) hmark)
818 (push dbuffer (headers-info-draft-bufs hinfo)))
819 (let ((msg-buf (maybe-make-mh-buffer (format nil "Message ~A ~A" folder msg)
820 :message)))
821 (defhvar "Message Information"
822 "This holds the information about the current headers buffer."
823 :value (make-message-info :folder folder :msgs msg
824 :headers-mark
825 (if h-buf (copy-mark hmark) hmark)
826 :draft-buf dbuffer)
827 :buffer msg-buf)
828 (when h-buf
829 (defhvar "Headers Buffer"
830 "This is bound in message and draft buffers to their associated
831 headers buffer."
832 :value h-buf :buffer msg-buf)
833 (push msg-buf (headers-info-other-msg-bufs hinfo)))
834 (read-mh-file (merge-pathnames
835 msg
836 (merge-relative-pathnames (strip-folder-name folder)
837 (mh-directory-pathname)))
838 msg-buf)
839 (setf (buffer-writable msg-buf) nil)
840 (defhvar "Message Buffer"
841 "This is bound in draft buffers to their associated message buffer."
842 :value msg-buf :buffer dbuffer))
843 (get-draft-buffer-window dbuffer)))
844
845
846 (defcommand "Forward Message" (p)
847 "Forward current message.
848 Prompts for a folder and message to forward. When in a headers buffer,
849 forwards the message on the current line. When in a message buffer,
850 forwards that message."
851 "Prompts for a folder and message to reply to. When in a headers buffer,
852 replies to the message on the current line. When in a message buffer,
853 replies to that message."
854 (declare (ignore p))
855 (let ((hinfo (value headers-information))
856 (minfo (value message-information)))
857 (cond (hinfo
858 (multiple-value-bind (cur-msg cur-mark)
859 (headers-current-message hinfo)
860 (unless cur-msg (editor-error "Not on a header line."))
861 (setup-forward-draft (headers-info-folder hinfo)
862 cur-msg hinfo cur-mark)))
863 (minfo
864 (setup-message-buffer-draft (current-buffer) minfo :forward))
865 (t
866 (let ((folder (prompt-for-folder)))
867 (setup-forward-draft folder
868 (car (prompt-for-message :folder folder))))))))
869
870 ;;; SETUP-FORWARD-DRAFT sets up a draft forwarding folder's msg. When there
871 ;;; is a headers buffer involved (hinfo and hmark), the draft is associated
872 ;;; with it.
873 ;;;
874 ;;; This function is like SETUP-REPLY-DRAFT (in addition to "forw" and
875 ;;; :to-field), but it does not setup a message buffer. If this is added as
876 ;;; something forward drafts want, then SETUP-REPLY-DRAFT should be
877 ;;; parameterized and renamed.
878 ;;;
879 (defun setup-forward-draft (folder msg &optional hinfo hmark)
880 (let* ((dbuffer (sub-setup-message-draft "forw" :to-field
881 (list folder msg)))
882 (dinfo (variable-value 'draft-information :buffer dbuffer))
883 (h-buf (if hinfo (headers-info-buffer hinfo))))
884 (when h-buf
885 (defhvar "Headers Buffer"
886 "This is bound in message and draft buffers to their associated
887 headers buffer."
888 :value h-buf :buffer dbuffer)
889 (setf (draft-info-headers-mark dinfo) hmark)
890 (push dbuffer (headers-info-draft-bufs hinfo)))
891 (get-draft-buffer-window dbuffer)))
892
893
894 (defcommand "Send Message" (p)
895 "Setup a draft buffer.
896 Setup a draft buffer, reserving a draft folder message. When invoked in a
897 headers buffer, the current message is available in an associated message
898 buffer."
899 "Setup a draft buffer, reserving a draft folder message. When invoked in
900 a headers buffer, the current message is available in an associated
901 message buffer."
902 (declare (ignore p))
903 (let ((hinfo (value headers-information))
904 (minfo (value message-information)))
905 (cond (hinfo (setup-headers-message-draft hinfo))
906 (minfo (setup-message-buffer-draft (current-buffer) minfo :compose))
907 (t (setup-message-draft)))))
908
909 (defun setup-message-draft ()
910 (get-draft-buffer-window (sub-setup-message-draft "comp" :to-field)))
911
912 ;;; SETUP-HEADERS-MESSAGE-DRAFT sets up a draft buffer associated with a
913 ;;; headers buffer and a message buffer. The headers current message is
914 ;;; inserted in the message buffer which is also associated with the headers
915 ;;; buffer. The draft buffer is associated with the message buffer.
916 ;;;
917 (defun setup-headers-message-draft (hinfo)
918 (multiple-value-bind (cur-msg cur-mark)
919 (headers-current-message hinfo)
920 (unless cur-msg (message "Draft not associated with any message."))
921 (let* ((dbuffer (sub-setup-message-draft "comp" :to-field))
922 (dinfo (variable-value 'draft-information :buffer dbuffer))
923 (h-buf (headers-info-buffer hinfo)))
924 (when cur-msg
925 (defhvar "Headers Buffer"
926 "This is bound in message and draft buffers to their associated headers
927 buffer."
928 :value h-buf :buffer dbuffer)
929 (push dbuffer (headers-info-draft-bufs hinfo)))
930 (when cur-msg
931 (setf (draft-info-headers-mark dinfo) cur-mark)
932 (let* ((folder (headers-info-folder hinfo))
933 (msg-buf (maybe-make-mh-buffer
934 (format nil "Message ~A ~A" folder cur-msg)
935 :message)))
936 (defhvar "Message Information"
937 "This holds the information about the current headers buffer."
938 :value (make-message-info :folder folder :msgs cur-msg
939 :headers-mark (copy-mark cur-mark)
940 :draft-buf dbuffer)
941 :buffer msg-buf)
942 (defhvar "Headers Buffer"
943 "This is bound in message and draft buffers to their associated
944 headers buffer."
945 :value h-buf :buffer msg-buf)
946 (push msg-buf (headers-info-other-msg-bufs hinfo))
947 (read-mh-file (merge-pathnames
948 cur-msg
949 (merge-relative-pathnames (strip-folder-name folder)
950 (mh-directory-pathname)))
951 msg-buf)
952 (setf (buffer-writable msg-buf) nil)
953 (defhvar "Message Buffer"
954 "This is bound in draft buffers to their associated message buffer."
955 :value msg-buf :buffer dbuffer)))
956 (get-draft-buffer-window dbuffer))))
957
958 ;;; SETUP-MESSAGE-BUFFER-DRAFT takes a message buffer and its message
959 ;;; information. A draft buffer is created according to type, and the two
960 ;;; buffers are associated. Any previous association of the message buffer and
961 ;;; a draft buffer is dropped. Any association between the message buffer and
962 ;;; a headers buffer is propagated to the draft buffer, and if the message
963 ;;; buffer is the headers buffer's main message buffer, it is moved to "other"
964 ;;; status. Argument may be used to pass in the argument from the command.
965 ;;;
966 (defun setup-message-buffer-draft (msg-buf minfo type &optional argument)
967 (let* ((msgs (message-info-msgs minfo))
968 (cur-msg (if (consp msgs) (car msgs) msgs))
969 (folder (message-info-folder minfo))
970 (dbuffer
971 (ecase type
972 (:reply
973 (sub-setup-message-draft
974 "repl" :end-of-buffer
975 `(,folder ,cur-msg
976 ,@(if argument
977 (case (value reply-to-message-prefix-action)
978 (:no-cc-all '("-nocc" "all"))
979 (:cc-all '("-cc" "all")))))))
980 (:compose
981 (sub-setup-message-draft "comp" :to-field))
982 (:forward
983 (sub-setup-message-draft "forw" :to-field
984 (list folder cur-msg)))))
985 (dinfo (variable-value 'draft-information :buffer dbuffer)))
986 (when (message-info-draft-buf minfo)
987 (delete-variable 'message-buffer :buffer (message-info-draft-buf minfo)))
988 (setf (message-info-draft-buf minfo) dbuffer)
989 (when (eq type :reply)
990 (setf (draft-info-replied-to-folder dinfo) folder)
991 (setf (draft-info-replied-to-msg dinfo) cur-msg))
992 (when (hemlock-bound-p 'headers-buffer :buffer msg-buf)
993 (let* ((hbuf (variable-value 'headers-buffer :buffer msg-buf))
994 (hinfo (variable-value 'headers-information :buffer hbuf)))
995 (defhvar "Headers Buffer"
996 "This is bound in message and draft buffers to their associated
997 headers buffer."
998 :value hbuf :buffer dbuffer)
999 (setf (draft-info-headers-mark dinfo)
1000 (copy-mark (message-info-headers-mark minfo)))
1001 (push dbuffer (headers-info-draft-bufs hinfo))
1002 (when (eq (headers-info-msg-buffer hinfo) msg-buf)
1003 (setf (headers-info-msg-buffer hinfo) nil)
1004 (push msg-buf (headers-info-other-msg-bufs hinfo)))))
1005 (defhvar "Message Buffer"
1006 "This is bound in draft buffers to their associated message buffer."
1007 :value msg-buf :buffer dbuffer)
1008 (get-draft-buffer-window dbuffer)))
1009
1010 (defvar *draft-to-pattern*
1011 (new-search-pattern :string-insensitive :forward "To:"))
1012
1013 (defun sub-setup-message-draft (utility point-action &optional args)
1014 (mh utility `(,@args "-nowhatnowproc"))
1015 (let* ((folder (mh-draft-folder))
1016 (draft-msg (mh-current-message folder))
1017 (msg-pn (merge-pathnames draft-msg (mh-draft-folder-pathname)))
1018 (dbuffer (maybe-make-mh-buffer (format nil "Draft ~A" draft-msg)
1019 :draft)))
1020 (read-mh-file msg-pn dbuffer)
1021 (setf (buffer-pathname dbuffer) msg-pn)
1022 (defhvar "Draft Information"
1023 "This holds the information about the current draft buffer."
1024 :value (make-draft-info :folder (coerce-folder-name folder)
1025 :message draft-msg
1026 :pathname msg-pn)
1027 :buffer dbuffer)
1028 (let ((point (buffer-point dbuffer)))
1029 (ecase point-action
1030 (:to-field
1031 (when (find-pattern point *draft-to-pattern*)
1032 (line-end point)))
1033 (:end-of-buffer (buffer-end point))))
1034 dbuffer))
1035
1036 (defun read-mh-file (pathname buffer)
1037 (unless (probe-file pathname)
1038 (editor-error "No such message -- ~A" (namestring pathname)))
1039 (read-file pathname (buffer-point buffer))
1040 (setf (buffer-write-date buffer) (file-write-date pathname))
1041 (buffer-start (buffer-point buffer))
1042 (setf (buffer-modified buffer) nil))
1043
1044
1045 (defvar *draft-buffer-window-fun* 'change-to-buffer
1046 "This is called by GET-DRAFT-BUFFER-WINDOW to display a new draft buffer.
1047 The default is CHANGE-TO-BUFFER which uses the current window.")
1048
1049 ;;; GET-DRAFT-BUFFER-WINDOW is called to display a new draft buffer.
1050 ;;;
1051 (defun get-draft-buffer-window (dbuffer)
1052 (funcall *draft-buffer-window-fun* dbuffer))
1053
1054
1055 (defcommand "Reply to Message in Other Window" (p)
1056 "Reply to message, creating another window for draft buffer.
1057 Prompts for a folder and message to reply to. When in a headers buffer,
1058 replies to the message on the current line. When in a message buffer,
1059 replies to that message. The current window is split displaying the draft
1060 buffer in the new window and the message buffer in the current."
1061 "Prompts for a folder and message to reply to. When in a headers buffer,
1062 replies to the message on the current line. When in a message buffer,
1063 replies to that message."
1064 (let ((*draft-buffer-window-fun* #'draft-buffer-in-other-window))
1065 (reply-to-message-command p)))
1066
1067 (defun draft-buffer-in-other-window (dbuffer)
1068 (when (hemlock-bound-p 'message-buffer :buffer dbuffer)
1069 (let ((mbuf (variable-value 'message-buffer :buffer dbuffer)))
1070 (when (not (eq (current-buffer) mbuf))
1071 (change-to-buffer mbuf))))
1072 (setf (current-buffer) dbuffer)
1073 (setf (current-window) (make-window (buffer-start-mark dbuffer)))
1074 (defhvar "Split Window Draft"
1075 "Indicates window needs to be cleaned up for draft."
1076 :value t :buffer dbuffer))
1077
1078 (defhvar "Deliver Message Confirm"
1079 "When set, \"Deliver Message\" will ask for confirmation before sending the
1080 draft. This is off by default since \"Deliver Message\" is not bound to
1081 any key by default."
1082 :value t)
1083
1084 (defcommand "Deliver Message" (p)
1085 "Save and deliver the current draft buffer.
1086 When in a draft buffer, this saves the file and uses SEND to deliver the
1087 draft. Otherwise, this prompts for a draft message id, invoking SEND."
1088 "When in a draft buffer, this saves the file and uses SEND to deliver the
1089 draft. Otherwise, this prompts for a draft message id, invoking SEND."
1090 (declare (ignore p))
1091 (let ((dinfo (value draft-information)))
1092 (cond (dinfo
1093 (deliver-draft-buffer-message dinfo))
1094 (t
1095 (let* ((folder (coerce-folder-name (mh-draft-folder)))
1096 (msg (prompt-for-message :folder folder)))
1097 (mh "send" `("-draftfolder" ,folder "-draftmessage" ,@msg)))))))
1098
1099 (defun deliver-draft-buffer-message (dinfo)
1100 (when (draft-info-delivered dinfo)
1101 (editor-error "This draft has already been delivered."))
1102 (when (or (not (value deliver-message-confirm))
1103 (prompt-for-y-or-n :prompt "Deliver message? " :default t))
1104 (let ((dbuffer (current-buffer)))
1105 (when (buffer-modified dbuffer)
1106 (write-buffer-file dbuffer (buffer-pathname dbuffer)))
1107 (message "Delivering draft ...")
1108 (mh "send" `("-draftfolder" ,(draft-info-folder dinfo)
1109 "-draftmessage" ,(draft-info-message dinfo)))
1110 (setf (draft-info-delivered dinfo) t)
1111 (let ((replied-folder (draft-info-replied-to-folder dinfo))
1112 (replied-msg (draft-info-replied-to-msg dinfo)))
1113 (when replied-folder
1114 (message "Annotating message being replied to ...")
1115 (mh "anno" `(,replied-folder ,replied-msg "-component" "replied"))
1116 (do-headers-buffers (hbuf replied-folder)
1117 (with-headers-mark (hmark hbuf replied-msg)
1118 (mark-to-note-replied-msg hmark)
1119 (with-writable-buffer (hbuf)
1120 (setf (next-character hmark) #\A))))
1121 (dolist (b *buffer-list*)
1122 (when (and (hemlock-bound-p 'message-information :buffer b)
1123 (buffer-modeline-field-p b :replied-to-message))
1124 (dolist (w (buffer-windows b))
1125 (update-modeline-field b w :replied-to-message))))))
1126 (maybe-delete-extra-draft-window dbuffer (current-window))
1127 (let* ((mbuf (value message-buffer))
1128 (minfo (if mbuf
1129 (variable-value 'message-information :buffer mbuf))))
1130 (when (and minfo (not (message-info-keep minfo)))
1131 (delete-buffer-if-possible mbuf)))
1132 (delete-buffer-if-possible dbuffer))))
1133
1134 (defcommand "Delete Draft and Buffer" (p)
1135 "Delete the current draft message and buffer."
1136 "Delete the current draft message and buffer."
1137 (declare (ignore p))
1138 (let ((dinfo (value draft-information))
1139 (dbuffer (current-buffer)))
1140 (unless dinfo (editor-error "No draft associated with buffer."))
1141 (maybe-delete-extra-draft-window dbuffer (current-window))
1142 (delete-file (draft-info-pathname dinfo))
1143 (let* ((mbuf (value message-buffer))
1144 (minfo (if mbuf
1145 (variable-value 'message-information :buffer mbuf))))
1146 (when (and minfo (not (message-info-keep minfo)))
1147 (delete-buffer-if-possible mbuf)))
1148 (delete-buffer-if-possible dbuffer)))
1149
1150 ;;; MAYBE-DELETE-EXTRA-DRAFT-WINDOW takes a draft buffer and a window into it
1151 ;;; that should not be deleted. If "Split Window Draft" is bound in the buffer,
1152 ;;; and there are more than two windows (two windows plus the echo area at
1153 ;;; least), then we delete some window if it is not the dbuffer-window or the
1154 ;;; echo area window. Blow away the variable, so we don't think this is still
1155 ;;; a split window draft buffer.
1156 ;;;
1157 (defun maybe-delete-extra-draft-window (dbuffer dbuffer-window)
1158 (when (and (hemlock-bound-p 'split-window-draft :buffer dbuffer)
1159 (> (length (the list *window-list*)) 2))
1160 (delete-window
1161 (find-if #'(lambda (w)
1162 (not (or (eq w dbuffer-window)
1163 (eq w *echo-area-window*))))
1164 *window-list*))
1165 (delete-variable 'split-window-draft :buffer dbuffer)))
1166
1167
1168 (defcommand "Remail Message" (p)
1169 "Prompts for a folder and message to remail. Prompts for a resend-to
1170 address string and resend-cc address string. When in a headers buffer,
1171 remails the message on the current line. When in a message buffer,
1172 remails that message."
1173 "Prompts for a folder and message to remail. Prompts for a resend-to
1174 address string and resend-cc address string. When in a headers buffer,
1175 remails the message on the current line. When in a message buffer,
1176 remails that message."
1177 (declare (ignore p))
1178 (let ((hinfo (value headers-information))
1179 (minfo (value message-information)))
1180 (cond (hinfo
1181 (multiple-value-bind (cur-msg cur-mark)
1182 (headers-current-message hinfo)
1183 (unless cur-msg (editor-error "Not on a header line."))
1184 (delete-mark cur-mark)
1185 (remail-message (headers-info-folder hinfo) cur-msg
1186 (prompt-for-string :prompt "Resend To: ")
1187 (prompt-for-string :prompt "Resend Cc: "))))
1188 (minfo
1189 (remail-message (message-info-folder minfo)
1190 (message-info-msgs minfo)
1191 (prompt-for-string :prompt "Resend To: ")
1192 (prompt-for-string :prompt "Resend Cc: ")))
1193 (t
1194 (let ((folder (prompt-for-folder)))
1195 (remail-message folder
1196 (car (prompt-for-message :folder folder))
1197 (prompt-for-string :prompt "Resend To: ")
1198 (prompt-for-string :prompt "Resend Cc: "))))))
1199 (message "Message remailed."))
1200
1201
1202 ;;; REMAIL-MESSAGE claims a draft folder message with "dist". This is then
1203 ;;; sucked into a buffer and modified by inserting the supplied addresses.
1204 ;;; "send" is used to deliver the draft, but it requires certain evironment
1205 ;;; variables to make it do the right thing. "mhdist" says the draft is only
1206 ;;; remailing information, and "mhaltmsg" is the message to send. "mhannotate"
1207 ;;; must be set due to a bug in MH's "send"; it will not notice the "mhdist"
1208 ;;; flag unless there is some message to be annotated. This command does not
1209 ;;; provide for annotation of the remailed message.
1210 ;;;
1211 (defun remail-message (folder msg resend-to resend-cc)
1212 (mh "dist" `(,folder ,msg "-nowhatnowproc"))
1213 (let* ((draft-folder (mh-draft-folder))
1214 (draft-msg (mh-current-message draft-folder)))
1215 (setup-remail-draft-message draft-msg resend-to resend-cc)
1216 (mh "send" `("-draftfolder" ,draft-folder "-draftmessage" ,draft-msg)
1217 :environment
1218 `((:|mhdist| . "1")
1219 (:|mhannotate| . "1")
1220 (:|mhaltmsg| . ,(namestring
1221 (merge-pathnames msg (merge-relative-pathnames
1222 (strip-folder-name folder)
1223 (mh-directory-pathname)))))))))
1224
1225 ;;; SETUP-REMAIL-DRAFT-MESSAGE takes a draft folder and message that have been
1226 ;;; created with the MH "dist" utility. A buffer is created with this
1227 ;;; message's pathname, searching for "resent-to:" and "resent-cc:", filling in
1228 ;;; the supplied argument values. After writing out the results, the buffer
1229 ;;; is deleted.
1230 ;;;
1231 (defvar *draft-resent-to-pattern*
1232 (new-search-pattern :string-insensitive :forward "resent-to:"))
1233 (defvar *draft-resent-cc-pattern*
1234 (new-search-pattern :string-insensitive :forward "resent-cc:"))
1235
1236 (defun setup-remail-draft-message (msg resend-to resend-cc)
1237 (let* ((msg-pn (merge-pathnames msg (mh-draft-folder-pathname)))
1238 (dbuffer (maybe-make-mh-buffer (format nil "Draft ~A" msg)
1239 :draft))
1240 (point (buffer-point dbuffer)))
1241 (read-mh-file msg-pn dbuffer)
1242 (when (find-pattern point *draft-resent-to-pattern*)
1243 (line-end point)
1244 (insert-string point resend-to))
1245 (buffer-start point)
1246 (when (find-pattern point *draft-resent-cc-pattern*)
1247 (line-end point)
1248 (insert-string point resend-cc))
1249 (write-file (buffer-region dbuffer) msg-pn :keep-backup nil)
1250 ;; The draft buffer delete hook expects this to be bound.
1251 (defhvar "Draft Information"
1252 "This holds the information about the current draft buffer."
1253 :value :ignore
1254 :buffer dbuffer)
1255 (delete-buffer dbuffer)))
1256
1257
1258
1259 ;;;; Message and Draft Stuff.
1260
1261 (defhvar "Headers Buffer"
1262 "This is bound in message and draft buffers to their associated headers
1263 buffer."
1264 :value nil)
1265
1266 (defcommand "Goto Headers Buffer" (p)
1267 "Selects associated headers buffer if it exists.
1268 The headers buffer's point is moved to the appropriate line, pushing a
1269 buffer mark where point was."
1270 "Selects associated headers buffer if it exists."
1271 (declare (ignore p))
1272 (let ((h-buf (value headers-buffer)))
1273 (unless h-buf (editor-error "No associated headers buffer."))
1274 (let ((info (or (value message-information) (value draft-information))))
1275 (change-to-buffer h-buf)
1276 (push-buffer-mark (copy-mark (current-point)))
1277 (move-mark (current-point) (message/draft-info-headers-mark info)))))
1278
1279 (defhvar "Message Buffer"
1280 "This is bound in draft buffers to their associated message buffer."
1281 :value nil)
1282
1283 (defcommand "Goto Message Buffer" (p)
1284 "Selects associated message buffer if it exists."
1285 "Selects associated message buffer if it exists."
1286 (declare (ignore p))
1287 (let ((msg-buf (value message-buffer)))
1288 (unless msg-buf (editor-error "No associated message buffer."))
1289 (change-to-buffer msg-buf)))
1290
1291
1292 (defhvar "Message Insertion Prefix"
1293 "This is a fill prefix that is used when inserting text from a message buffer
1294 into a draft buffer by \"Insert Message Region\". It defaults to three
1295 spaces."
1296 :value " ")
1297
1298 (defhvar "Message Insertion Column"
1299 "This is a fill column that is used when inserting text from a message buffer
1300 into a draft buffer by \"Insert Message Region\"."
1301 :value 75)
1302
1303 (defcommand "Insert Message Region" (p)
1304 "Copy the current region into the associated draft buffer.
1305 When in a message buffer that has an associated draft buffer, the current
1306 active region is copied into the draft buffer. It is filled using \"Message
1307 Insertion Prefix\" and \"Message Insertion Column\". If an argument is
1308 supplied, the filling is inhibited."
1309 "When in a message buffer that has an associated draft buffer, the current
1310 active region is copied into the draft buffer. It is filled using
1311 \"Message Insertion Prefix\" and \"Message Insertion Column\". If an
1312 argument is supplied, the filling is inhibited."
1313 (let ((minfo (value message-information)))
1314 (unless minfo (editor-error "Not in a message buffer."))
1315 (let ((dbuf (message-info-draft-buf minfo)))
1316 (unless dbuf
1317 (editor-error "Message buffer not associated with any draft buffer."))
1318 (let* ((region (copy-region (current-region)))
1319 (dbuf-point (buffer-point dbuf))
1320 (dbuf-mark (copy-mark dbuf-point)))
1321 (if (and (hemlock-bound-p 'split-window-draft :buffer dbuf)
1322 (> (length (the list *window-list*)) 2)
1323 (buffer-windows dbuf))
1324 (setf (current-buffer) dbuf
1325 (current-window) (car (buffer-windows dbuf)))
1326 (change-to-buffer dbuf))
1327 (push-buffer-mark dbuf-mark)
1328 (ninsert-region dbuf-point region)
1329 (unless p
1330 (fill-region-by-paragraphs (region dbuf-mark dbuf-point)
1331 (value message-insertion-prefix)
1332 (value message-insertion-column))))))
1333 (setf (last-command-type) :ephemerally-active))
1334
1335
1336 (defhvar "Message Buffer Insertion Prefix"
1337 "This is a line prefix that is inserted at the beginning of every line in
1338 a message buffer when inserting those lines into a draft buffer with
1339 \"Insert Message Buffer\". It defaults to four spaces."
1340 :value " ")
1341
1342 (defcommand "Insert Message Buffer" (p)
1343 "Insert entire (associated) message buffer into (associated) draft buffer.
1344 When in a draft buffer with an associated message buffer, or when in a
1345 message buffer that has an associated draft buffer, the message buffer is
1346 inserted into the draft buffer. Each inserted line is modified by prefixing
1347 it with \"Message Buffer Insertion Prefix\". If an argument is supplied the
1348 prefixing is inhibited."
1349 "When in a draft buffer with an associated message buffer, or when in a
1350 message buffer that has an associated draft buffer, the message buffer
1351 is inserted into the draft buffer. Each inserted line is modified by
1352 prefixing it with \"Message Buffer Insertion Prefix\". If an argument
1353 is supplied the prefixing is inhibited."
1354 (let ((minfo (value message-information))
1355 (dinfo (value draft-information))
1356 mbuf dbuf)
1357 (cond (minfo
1358 (setf dbuf (message-info-draft-buf minfo))
1359 (unless dbuf
1360 (editor-error
1361 "Message buffer not associated with any draft buffer."))
1362 (setf mbuf (current-buffer))
1363 (change-to-buffer dbuf))
1364 (dinfo
1365 (setf mbuf (value message-buffer))
1366 (unless mbuf
1367 (editor-error
1368 "Draft buffer not associated with any message buffer."))
1369 (setf dbuf (current-buffer)))
1370 (t (editor-error "Not in a draft or message buffer.")))
1371 (let* ((dbuf-point (buffer-point dbuf))
1372 (dbuf-mark (copy-mark dbuf-point)))
1373 (push-buffer-mark dbuf-mark)
1374 (insert-region dbuf-point (buffer-region mbuf))
1375 (unless p
1376 (let ((prefix (value message-buffer-insertion-prefix)))
1377 (with-mark ((temp dbuf-mark :left-inserting))
1378 (loop
1379 (when (mark>= temp dbuf-point) (return))
1380 (insert-string temp prefix)
1381 (unless (line-offset temp 1 0) (return)))))))
1382 (insert-message-buffer-cleanup-split-draft dbuf mbuf))
1383 (setf (last-command-type) :ephemerally-active))
1384
1385 ;;; INSERT-MESSAGE-BUFFER-CLEANUP-SPLIT-DRAFT tries to delete an extra window
1386 ;;; due to "Reply to Message in Other Window". Since we just inserted the
1387 ;;; message buffer in the draft buffer, we don't need the other window into
1388 ;;; the message buffer.
1389 ;;;
1390 (defun insert-message-buffer-cleanup-split-draft (dbuf mbuf)
1391 (when (and (hemlock-bound-p 'split-window-draft :buffer dbuf)
1392 (> (length (the list *window-list*)) 2))
1393 (let ((win (car (buffer-windows mbuf))))
1394 (cond
1395 (win
1396 (when (eq win (current-window))
1397 (let ((dwin (car (buffer-windows dbuf))))
1398 (unless dwin
1399 (editor-error "Couldn't fix windows for split window draft."))
1400 (setf (current-buffer) dbuf)
1401 (setf (current-window) dwin)))
1402 (delete-window win))
1403 (t ;; This happens when invoked with the message buffer current.
1404 (let ((dwins (buffer-windows dbuf)))
1405 (when (> (length (the list dwins)) 1)
1406 (delete-window (find-if #'(lambda (w)
1407 (not (eq w (current-window))))
1408 dwins)))))))
1409 (delete-variable 'split-window-draft :buffer dbuf)))
1410
1411
1412 ;;; CLEANUP-MESSAGE-BUFFER is called when a buffer gets deleted. It cleans
1413 ;;; up references to a message buffer.
1414 ;;;
1415 (defun cleanup-message-buffer (buffer)
1416 (let ((minfo (variable-value 'message-information :buffer buffer)))
1417 (when (hemlock-bound-p 'headers-buffer :buffer buffer)
1418 (let* ((hinfo (variable-value 'headers-information
1419 :buffer (variable-value 'headers-buffer
1420 :buffer buffer)))
1421 (msg-buf (headers-info-msg-buffer hinfo)))
1422 (if (eq msg-buf buffer)
1423 (setf (headers-info-msg-buffer hinfo) nil)
1424 (setf (headers-info-other-msg-bufs hinfo)
1425 (delete buffer (headers-info-other-msg-bufs hinfo)
1426 :test #'eq))))
1427 (delete-mark (message-info-headers-mark minfo))
1428 ;;
1429 ;; Do this for MAYBE-MAKE-MH-BUFFER since it isn't necessary for GC.
1430 (delete-variable 'headers-buffer :buffer buffer))
1431 (when (message-info-draft-buf minfo)
1432 (delete-variable 'message-buffer
1433 :buffer (message-info-draft-buf minfo)))))
1434
1435 ;;; CLEANUP-DRAFT-BUFFER is called when a buffer gets deleted. It cleans
1436 ;;; up references to a draft buffer.
1437 ;;;
1438 (defun cleanup-draft-buffer (buffer)
1439 (let ((dinfo (variable-value 'draft-information :buffer buffer)))
1440 (when (hemlock-bound-p 'headers-buffer :buffer buffer)
1441 (let* ((hinfo (variable-value 'headers-information
1442 :buffer (variable-value 'headers-buffer
1443 :buffer buffer))))
1444 (setf (headers-info-draft-bufs hinfo)
1445 (delete buffer (headers-info-draft-bufs hinfo) :test #'eq))
1446 (delete-mark (draft-info-headers-mark dinfo))))
1447 (when (hemlock-bound-p 'message-buffer :buffer buffer)
1448 (setf (message-info-draft-buf
1449 (variable-value 'message-information
1450 :buffer (variable-value 'message-buffer
1451 :buffer buffer)))
1452 nil))))
1453
1454 ;;; CLEANUP-HEADERS-BUFFER is called when a buffer gets deleted. It cleans
1455 ;;; up references to a headers buffer.
1456 ;;;
1457 (defun cleanup-headers-buffer (buffer)
1458 (let* ((hinfo (variable-value 'headers-information :buffer buffer))
1459 (msg-buf (headers-info-msg-buffer hinfo)))
1460 (when msg-buf
1461 (cleanup-headers-reference
1462 msg-buf (variable-value 'message-information :buffer msg-buf)))
1463 (dolist (b (headers-info-other-msg-bufs hinfo))
1464 (cleanup-headers-reference
1465 b (variable-value 'message-information :buffer b)))
1466 (dolist (b (headers-info-draft-bufs hinfo))
1467 (cleanup-headers-reference
1468 b (variable-value 'draft-information :buffer b)))))
1469
1470 (defun cleanup-headers-reference (buffer info)
1471 (delete-mark (message/draft-info-headers-mark info))
1472 (setf (message/draft-info-headers-mark info) nil)
1473 (delete-variable 'headers-buffer :buffer buffer)
1474 (when (typep info 'draft-info)
1475 (setf (draft-info-replied-to-folder info) nil)
1476 (setf (draft-info-replied-to-msg info) nil)))
1477
1478 ;;; REVAMP-HEADERS-BUFFER cleans up a headers buffer for immediate re-use.
1479 ;;; After deleting the buffer's region, there will be one line in the buffer
1480 ;;; because of how Hemlock regions work, so we have to delete that line's
1481 ;;; plist. Then we clean up any references to the buffer and delete the
1482 ;;; main message buffer. The other message buffers are left alone assuming
1483 ;;; they are on the "others" list because they are being used in some
1484 ;;; particular way (for example, a draft buffer refers to one or the user has
1485 ;;; kept it). Then some slots of the info structure are set to nil.
1486 ;;;
1487 (defun revamp-headers-buffer (hbuffer hinfo)
1488 (delete-region (buffer-region hbuffer))
1489 (setf (line-plist (mark-line (buffer-point hbuffer))) nil)
1490 (let ((msg-buf (headers-info-msg-buffer hinfo)))
1491 ;; Deleting the buffer sets the slot to nil.
1492 (when msg-buf (delete-buffer-if-possible msg-buf))
1493 (cleanup-headers-buffer hbuffer))
1494 (setf (headers-info-other-msg-bufs hinfo) nil)
1495 (setf (headers-info-draft-bufs hinfo) nil)
1496 (setf (headers-info-msg-seq hinfo) nil)
1497 (setf (headers-info-msg-strings hinfo) nil))
1498
1499
1500
1501 ;;;; Incorporating new mail.
1502
1503 (defhvar "New Mail Folder"
1504 "This is the folder new mail is incorporated into."
1505 :value "+inbox")
1506
1507 (defcommand "Incorporate New Mail" (p)
1508 "Incorporates new mail into \"New Mail Folder\", displaying INC output in
1509 a pop-up window."
1510 "Incorporates new mail into \"New Mail Folder\", displaying INC output in
1511 a pop-up window."
1512 (declare (ignore p))
1513 (with-pop-up-display (s)
1514 (incorporate-new-mail s)))
1515
1516 (defhvar "Unseen Headers Message Spec"
1517 "This is an MH message spec suitable any message prompt. It is used to
1518 supply headers for the unseen headers buffer, in addition to the
1519 unseen-sequence name that is taken from the user's MH profile, when
1520 incorporating new mail and after expunging. This value is a string."
1521 :value nil)
1522
1523 (defcommand "Incorporate and Read New Mail" (p)
1524 "Incorporates new mail and generates a headers buffer.
1525 Incorporates new mail into \"New Mail Folder\", and creates a headers buffer
1526 with the new messages. To use this, you must define an unseen- sequence in
1527 your profile. Each time this is invoked the unseen-sequence is SCAN'ed, and
1528 the headers buffer's contents are replaced."
1529 "Incorporates new mail into \"New Mail Folder\", and creates a headers
1530 buffer with the new messages. This buffer will be appended to with
1531 successive uses of this command."
1532 (declare (ignore p))
1533 (let ((unseen-seq (mh-profile-component "unseen-sequence")))
1534 (unless unseen-seq
1535 (editor-error "No unseen-sequence defined in MH profile."))
1536 (incorporate-new-mail)
1537 (let* ((folder (value new-mail-folder))
1538 ;; Stash current message before fetching unseen headers.
1539 (cur-msg (mh-current-message folder))
1540 (region (get-new-mail-msg-hdrs folder unseen-seq)))
1541 ;; Fetch message headers before possibly making buffer in case we error.
1542 (when (not (and *new-mail-buffer*
1543 (member *new-mail-buffer* *buffer-list* :test #'eq)))
1544 (let ((name (format nil "Unseen Headers ~A" folder)))
1545 (when (getstring name *buffer-names*)
1546 (editor-error "There already is a buffer named ~S!" name))
1547 (setf *new-mail-buffer*
1548 (make-buffer name :modes (list "Headers")
1549 :delete-hook '(new-mail-buf-delete-hook)))
1550 (setf (buffer-writable *new-mail-buffer*) nil)))
1551 (cond ((hemlock-bound-p 'headers-information
1552 :buffer *new-mail-buffer*)
1553 (let ((hinfo (variable-value 'headers-information
1554 :buffer *new-mail-buffer*)))
1555 (unless (string= (headers-info-folder hinfo) folder)
1556 (editor-error
1557 "An unseen headers buffer already exists but into another ~
1558 folder. Your mail has already been incorporated into the ~
1559 specified folder."))
1560 (with-writable-buffer (*new-mail-buffer*)
1561 (revamp-headers-buffer *new-mail-buffer* hinfo))
1562 ;; Restore the name in case someone used "Pick Headers".
1563 (setf (buffer-name *new-mail-buffer*)
1564 (format nil "Unseen Headers ~A" folder))
1565 (insert-new-mail-message-headers hinfo region cur-msg)))
1566 (t
1567 (let ((hinfo (make-headers-info :buffer *new-mail-buffer*
1568 :folder folder)))
1569 (defhvar "Headers Information"
1570 "This holds the information about the current headers buffer."
1571 :value hinfo :buffer *new-mail-buffer*)
1572 (insert-new-mail-message-headers hinfo region cur-msg)))))))
1573
1574 ;;; NEW-MAIL-BUF-DELETE-HOOK is invoked whenever the new mail buffer is
1575 ;;; deleted.
1576 ;;;
1577 (defun new-mail-buf-delete-hook (buffer)
1578 (declare (ignore buffer))
1579 (setf *new-mail-buffer* nil))
1580
1581 ;;; GET-NEW-MAIL-MSG-HDRS takes a folder and the unseen-sequence name. It
1582 ;;; returns a region with the unseen message headers and any headers due to
1583 ;;; the "Unseen Headers Message Spec" variable.
1584 ;;;
1585 (defun get-new-mail-msg-hdrs (folder unseen-seq)
1586 (let* ((unseen-headers-message-spec (value unseen-headers-message-spec))
1587 (other-msgs (if unseen-headers-message-spec
1588 (breakup-message-spec
1589 (string-trim '(#\space #\tab)
1590 unseen-headers-message-spec))))
1591 (msg-spec (cond ((null other-msgs)
1592 (list unseen-seq))
1593 ((member unseen-seq other-msgs :test #'string=)
1594 other-msgs)
1595 (t (cons unseen-seq other-msgs)))))
1596 (message-headers-to-region folder msg-spec)))
1597
1598 ;;; INSERT-NEW-MAIL-MESSAGE-HEADERS inserts region in the new mail buffer.
1599 ;;; Then we look for the header line with cur-msg id, moving point there.
1600 ;;; There may have been unseen messages before incorporating new mail, and
1601 ;;; cur-msg should be the first new message. Then we either switch to the
1602 ;;; new mail headers, or show the current message.
1603 ;;;
1604 (defun insert-new-mail-message-headers (hinfo region cur-msg)
1605 (declare (simple-string cur-msg))
1606 (with-writable-buffer (*new-mail-buffer*)
1607 (insert-message-headers *new-mail-buffer* hinfo region))
1608 (let ((point (buffer-point *new-mail-buffer*)))
1609 (buffer-start point)
1610 (with-headers-mark (cur-mark *new-mail-buffer* cur-msg)
1611 (move-mark point cur-mark)))
1612 (change-to-buffer *new-mail-buffer*))
1613
1614
1615 (defhvar "Store Password"
1616 "When this is set, the user is only prompted once for his password."
1617 :value nil)
1618
1619 (defvar *stored-password* nil)
1620
1621 (defun get-password ()
1622 (if (value store-password)
1623 (or *stored-password*
1624 (setf *stored-password* (prompt-for-password)))
1625 (prompt-for-password)))
1626
1627
1628 (defhvar "Authenticate Incorporation"
1629 "When this is set (the default), incorporating new mail prompts for a
1630 password to access a remote mail drop."
1631 :value t)
1632 (defhvar "Authentication User Name"
1633 "When incorporating new mail accesses a remote mail drop, this is the user
1634 name supplied for authentication on the remote machine. If this is nil
1635 it is looked up on the local machine."
1636 :value nil)
1637 #|
1638 (defhvar "Authentication Group Name"
1639 "When incorporating new mail accesses a remote mail drop, this is the group
1640 name supplied for authentication on the remote machine. If this is nil
1641 it is looked up on the local machine."
1642 :value nil)
1643 (defhvar "Authentication Account Name"
1644 "When incorporating new mail accesses a remote mail drop, this is the account
1645 name supplied for authentication on the remote machine. If this is nil
1646 it is looked up on the local machine."
1647 :value nil)
1648 |#
1649
1650 (defhvar "Incorporate New Mail Hook"
1651 "Functions on this hook are invoked immediately after new mail is
1652 incorporated."
1653 :value nil)
1654
1655 (defun incorporate-new-mail (&optional stream)
1656 "Incorporates new mail, passing INC's output to stream. When stream is
1657 nil, output is flushed."
1658 (unless (new-mail-p) (editor-error "No new mail."))
1659 (let ((args `(,(coerce-folder-name (value new-mail-folder))
1660 ,@(if stream nil '("-silent"))
1661 "-form" ,(namestring (value mh-scan-line-form))
1662 "-width" ,(number-string (value fill-column)))))
1663 (cond ((value authenticate-incorporation)
1664 (let ((password (get-password)))
1665 ;; Since we know there is mail due to above check, look for a
1666 ;; possible password failure since MH or the rfs stuff is stupid.
1667 (multiple-value-bind
1668 (winp error-string)
1669 (let ((*standard-output* (or stream *standard-output*)))
1670 (message "Incorporating new mail ...")
1671 (mh "inc" args :errorp nil :password password
1672 :username (value authentication-user-name)))
1673 (declare (type (or simple-string null) error-string))
1674 (unless winp
1675 (when (string= error-string "inc: unable to read" :end1 19)
1676 (setf *stored-password* nil)
1677 (editor-error
1678 "Couldn't read maildrop, possible mistyped password."))
1679 (editor-error "MH Error -- ~A" error-string)))))
1680 (t (message "Incorporating new mail ...")
1681 (mh "inc" args))))
1682 (when (value incorporate-new-mail-hook)
1683 (message "Invoking new mail hooks ..."))
1684 (invoke-hook incorporate-new-mail-hook))
1685
1686
1687
1688 ;;;; Deletion.
1689
1690 (defhvar "Virtual Message Deletion"
1691 "When set, \"Delete Message\" merely MARK's a message into the
1692 \"hemlockdeleted\" sequence; otherwise, RMM is invoked."
1693 :value t)
1694
1695 (defcommand "Delete Message and Show Next" (p)
1696 "Delete message and show next undeleted message.
1697 This command is only valid in a headers buffer or a message buffer
1698 associated with some headers buffer. The current message is deleted, and
1699 the next undeleted one is shown."
1700 "Delete the current message and show the next undeleted one."
1701 (declare (ignore p))
1702 (let ((hinfo (value headers-information))
1703 (minfo (value message-information)))
1704 (cond (hinfo
1705 (multiple-value-bind (cur-msg cur-mark)
1706 (headers-current-message hinfo)
1707 (unless cur-msg (editor-error "Not on a header line."))
1708 (delete-mark cur-mark)
1709 (delete-message (headers-info-folder hinfo) cur-msg)))
1710 (minfo
1711 (delete-message (message-info-folder minfo)
1712 (message-info-msgs minfo)))
1713 (t
1714 (editor-error "Not in a headers or message buffer."))))
1715 (show-message-offset 1 :undeleted))
1716
1717 (defcommand "Delete Message and Down Line" (p)
1718 "Deletes the current message, moving point to the next line.
1719 When in a headers buffer, deletes the message on the current line. Then it
1720 moves point to the next non-blank line."
1721 "Deletes current message and moves point down a line."
1722 (declare (ignore p))
1723 (let ((hinfo (value headers-information)))
1724 (unless hinfo (editor-error "Not in a headers buffer."))
1725 (multiple-value-bind (cur-msg cur-mark)
1726 (headers-current-message hinfo)
1727 (unless cur-msg (editor-error "Not on a header line."))
1728 (delete-message (headers-info-folder hinfo) cur-msg)
1729 (when (line-offset cur-mark 1)
1730 (unless (blank-line-p (mark-line cur-mark))
1731 (move-mark (current-point) cur-mark)))
1732 (delete-mark cur-mark))))
1733
1734 ;;; "Delete Message" unlike "Headers Delete Message" cannot know for sure
1735 ;;; which message id's have been deleted, so when virtual message deletion
1736 ;;; is not used, we cannot use DELETE-HEADERS-BUFFER-LINE to keep headers
1737 ;;; buffers consistent. However, the message id's in the buffer (if deleted)
1738 ;;; will generate MH errors if operations are attempted with them, and
1739 ;;; if the user ever packs the folder with "Expunge Messages", the headers
1740 ;;; buffer will be updated.
1741 ;;;
1742 (defcommand "Delete Message" (p)
1743 "Prompts for a folder, messages to delete, and pick expression. When in
1744 a headers buffer into the same folder specified, the messages prompt
1745 defaults to those messages in the buffer; \"all\" may be entered if this is
1746 not what is desired. When \"Virtual Message Deletion\" is set, messages are
1747 only MARK'ed for deletion. See \"Expunge Messages\". When this feature is
1748 not used, headers and message buffers message id's my not be consistent
1749 with MH."
1750 "Prompts for a folder and message to delete. When \"Virtual Message
1751 Deletion\" is set, messages are only MARK'ed for deletion. See \"Expunge
1752 Messages\"."
1753 (declare (ignore p))
1754 (let* ((folder (prompt-for-folder))
1755 (hinfo (value headers-information))
1756 (temp-msgs (prompt-for-message
1757 :folder folder
1758 :messages
1759 (if (and hinfo
1760 (string= folder
1761 (the simple-string
1762 (headers-info-folder hinfo))))
1763 (headers-info-msg-strings hinfo))
1764 :prompt "MH messages to pick from: "))
1765 (pick-exp (prompt-for-pick-expression))
1766 (msgs (pick-messages folder temp-msgs pick-exp))
1767 (virtually (value virtual-message-deletion)))
1768 (declare (simple-string folder))
1769 (if virtually
1770 (mh "mark" `(,folder ,@msgs "-sequence" "hemlockdeleted" "-add"))
1771 (mh "rmm" `(,folder ,@msgs)))
1772 (if virtually
1773 (let ((deleted-seq (mh-sequence-list folder "hemlockdeleted")))
1774 (when deleted-seq
1775 (do-headers-buffers (hbuf folder)
1776 (with-writable-buffer (hbuf)
1777 (note-deleted-headers hbuf deleted-seq)))))
1778 (do-headers-buffers (hbuf folder hinfo)
1779 (do-headers-lines (hbuf :line-var line :mark-var hmark)
1780 (when (member (line-message-id line) msgs :test #'string=)
1781 (delete-headers-buffer-line hinfo hmark)))))))
1782
1783 (defcommand "Headers Delete Message" (p)
1784 "Delete current message.
1785 When in a headers buffer, deletes the message on the current line. When
1786 in a message buffer, deletes that message. When \"Virtual Message
1787 Deletion\" is set, messages are only MARK'ed for deletion. See \"Expunge
1788 Messages\"."
1789 "When in a headers buffer, deletes the message on the current line. When
1790 in a message buffer, deletes that message. When \"Virtual Message
1791 Deletion\" is set, messages are only MARK'ed for deletion. See \"Expunge
1792 Messages\"."
1793 (declare (ignore p))
1794 (let ((hinfo (value headers-information))
1795 (minfo (value message-information)))
1796 (cond (hinfo
1797 (multiple-value-bind (cur-msg cur-mark)
1798 (headers-current-message hinfo)
1799 (unless cur-msg (editor-error "Not on a header line."))
1800 (delete-mark cur-mark)
1801 (delete-message (headers-info-folder hinfo) cur-msg)))
1802 (minfo
1803 (let ((msgs (message-info-msgs minfo)))
1804 (delete-message (message-info-folder minfo)
1805 (if (consp msgs) (car msgs) msgs)))
1806 (message "Message deleted."))
1807 (t (editor-error "Not in a headers or message buffer.")))))
1808
1809 ;;; DELETE-MESSAGE takes a folder and message id and either flags this message
1810 ;;; for deletion or deletes it. All headers buffers into folder are updated,
1811 ;;; either by flagging a headers line or deleting it.
1812 ;;;
1813 (defun delete-message (folder msg)
1814 (cond ((value virtual-message-deletion)
1815 (mark-one-message folder msg "hemlockdeleted" :add)
1816 (do-headers-buffers (hbuf folder)
1817 (with-headers-mark (hmark hbuf msg)
1818 (with-writable-buffer (hbuf)
1819 (note-deleted-message-at-mark hmark)))))
1820 (t (mh "rmm" (list folder msg))
1821 (do-headers-buffers (hbuf folder hinfo)
1822 (with-headers-mark (hmark hbuf msg)
1823 (delete-headers-buffer-line hinfo hmark)))))
1824 (dolist (b *buffer-list*)
1825 (when (and (hemlock-bound-p 'message-information :buffer b)
1826 (buffer-modeline-field-p b :deleted-message))
1827 (dolist (w (buffer-windows b))
1828 (update-modeline-field b w :deleted-message)))))
1829
1830 ;;; NOTE-DELETED-MESSAGE-AT-MARK takes a mark at the beginning of a valid
1831 ;;; headers line, sticks a "D" on the line, and frobs the line's deleted
1832 ;;; property. This assumes the headers buffer is modifiable.
1833 ;;;
1834 (defun note-deleted-message-at-mark (mark)
1835 (find-attribute mark :digit)
1836 (find-attribute mark :digit #'zerop)
1837 (character-offset mark 2)
1838 (setf (next-character mark) #\D)
1839 (setf (line-message-deleted (mark-line mark)) t))
1840
1841 ;;; DELETE-HEADERS-BUFFER-LINE takes a headers information and a mark on the
1842 ;;; line to be deleted. Before deleting the line, we check to see if any
1843 ;;; message or draft buffers refer to the buffer because of the line. Due
1844 ;;; to how regions are deleted, line plists get messed up, so they have to
1845 ;;; be regenerated. We regenerate them for the whole buffer, so we don't have
1846 ;;; to hack the code to know which lines got messed up.
1847 ;;;
1848 (defun delete-headers-buffer-line (hinfo hmark)
1849 (delete-headers-line-references hinfo hmark)
1850 (let ((id (line-message-id (mark-line hmark)))
1851 (hbuf (headers-info-buffer hinfo)))
1852 (with-writable-buffer (hbuf)
1853 (with-mark ((end (line-start hmark) :left-inserting))
1854 (unless (line-offset end 1 0) (buffer-end end))
1855 (delete-region (region hmark end))))
1856 (let ((seq (mh-sequence-delete id (headers-info-msg-seq hinfo))))
1857 (setf (headers-info-msg-seq hinfo) seq)
1858 (setf (headers-info-msg-strings hinfo) (mh-sequence-strings seq)))
1859 (set-message-headers-ids hbuf)
1860 (when (value virtual-message-deletion)
1861 (let ((deleted-seq (mh-sequence-list (headers-info-folder hinfo)
1862 "hemlockdeleted")))
1863 (do-headers-lines (hbuf :line-var line)
1864 (setf (line-message-deleted line)
1865 (mh-sequence-member-p (line-message-id line) deleted-seq)))))))
1866
1867
1868 ;;; DELETE-HEADERS-LINE-REFERENCES removes any message buffer or draft buffer
1869 ;;; pointers to a headers buffer or marks into the headers buffer. Currently
1870 ;;; message buffers and draft buffers are identified differently for no good
1871 ;;; reason; probably message buffers should be located in the same way draft
1872 ;;; buffers are. Also, we currently assume only one of other-msg-bufs could
1873 ;;; refer to the line (similarly for draft-bufs), but this might be bug
1874 ;;; prone. The message buffer case couldn't happen since the buffer name
1875 ;;; would cause MAYBE-MAKE-MH-BUFFER to re-use the buffer, but you could reply
1876 ;;; to the same message twice simultaneously.
1877 ;;;
1878 (defun delete-headers-line-references (hinfo hmark)
1879 (let ((msg-id (line-message-id (mark-line hmark)))
1880 (main-msg-buf (headers-info-msg-buffer hinfo)))
1881 (declare (simple-string msg-id))
1882 (when main-msg-buf
1883 (let ((minfo (variable-value 'message-information :buffer main-msg-buf)))
1884 (when (string= (the simple-string (message-info-msgs minfo))
1885 msg-id)
1886 (cond ((message-info-draft-buf minfo)
1887 (cleanup-headers-reference main-msg-buf minfo)
1888 (setf (headers-info-msg-buffer hinfo) nil))
1889 (t (delete-buffer-if-possible main-msg-buf))))))
1890 (dolist (mbuf (headers-info-other-msg-bufs hinfo))
1891 (let ((minfo (variable-value 'message-information :buffer mbuf)))
1892 (when (string= (the simple-string (message-info-msgs minfo))
1893 msg-id)
1894 (cond ((message-info-draft-buf minfo)
1895 (cleanup-headers-reference mbuf minfo)
1896 (setf (headers-info-other-msg-bufs hinfo)
1897 (delete mbuf (headers-info-other-msg-bufs hinfo)
1898 :test #'eq)))
1899 (t (delete-buffer-if-possible mbuf)))
1900 (return)))))
1901 (dolist (dbuf (headers-info-draft-bufs hinfo))
1902 (let ((dinfo (variable-value 'draft-information :buffer dbuf)))
1903 (when (same-line-p (draft-info-headers-mark dinfo) hmark)
1904 (cleanup-headers-reference dbuf dinfo)
1905 (setf (headers-info-draft-bufs hinfo)
1906 (delete dbuf (headers-info-draft-bufs hinfo) :test #'eq))
1907 (return)))))
1908
1909
1910 (defcommand "Undelete Message" (p)
1911 "Prompts for a folder, messages to undelete, and pick expression. When in
1912 a headers buffer into the same folder specified, the messages prompt
1913 defaults to those messages in the buffer; \"all\" may be entered if this is
1914 not what is desired. This command is only meaningful if you have
1915 \"Virtual Message Deletion\" set."
1916 "Prompts for a folder, messages to undelete, and pick expression. When in
1917 a headers buffer into the same folder specified, the messages prompt
1918 defaults to those messages in the buffer; \"all\" may be entered if this is
1919 not what is desired. This command is only meaningful if you have
1920 \"Virtual Message Deletion\" set."
1921 (declare (ignore p))
1922 (unless (value virtual-message-deletion)
1923 (editor-error "You don't use virtual message deletion."))
1924 (let* ((folder (prompt-for-folder))
1925 (hinfo (value headers-information))
1926 (temp-msgs (prompt-for-message
1927 :folder folder
1928 :messages
1929 (if (and hinfo
1930 (string= folder
1931 (the simple-string
1932 (headers-info-folder hinfo))))
1933 (headers-info-msg-strings hinfo))
1934 :prompt "MH messages to pick from: "))
1935 (pick-exp (prompt-for-pick-expression))
1936 (msgs (if pick-exp
1937 (or (pick-messages folder temp-msgs pick-exp) temp-msgs)
1938 temp-msgs)))
1939 (declare (simple-string folder))
1940 (mh "mark" `(,folder ,@msgs "-sequence" "hemlockdeleted" "-delete"))
1941 (let ((deleted-seq (mh-sequence-list folder "hemlockdeleted")))
1942 (do-headers-buffers (hbuf folder)
1943 (with-writable-buffer (hbuf)
1944 (do-headers-lines (hbuf :line-var line :mark-var hmark)
1945 (when (and (line-message-deleted line)
1946 (not (mh-sequence-member-p (line-message-id line)
1947 deleted-seq)))
1948 (note-undeleted-message-at-mark hmark))))))))
1949
1950 (defcommand "Headers Undelete Message" (p)
1951 "Undelete the current message.
1952 When in a headers buffer, undeletes the message on the current line. When
1953 in a message buffer, undeletes that message. This command is only
1954 meaningful if you have \"Virtual Message Deletion\" set."
1955 "When in a headers buffer, undeletes the message on the current line. When
1956 in a message buffer, undeletes that message. This command is only
1957 meaningful if you have \"Virtual Message Deletion\" set."
1958 (declare (ignore p))
1959 (unless (value virtual-message-deletion)
1960 (editor-error "You don't use virtual message deletion."))
1961 (let ((hinfo (value headers-information))
1962 (minfo (value message-information)))
1963 (cond (hinfo
1964 (multiple-value-bind (cur-msg cur-mark)
1965 (headers-current-message hinfo)
1966 (unless cur-msg (editor-error "Not on a header line."))
1967 (delete-mark cur-mark)
1968 (undelete-message (headers-info-folder hinfo) cur-msg)))
1969 (minfo
1970 (undelete-message (message-info-folder minfo)
1971 (message-info-msgs minfo))
1972 (message "Message undeleted."))
1973 (t (editor-error "Not in a headers or message buffer.")))))
1974
1975 ;;; UNDELETE-MESSAGE takes a folder and a message id. All headers buffers into
1976 ;;; folder are updated.
1977 ;;;
1978 (defun undelete-message (folder msg)
1979 (mark-one-message folder msg "hemlockdeleted" :delete)
1980 (do-headers-buffers (hbuf folder)
1981 (with-headers-mark (hmark hbuf msg)
1982 (with-writable-buffer (hbuf)
1983 (note-undeleted-message-at-mark hmark))))
1984 (dolist (b *buffer-list*)
1985 (when (and (hemlock-bound-p 'message-information :buffer b)
1986 (buffer-modeline-field-p b :deleted-message))
1987 (dolist (w (buffer-windows b))
1988 (update-modeline-field b w :deleted-message)))))
1989
1990 ;;; NOTE-UNDELETED-MESSAGE-AT-MARK takes a mark at the beginning of a valid
1991 ;;; headers line, sticks a space on the line in place of a "D", and frobs the
1992 ;;; line's deleted property. This assumes the headers buffer is modifiable.
1993 ;;;
1994 (defun note-undeleted-message-at-mark (hmark)
1995 (find-attribute hmark :digit)
1996 (find-attribute hmark :digit #'zerop)
1997 (character-offset hmark 2)
1998 (setf (next-character hmark) #\space)
1999 (setf (line-message-deleted (mark-line hmark)) nil))
2000
2001
2002 (defcommand "Expunge Messages" (p)
2003 "Expunges messages marked for deletion.
2004 This command prompts for a folder, invoking RMM on the \"hemlockdeleted\"
2005 sequence after asking the user for confirmation. Setting \"Quit Headers
2006 Confirm\" to nil inhibits prompting. The folder's message id's are packed
2007 with FOLDER -pack. When in a headers buffer, uses that folder. When in a
2008 message buffer, uses its folder, updating any associated headers buffer.
2009 When \"Temporary Draft Folder\" is bound, this folder's messages are deleted
2010 and expunged."
2011 "Prompts for a folder, invoking RMM on the \"hemlockdeleted\" sequence and
2012 packing the message id's with FOLDER -pack. When in a headers buffer,
2013 uses that folder."
2014 (declare (ignore p))
2015 (let* ((hinfo (value headers-information))
2016 (minfo (value message-information))
2017 (folder (cond (hinfo (headers-info-folder hinfo))
2018 (minfo (message-info-folder minfo))
2019 (t (prompt-for-folder))))
2020 (deleted-seq (mh-sequence-list folder "hemlockdeleted")))
2021 ;;
2022 ;; Delete the messages if there are any.
2023 ;; This deletes "hemlockdeleted" from sequence file; we don't have to.
2024 (when (and deleted-seq
2025 (or (not (value expunge-messages-confirm))
2026 (prompt-for-y-or-n
2027 :prompt (list "Expunge messages and pack folder ~A? "
2028 folder)
2029 :default t
2030 :default-string "Y")))
2031 (message "Deleting messages ...")
2032 (mh "rmm" (list folder "hemlockdeleted"))
2033 ;;
2034 ;; Compact the message id's after deletion.
2035 (let ((*standard-output* *mh-utility-bit-bucket*))
2036 (message "Compacting folder ...")
2037 (mh "folder" (list folder "-fast" "-pack")))
2038 ;;
2039 ;; Do a bunch of consistency maintenance.
2040 (let ((new-buf-p (eq (current-buffer) *new-mail-buffer*)))
2041 (message "Maintaining consistency ...")
2042 (expunge-messages-fold-headers-buffers folder)
2043 (expunge-messages-fix-draft-buffers folder)
2044 (expunge-messages-fix-unseen-headers folder)
2045 (when new-buf-p (change-to-buffer *new-mail-buffer*)))
2046 (delete-and-expunge-temp-drafts))))
2047
2048 ;;; EXPUNGE-MESSAGES-FOLD-HEADERS-BUFFERS deletes all headers buffers into the
2049 ;;; compacted folder. We can only update the headers buffers by installing all
2050 ;;; headers, so there may as well be only one such buffer. First we get a list
2051 ;;; of the buffers since DO-HEADERS-BUFFERS is trying to iterate over a list
2052 ;;; being destructively modified by buffer deletions.
2053 ;;;
2054 (defun expunge-messages-fold-headers-buffers (folder)
2055 (let (hbufs)
2056 (declare (list hbufs))
2057 (do-headers-buffers (b folder)
2058 (unless (eq b *new-mail-buffer*)
2059 (push b hbufs)))
2060 (unless (zerop (length hbufs))
2061 (dolist (b hbufs)
2062 (delete-headers-buffer-and-message-buffers-command nil b))
2063 (new-message-headers folder (list "all")))))
2064
2065 ;;; EXPUNGE-MESSAGES-FIX-DRAFT-BUFFERS finds any draft buffer that was set up
2066 ;;; as a reply to some message in folder, removing this relationship in case
2067 ;;; that message id does not exist after expunge folder compaction.
2068 ;;;
2069 (defun expunge-messages-fix-draft-buffers (folder)
2070 (declare (simple-string folder))
2071 (dolist (b *buffer-list*)
2072 (when (hemlock-bound-p 'draft-information :buffer b)
2073 (let* ((dinfo (variable-value 'draft-information :buffer b))
2074 (reply-folder (draft-info-replied-to-folder dinfo)))
2075 (when (and reply-folder
2076 (string= (the simple-string reply-folder) folder))
2077 (setf (draft-info-replied-to-folder dinfo) nil)
2078 (setf (draft-info-replied-to-msg dinfo) nil))))))
2079
2080 ;;; EXPUNGE-MESSAGES-FIX-UNSEEN-HEADERS specially handles the unseen headers
2081 ;;; buffer apart from the other headers buffers into the same folder when
2082 ;;; messages have been expunged. We must delete the associated message buffers
2083 ;;; since REVAMP-HEADERS-BUFFER does not, and these potentially reference bad
2084 ;;; message id's. When doing this we must copy the other-msg-bufs list since
2085 ;;; the delete buffer cleanup hook for them is destructive. Then we check for
2086 ;;; more unseen messages.
2087 ;;;
2088 (defun expunge-messages-fix-unseen-headers (folder)
2089 (declare (simple-string folder))
2090 (when *new-mail-buffer*
2091 (let ((hinfo (variable-value 'headers-information
2092 :buffer *new-mail-buffer*)))
2093 (when (string= (the simple-string (headers-info-folder hinfo))
2094 folder)
2095 (let ((other-bufs (copy-list (headers-info-other-msg-bufs hinfo))))
2096 (dolist (b other-bufs) (delete-buffer-if-possible b)))
2097 (with-writable-buffer (*new-mail-buffer*)
2098 (revamp-headers-buffer *new-mail-buffer* hinfo)
2099 ;; Restore the name in case someone used "Pick Headers".
2100 (setf (buffer-name *new-mail-buffer*)
2101 (format nil "Unseen Headers ~A" folder))
2102 (let ((region (maybe-get-new-mail-msg-hdrs folder)))
2103 (when region
2104 (insert-message-headers *new-mail-buffer* hinfo region))))))))
2105
2106 ;;; MAYBE-GET-NEW-MAIL-MSG-HDRS returns a region suitable for a new mail buffer
2107 ;;; or nil. Folder is probed for unseen headers, and if there are some, then
2108 ;;; we call GET-NEW-MAIL-MSG-HDRS which also uses "Unseen Headers Message Spec".
2109 ;;; If there are no unseen headers, we only look for "Unseen Headers Message
2110 ;;; Spec" messages. We go through these contortions to keep MH from outputting
2111 ;;; errors.
2112 ;;;
2113 (defun maybe-get-new-mail-msg-hdrs (folder)
2114 (let ((unseen-seq-name (mh-profile-component "unseen-sequence")))
2115 (multiple-value-bind (unseen-seq foundp)
2116 (mh-sequence-list folder unseen-seq-name)
2117 (if (and foundp unseen-seq)
2118 (get-new-mail-msg-hdrs folder unseen-seq-name)
2119 (let ((spec (value unseen-headers-message-spec)))
2120 (when spec
2121 (message-headers-to-region
2122 folder
2123 (breakup-message-spec (string-trim '(#\space #\tab) spec)))))))))
2124
2125
2126
2127 ;;;; Folders.
2128
2129 (defvar *folder-name-table* nil)
2130
2131 (defun check-folder-name-table ()
2132 (unless *folder-name-table*
2133 (message "Finding folder names ...")
2134 (setf *folder-name-table* (make-string-table))
2135 (let* ((output (with-output-to-string (*standard-output*)
2136 (mh "folders" '("-fast"))))
2137 (length (length output))
2138 (start 0))
2139 (declare (simple-string output))
2140 (loop
2141 (when (> start length) (return))
2142 (let ((nl (position #\newline output :start start)))
2143 (unless nl (return))
2144 (unless (= start nl)
2145 (setf (getstring (subseq output start nl) *folder-name-table*) t))
2146 (setf start (1+ nl)))))))
2147
2148 (defcommand "List Folders" (p)
2149 "Pop up a list of folders at top-level."
2150 "Pop up a list of folders at top-level."
2151 (declare (ignore p))
2152 (check-folder-name-table)
2153 (with-pop-up-display (s)
2154 (do-strings (f ignore *folder-name-table*)
2155 (declare (ignore ignore))
2156 (write-line f s))))
2157
2158 (defcommand "Create Folder" (p)
2159 "Creates a folder. If the folder already exists, an error is signaled."
2160 "Creates a folder. If the folder already exists, an error is signaled."
2161 (declare (ignore p))
2162 (let ((folder (prompt-for-folder :must-exist nil)))
2163 (when (folder-existsp folder)
2164 (editor-error "Folder already exists -- ~S!" folder))
2165 (create-folder folder)))
2166
2167 (defcommand "Delete Folder" (p)
2168 "Prompts for a folder and uses RMF to delete it."
2169 "Prompts for a folder and uses RMF to delete it."
2170 (declare (ignore p))
2171 (let* ((folder (prompt-for-folder))
2172 (*standard-output* *mh-utility-bit-bucket*))
2173 (mh "rmf" (list folder))
2174 ;; RMF doesn't recognize this documented switch.
2175 ;; "-nointeractive"))))
2176 (check-folder-name-table)
2177 (delete-string (strip-folder-name folder) *folder-name-table*)))
2178
2179
2180 (defvar *refile-default-destination* nil)
2181
2182 (defcommand "Refile Message" (p)
2183 "Prompts for a source folder, messages, pick expression, and a destination
2184 folder to refile the messages."
2185 "Prompts for a source folder, messages, pick expression, and a destination
2186 folder to refile the messages."
2187 (declare (ignore p))
2188 (let* ((src-folder (prompt-for-folder :prompt "Source folder: "))
2189 (hinfo (value headers-information))
2190 (temp-msgs (prompt-for-message
2191 :folder src-folder
2192 :messages
2193 (if (and hinfo
2194 (string= src-folder
2195 (the simple-string
2196 (headers-info-folder hinfo))))
2197 (headers-info-msg-strings hinfo))
2198 :prompt "MH messages to pick from: "))
2199 (pick-exp (prompt-for-pick-expression))
2200 ;; Return pick result or temp-msgs individually specified in a list.
2201 (msgs (pick-messages src-folder temp-msgs pick-exp)))
2202 (declare (simple-string src-folder))
2203 (refile-message src-folder msgs
2204 (prompt-for-folder :must-exist nil
2205 :prompt "Destination folder: "
2206 :default *refile-default-destination*))))
2207
2208 (defcommand "Headers Refile Message" (p)
2209 "Refile the current message.
2210 When in a headers buffer, refiles the message on the current line, and when
2211 in a message buffer, refiles that message, prompting for a destination
2212 folder."
2213 "When in a headers buffer, refiles the message on the current line, and when
2214 in a message buffer, refiles that message, prompting for a destination
2215 folder."
2216 (declare (ignore p))
2217 (let ((hinfo (value headers-information))
2218 (minfo (value message-information)))
2219 (cond (hinfo
2220 (multiple-value-bind (cur-msg cur-mark)
2221 (headers-current-message hinfo)
2222 (unless cur-msg (editor-error "Not on a header line."))
2223 (delete-mark cur-mark)
2224 (refile-message (headers-info-folder hinfo) cur-msg
2225 (prompt-for-folder
2226 :must-exist nil
2227 :prompt "Destination folder: "
2228 :default *refile-default-destination*))))
2229 (minfo
2230 (refile-message
2231 (message-info-folder minfo) (message-info-msgs minfo)
2232 (prompt-for-folder :must-exist nil
2233 :prompt "Destination folder: "
2234 :default *refile-default-destination*))
2235 (message "Message refiled."))
2236 (t
2237 (editor-error "Not in a headers or message buffer.")))))
2238
2239 ;;; REFILE-MESSAGE refiles msg from src-folder to dst-folder. If dst-buffer
2240 ;;; doesn't exist, the user is prompted for creating it. All headers buffers
2241 ;;; concerning src-folder are updated. When msg is a list, we did a general
2242 ;;; message prompt, and we cannot know which headers lines to delete.
2243 ;;;
2244 (defun refile-message (src-folder msg dst-folder)
2245 (unless (folder-existsp dst-folder)
2246 (cond ((prompt-for-y-or-n
2247 :prompt "Destination folder doesn't exist. Create it? "
2248 :default t :default-string "Y")
2249 (create-folder dst-folder))
2250 (t (editor-error "Not refiling message."))))
2251 (mh "refile" `(,@(if (listp msg) msg (list msg))
2252 "-src" ,src-folder ,dst-folder))
2253 (setf *refile-default-destination* (strip-folder-name dst-folder))
2254 (if (listp msg)
2255 (do-headers-buffers (hbuf src-folder hinfo)
2256 (do-headers-lines (hbuf :line-var line :mark-var hmark)
2257 (when (member (line-message-id line) msg :test #'string=)
2258 (delete-headers-buffer-line hinfo hmark))))
2259 (do-headers-buffers (hbuf src-folder hinfo)
2260 (with-headers-mark (hmark hbuf msg)
2261 (delete-headers-buffer-line hinfo hmark)))))
2262
2263
2264
2265 ;;;; Miscellaneous commands.
2266
2267 (defcommand "Mark Message" (p)
2268 "Prompts for a folder, message, and sequence. By default the message is
2269 added, but if an argument is supplied, the message is deleted. When in
2270 a headers buffer or message buffer, only a sequence is prompted for."
2271 "Prompts for a folder, message, and sequence. By default the message is
2272 added, but if an argument is supplied, the message is deleted. When in
2273 a headers buffer or message buffer, only a sequence is prompted for."
2274 (let* ((hinfo (value headers-information))
2275 (minfo (value message-information)))
2276 (cond (hinfo
2277 (multiple-value-bind (cur-msg cur-mark)
2278 (headers-current-message hinfo)
2279 (unless cur-msg (editor-error "Not on a header line."))
2280 (delete-mark cur-mark)
2281 (let ((seq-name (prompt-for-string :prompt "Sequence name: "
2282 :trim t)))
2283 (declare (simple-string seq-name))
2284 (when (string= "" seq-name)
2285 (editor-error "Sequence name cannot be empty."))
2286 (mark-one-message (headers-info-folder hinfo)
2287 cur-msg seq-name (if p :delete :add)))))
2288 (minfo
2289 (let ((msgs (message-info-msgs minfo))
2290 (seq-name (prompt-for-string :prompt "Sequence name: "
2291 :trim t)))
2292 (declare (simple-string seq-name))
2293 (when (string= "" seq-name)
2294 (editor-error "Sequence name cannot be empty."))
2295 (mark-one-message (message-info-folder minfo)
2296 (if (consp msgs) (car msgs) msgs)
2297 seq-name (if p :delete :add))))
2298 (t
2299 (let ((folder (prompt-for-folder))
2300 (seq-name (prompt-for-string :prompt "Sequence name: "
2301 :trim t)))
2302 (declare (simple-string seq-name))
2303 (when (string= "" seq-name)
2304 (editor-error "Sequence name cannot be empty."))
2305 (mh "mark" `(,folder ,@(prompt-for-message :folder folder)
2306 "-sequence" ,seq-name
2307 ,(if p "-delete" "-add"))))))))
2308
2309
2310 (defcommand "List Mail Buffers" (p)
2311 "Show a list of all mail associated buffers.
2312 If the buffer has an associated message buffer, it is displayed to the right
2313 of the buffer name. If there is no message buffer, but the buffer is
2314 associated with a headers buffer, then it is displayed. If the buffer is
2315 modified then a * is displayed before the name."
2316 "Display the names of all buffers in a with-random-typeout window."
2317 (declare (ignore p))
2318 (let ((buffers nil))
2319 (declare (list buffers))
2320 (do-strings (n b *buffer-names*)
2321 (declare (ignore n))
2322 (unless (eq b *echo-area-buffer*)
2323 (cond ((hemlock-bound-p 'message-buffer :buffer b)
2324 ;; Catches draft buffers associated with message buffers first.
2325 (push (cons b (variable-value 'message-buffer :buffer b))
2326 buffers))
2327 ((hemlock-bound-p 'headers-buffer :buffer b)
2328 ;; Then draft or message buffers associated with headers buffers.
2329 (push (cons b (variable-value 'headers-buffer :buffer b))
2330 buffers))
2331 ((or (hemlock-bound-p 'draft-information :buffer b)
2332 (hemlock-bound-p 'message-information :buffer b)
2333 (hemlock-bound-p 'headers-information :buffer b))
2334 (push b buffers)))))
2335 (with-pop-up-display (s :height (length buffers))
2336 (dolist (ele (nreverse buffers))
2337 (let* ((association (if (consp ele) (cdr ele)))
2338 (b (if association (car ele) ele))
2339 (buffer-pathname (buffer-pathname b))
2340 (buffer-name (buffer-name b)))
2341 (write-char (if (buffer-modified b) #\* #\space) s)
2342 (if buffer-pathname
2343 (format s "~A ~A~:[~;~50T~:*~A~]~%"
2344 (file-namestring buffer-pathname)
2345 (directory-namestring buffer-pathname)
2346 (if association (buffer-name association)))
2347 (format s "~A~:[~;~50T~:*~A~]~%"
2348 buffer-name
2349 (if association (buffer-name association)))))))))
2350
2351
2352 (defcommand "Message Help" (p)
2353 "Show this help."
2354 "Show this help."
2355 (declare (ignore p))
2356 (describe-mode-command nil "Message"))
2357
2358 (defcommand "Headers Help" (p)
2359 "Show this help."
2360 "Show this help."
2361 (declare (ignore p))
2362 (describe-mode-command nil "Headers"))
2363
2364 (defcommand "Draft Help" (p)
2365 "Show this help."
2366 "Show this help."
2367 (declare (ignore p))
2368 (describe-mode-command nil "Draft"))
2369
2370
2371
2372 ;;;; Prompting.
2373
2374 ;;; Folder prompting.
2375 ;;;
2376
2377 (defun prompt-for-folder (&key (must-exist t) (prompt "MH Folder: ")
2378 (default (mh-current-folder)))
2379 "Prompts for a folder, using MH's idea of the current folder as a default.
2380 The result will have a leading + in the name."
2381 (check-folder-name-table)
2382 (let ((folder (prompt-for-keyword (list *folder-name-table*)
2383 :must-exist must-exist :prompt prompt
2384 :default default :default-string default
2385 :help "Enter folder name.")))
2386 (declare (simple-string folder))
2387 (when (string= folder "") (editor-error "Must supply folder!"))
2388 (let ((name (coerce-folder-name folder)))
2389 (when (and must-exist (not (folder-existsp name)))
2390 (editor-error "Folder does not exist -- ~S." name))
2391 name)))
2392
2393 (defun coerce-folder-name (folder)
2394 (if (char= (schar folder 0) #\+)
2395 folder
2396 (concatenate 'simple-string "+" folder)))
2397
2398 (defun strip-folder-name (folder)
2399 (if (char= (schar folder 0) #\+)
2400 (subseq folder 1)
2401 folder))
2402
2403
2404 ;;; Message prompting.
2405 ;;;
2406
2407 (defun prompt-for-message (&key (folder (mh-current-folder))
2408 (prompt "MH messages: ")
2409 messages)
2410 "Prompts for a message spec, using messages as a default. If messages is
2411 not supplied, then the current message for folder is used. The result is
2412 a list of strings which are the message ids, intervals, and/or sequence
2413 names the user entered."
2414 (let* ((cur-msg (cond ((not messages) (mh-current-message folder))
2415 ((stringp messages) messages)
2416 ((consp messages)
2417 (if (= (length (the list messages)) 1)
2418 (car messages)
2419 (format nil "~{~A~^ ~}" messages))))))
2420 (breakup-message-spec (prompt-for-string :prompt prompt
2421 :default cur-msg
2422 :default-string cur-msg
2423 :trim t
2424 :help "Enter MH message id(s)."))))
2425
2426 (defun breakup-message-spec (msgs)
2427 (declare (simple-string msgs))
2428 (let ((start 0)
2429 (result nil))
2430 (loop
2431 (let ((end (position #\space msgs :start start :test #'char=)))
2432 (unless end
2433 (return (if (zerop start)
2434 (list msgs)
2435 (nreverse (cons (subseq msgs start) result)))))
2436 (push (subseq msgs start end) result)
2437 (setf start (1+ end))))))
2438
2439
2440 ;;; PICK expression prompting.
2441 ;;;
2442
2443 (defhvar "MH Lisp Expression"
2444 "When this is set (the default), MH expression prompts are read in a Lisp
2445 syntax. Otherwise, the input is as if it had been entered on a shell
2446 command line."
2447 :value t)
2448
2449 ;;; This is dynamically bound to nil for argument processing routines.
2450 ;;;
2451 (defvar *pick-expression-strings* nil)
2452
2453 (defun prompt-for-pick-expression ()
2454 "Prompts for an MH PICK-like expression that is converted to a list of
2455 strings suitable for EXT:RUN-PROGRAM. As a second value, the user's
2456 expression is as typed in is returned."
2457 (let ((exp (prompt-for-string :prompt "MH expression: "
2458 :help "Expression to PICK over mail messages."
2459 :trim t))
2460 (*pick-expression-strings* nil))
2461 (if (value mh-lisp-expression)
2462 (let ((exp (let ((*package* *keyword-package*))
2463 (read-from-string exp))))
2464 (if exp
2465 (if (consp exp)
2466 (lisp-to-pick-expression exp)
2467 (editor-error "Lisp PICK expressions cannot be atomic."))))
2468 (expand-mh-pick-spec exp))
2469 (values (nreverse *pick-expression-strings*)
2470 exp)))
2471
2472 (defun lisp-to-pick-expression (exp)
2473 (ecase (car exp)
2474 (:and (lpe-and/or exp "-and"))
2475 (:or (lpe-and/or exp "-or"))
2476 (:not (push "-not" *pick-expression-strings*)
2477 (let ((nexp (cadr exp)))
2478 (unless (consp nexp) (editor-error "Bad expression -- ~S" nexp))
2479 (lisp-to-pick-expression nexp)))
2480
2481 (:cc (lpe-output-and-go exp "-cc"))
2482 (:date (lpe-output-and-go exp "-date"))
2483 (:from (lpe-output-and-go exp "-from"))
2484 (:search (lpe-output-and-go exp "-search"))
2485 (:subject (lpe-output-and-go exp "-subject"))
2486 (:to (lpe-output-and-go exp "-to"))
2487 (:-- (lpe-output-and-go (cdr exp)
2488 (concatenate 'simple-string
2489 "--" (string (cadr exp)))))
2490
2491 (:before (lpe-after-and-before exp "-before"))
2492 (:after (lpe-after-and-before exp "-after"))
2493 (:datefield (lpe-output-and-go exp "-datefield"))))
2494
2495 (defun lpe-after-and-before (exp op)
2496 (let ((operand (cadr exp)))
2497 (when (numberp operand)
2498 (setf (cadr exp)
2499 (if (plusp operand)
2500 (number-string (- operand))
2501 (number-string operand)))))
2502 (lpe-output-and-go exp op))
2503
2504 (defun lpe-output-and-go (exp op)
2505 (push op *pick-expression-strings*)
2506 (let ((operand (cadr exp)))
2507 (etypecase operand
2508 (string (push operand *pick-expression-strings*))
2509 (symbol (push (symbol-name operand)
2510 *pick-expression-strings*)))))
2511
2512 (defun lpe-and/or (exp op)
2513 (push "-lbrace" *pick-expression-strings*)
2514 (dolist (ele (cdr exp))
2515 (lisp-to-pick-expression ele)
2516 (push op *pick-expression-strings*))
2517 (pop *pick-expression-strings*) ;Clear the extra "-op" arg.
2518 (push "-rbrace" *pick-expression-strings*))
2519
2520 ;;; EXPAND-MH-PICK-SPEC takes a string of "words" assumed to be separated
2521 ;;; by single spaces. If a "word" starts with a quotation mark, then
2522 ;;; everything is grabbed up to the next one and used as a single word.
2523 ;;; Currently, this does not worry about extra spaces (or tabs) between
2524 ;;; "words".
2525 ;;;
2526 (defun expand-mh-pick-spec (spec)
2527 (declare (simple-string spec))
2528 (let ((start 0))
2529 (loop
2530 (let ((end (position #\space spec :start start :test #'char=)))
2531 (unless end
2532 (if (zerop start)
2533 (setf *pick-expression-strings* (list spec))
2534 (push (subseq spec start) *pick-expression-strings*))
2535 (return))
2536 (cond ((char= #\" (schar spec start))
2537 (setf end (position #\" spec :start (1+ start) :test #'char=))
2538 (unless end (editor-error "Bad quoting syntax."))
2539 (push (subseq spec (1+ start) end) *pick-expression-strings*)
2540 (setf start (+ end 2)))
2541 (t (push (subseq spec start end) *pick-expression-strings*)
2542 (setf start (1+ end))))))))
2543
2544
2545 ;;; Password prompting.
2546 ;;;
2547
2548 (defun prompt-for-password (&optional (prompt "Password: "))
2549 "Prompts for password with prompt."
2550 (let ((hi::*parse-verification-function* #'(lambda (string) (list string))))
2551 (let ((hi::*parse-prompt* prompt))
2552 (hi::display-prompt-nicely))
2553 (let ((start-window (current-window)))
2554 (move-mark *parse-starting-mark* (buffer-point *echo-area-buffer*))
2555 (setf (current-window) *echo-area-window*)
2556 (unwind-protect
2557 (use-buffer *echo-area-buffer*
2558 (let ((result ()))
2559 (declare (list result))
2560 (loop
2561 (let ((key-event (get-key-event *editor-input*)))
2562 (ring-pop hi::*key-event-history*)
2563 (cond ((eq key-event #k"return")
2564 (return (prog1 (coerce (nreverse result)
2565 'simple-string)
2566 (fill result nil))))
2567 ((or (eq key-event #k"control-u")
2568 (eq key-event #k"control-U"))
2569 (setf result nil))
2570 (t (push (ext:key-event-char key-event) result)))))))
2571 (setf (current-window) start-window)))))
2572
2573
2574
2575
2576 ;;;; Making mail buffers.
2577
2578 ;;; MAYBE-MAKE-MH-BUFFER looks up buffer with name, returning it if it exists
2579 ;;; after cleaning it up to a state "good as new". Currently, we don't
2580 ;;; believe it is possible to try to make two draft buffers with the same name
2581 ;;; since that would mean that composition, draft folder interaction, and
2582 ;;; draft folder current message didn't do what we expected -- or some user
2583 ;;; was modifying the draft folder in some evil way.
2584 ;;;
2585 (defun maybe-make-mh-buffer (name use)
2586 (let ((buf (getstring name *buffer-names*)))
2587 (cond ((not buf)
2588 (ecase use
2589 (:headers (make-buffer name
2590 :modes '("Headers")
2591 :delete-hook '(cleanup-headers-buffer)))
2592
2593 (:message
2594 (make-buffer name :modes '("Message")
2595 :modeline-fields
2596 (value default-message-modeline-fields)
2597 :delete-hook '(cleanup-message-buffer)))
2598
2599 (:draft
2600 (let ((buf (make-buffer
2601 name :delete-hook '(cleanup-draft-buffer))))
2602 (setf (buffer-minor-mode buf "Draft") t)
2603 buf))))
2604 ((hemlock-bound-p 'headers-information :buffer buf)
2605 (setf (buffer-writable buf) t)
2606 (delete-region (buffer-region buf))
2607 (cleanup-headers-buffer buf)
2608 (delete-variable 'headers-information :buffer buf)
2609 buf)
2610 ((hemlock-bound-p 'message-information :buffer buf)
2611 (setf (buffer-writable buf) t)
2612 (delete-region (buffer-region buf))
2613 (cleanup-message-buffer buf)
2614 (delete-variable 'message-information :buffer buf)
2615 buf)
2616 ((hemlock-bound-p 'draft-information :buffer buf)
2617 (error "Attempt to create multiple draft buffers to same draft ~
2618 folder message -- ~S"
2619 name)))))
2620
2621
2622 ;;;; Message buffer modeline fields.
2623
2624 (make-modeline-field
2625 :name :deleted-message :width 2
2626 :function
2627 #'(lambda (buffer window)
2628 "Returns \"D \" when message in buffer is deleted."
2629 (declare (ignore window))
2630 (let* ((minfo (variable-value 'message-information :buffer buffer))
2631 (hmark (message-info-headers-mark minfo)))
2632 (cond ((not hmark)
2633