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