Added -clobber switch to mhstore(1) [Bug #11160].
[mmh] / docs / historical / mh-6.8.5 / miscellany / mhe / mh-e.ml
1 ; This file implements "mhe", the display-oriented front end to the MH mail
2 ; system. Documentation is in file mh-doc.ml.
3 ; To install this at your site you must edit the variables flagged with
4 ; an asterisk below.
5
6 ;  Brian K. Reid, Stanford, April 1982
7 ;
8 ; This is version 4 (September 1982); it uses fast-filter-region.
9
10 ; UCI modification: we don't need fast-filter-region since we have
11 ;                   use-users-shell
12     (setq stack-trace-on-error 1)
13     (declare-global             ;*marks installation constants
14          mh-keymap-defined      ; T iff keymap exists.
15          mh-folder              ; string name, e.g. "inbox"
16          mh-path                ; "/mnt/reid/Mail", or whatever
17          mh-progs               ;*"/usr/local/lib/mh", or whatever
18          bboard-path            ;*"/usr/spool/netnews", or whatever
19          mh-buffer-filename     ; "/mnt/reid/Mail/inbox", or whatever
20          t-buffer-filename      ; scratch for side effect from mh-folder
21          mh-flist               ; "inbox,carbons,news", or whatever
22          mh-direction           ; 1 is up, -1 is down.
23          mh-annotate            ; are we annotating processed msgs?
24          mh-writeable           ; is this folder write-enabled?
25          mh-last-destination    ; destination of last "move" command
26          mhe-debug              ; are we debugging macro package?
27     )
28
29     (argc)                      ; is this early enough, James?
30     (setq mh-keymap-defined 0)
31     (setq mhe-debug 0)
32     (setq-default mh-annotate 1)
33     (setq-default mh-writeable 1)
34     (setq bboard-path "/dev/null"); UCI
35     (setq mh-path "")
36     (setq mh-progs "/usr/uci")  ; UCI
37     (setq mh-flist "")
38     (setq-default right-margin 77)
39     (setq-default mh-direction 1)
40     (setq pop-up-windows 1)     ; mhe requires popup windows!
41
42     (declare-buffer-specific
43         mh-direction
44         mh-buffer-filename
45         mh-folder-title
46         mh-annotate
47         mh-writeable
48         backup-before-writing
49         wrap-long-lines
50     )
51
52 (defun                          ; (mh "folder" "range")
53     (mh folder range
54         (temp-use-buffer "cmd-buffer") (erase-buffer)
55         (setq backup-before-writing 0)
56         (find-path)
57         (setq folder (arg 1 (concat ": mh on folder? [" mh-folder "] ")))
58         (if (= folder "")
59             (setq folder mh-folder))
60         (if (= '+' (string-to-char (substr folder 1 1)))
61             (setq folder (substr folder 2 -1)))
62         (setq range (arg 2))
63         (setq mh-folder (get-folder-name "??" folder 1))
64         (&mh-read-folder mh-folder range t-buffer-filename mh-folder)
65         (progn stop-loop
66                (setq stop-loop 0)
67                (while (! stop-loop)
68                       (pop-to-buffer (concat "+" mh-folder))
69                       (use-local-map "&mh-keymap")
70                       (error-occured (recursive-edit))
71                       (setq stop-loop (&mh-exit))
72                )
73         )
74     )
75 )
76 ; This function marks a message as being deleted. This mark has two parts.
77 ; The letter "D" is placed in column 4 of the header line, and the message
78 ; number is added to the text of an "rmm" command that is being assembled
79 ; in the command buffer.
80 (defun 
81     (&mh-Mark-file-deleted
82         (pop-to-buffer (concat "+" mh-folder))
83         (if (! mh-writeable)
84             (error-message "Sorry; this folder is read-only."))
85         (beginning-of-line)
86         (goto-character (+ (dot) 3))
87         (if (| (= (following-char) ' ') (= (following-char) '+'))
88             (progn 
89                    (delete-next-character)
90                    (insert-string "D")
91                    (setq buffer-is-modified 0)
92                    (temp-use-buffer "cmd-buffer")
93                    (beginning-of-file)
94                    (if (error-occured
95                            (re-search-forward
96                                (concat "^rmm +" mh-folder)))
97                        (progn 
98                               (end-of-file)
99                               (insert-string (concat "rmm +" mh-folder "\n"))
100                               (backward-character)
101                        )
102                    )
103                    (end-of-line)
104                    (insert-string (concat " " (&mh-get-msgnum)))
105                    (setq buffer-is-modified 0)
106                    (pop-to-buffer (concat "+" mh-folder))
107             )
108         )
109         (another-line)
110     )
111 )
112 ; These functions create (and make current) a header buffer on a new message
113 ; or bboard directory.
114 (defun 
115     (&mh-new-folder which
116         (setq which (get-folder-name "New" "" 1))
117         (&mh-read-folder which "" t-buffer-filename which)
118     )
119     
120     (&mh-bboard which
121         (error-message "B: command not implemented at UCI."); UCI
122 ;UCI    (setq which (get-bboard-name))
123 ;UCI    (&mh-read-folder which "" t-buffer-filename t-buffer-filename)
124 ;UCI    (setq mh-annotate 0)
125 ;UCI    (setq mh-writeable 0)
126     )
127 )
128
129 (defun    
130     (&mh-remove
131         (if (= "+" (substr (current-buffer-name) 1 1))
132             (progn 
133                    (beginning-of-line)
134                    (&mh-unmark)
135                    (kill-to-end-of-line) (kill-to-end-of-line)
136                    (setq buffer-is-modified 0)
137             )
138             (error-message "The " (char-to-string (last-key-struck)) " command works only in header windows.")
139         )
140     )
141
142 ; This function gets redefined when &mh-move is autoloaded. Shame on me for
143 ; giving it a name so similar to the function above.
144     (&mh-re-move
145         (error-message "I can't repeat the last ^ command because you haven't typed one yet")
146     )
147
148     (&mh-summary
149         (message
150                 "nxt prev del ^put !rpt unmrk typ edit mail forw inc repl get bboard ^X^C ?")
151     )
152
153 ;  This function is redefined when file mh-extras.ml is autoloaded
154     (&mh-beep (send-string-to-terminal "\a"))
155 )
156 ; These functions are used to preserve the contents of the kill buffer
157 ; across things that we want to be invisible, so that the keyboard-level
158 ; user does not have to worry about system functions clobbering the kill
159 ; buffer.
160 (defun     
161     (&mh-save-killbuffer
162         (save-excursion 
163             (temp-use-buffer "Kill buffer")
164             (temp-use-buffer "Kill save")
165             (setq backup-before-writing 0)
166             (erase-buffer)
167             (yank-buffer "Kill buffer")
168             (setq buffer-is-modified 0)
169         )
170     )
171     
172     (&mh-restore-killbuffer
173         (save-excursion 
174             (temp-use-buffer "Kill buffer")
175             (erase-buffer)
176             (yank-buffer "Kill save")
177         )
178     )
179 )
180 ; These functions move the cursor around in a header buffer, and possibly
181 ; also display the message that the cursor now points to.
182 (defun     
183     (&mh-next-line
184         (pop-to-buffer (concat "+" mh-folder))
185         (setq mh-direction 1)
186         (next-line) (beginning-of-line)
187         (if (eobp)
188             (progn (previous-line)
189                    (setq mh-direction -1)))
190     )
191     (&mh-previous-line
192         (pop-to-buffer (concat "+" mh-folder))
193         (setq mh-direction -1)
194         (previous-line) (beginning-of-line)
195         (if (bobp)
196             (setq mh-direction 1))
197     )
198     
199     (another-line old-direction
200         (setq old-direction mh-direction)
201         (if (> mh-direction 0)
202             (&mh-next-line)
203             (&mh-previous-line)
204         )
205         (if (!= old-direction mh-direction)
206             (if (> mh-direction 0)
207                 (beginning-of-line)
208                 (&mh-previous-line)
209             )
210         )
211     )
212     
213 )
214 ; These functions query the user for various things, and error-check the
215 ; responses. "get-response" reads a 1-letter response code in the minibuffer.
216 ; "get-folder-name" extracts the string name of an MH folder or file.
217 ; "get-bboard-name" gets the string name of a bboard file.
218 (defun     
219     (get-response chr ok s c pr
220         (setq ok 0) (setq pr (arg 1))
221         (while (! ok)
222                (setq chr
223                      (string-to-char 
224                          (setq c
225                                (get-tty-string pr)
226                          )
227                      )
228                )
229                
230                (setq s (arg 2))
231                (while (> (length s) 0)
232                       (if (= chr (string-to-char (substr s 1 1)))
233                           (progn (setq ok 1) (setq s ""))
234                           (setq s (substr s 2 -1))
235                       )
236                )
237                (if (= ok 0)
238                    (progn (if (!= chr '?')
239                               (setq pr (concat "Illegal response '"
240                                                (char-to-string chr)
241                                                "'. " (arg 1)))
242                               (setq pr (arg 3))
243                           )
244                    )
245                )
246         )
247         (if (& (>= chr 'A') (<= chr 'Z'))
248             (+ chr (- 'a' 'A'))
249             chr
250         )
251     )
252     
253     (get-folder-name            ; (g-f-n "prompt" "default" can-create)
254         exists msgg name defarg
255         (setq exists 0)
256         (if (> (nargs) 1) (setq defarg (arg 2)) (setq defarg ""))
257         (setq msgg (concat (arg 1) " folder name? "))
258         (while (! exists)
259                (if (= 0 (length defarg))
260                    (setq name (get-tty-string msgg))
261                    (setq name defarg)
262                )
263                (setq defarg "")
264                (if (= 0 (length name))
265                    (error-message "Aborted."))
266                (if (!= (string-to-char (substr name 1 1)) '/')
267                    (setq t-buffer-filename (concat mh-path "/" name))
268                    (setq t-buffer-filename name)
269                )
270                (setq exists (file-exists t-buffer-filename))
271                (if (& (!= exists 1) (!= (arg 3) 0))
272                    (progn ans
273                           (setq ans (get-response
274                                         (concat "Folder +" name " does not exist. May I create it for you? ")
275                                         "yYnN\\ 3"
276                                         "Please answer y or n"))
277                           (if (= ans 'y')
278                               (progn 
279                                      (message "OK, I will create one for you.")
280                                      (send-to-shell 
281                                          (concat "mkdir " t-buffer-filename))
282                                      (setq exists 1)
283                               )
284                           )
285                    )
286                )
287                (if (!= exists 1)
288                    (setq msgg  (concat "Sorry, no such folder as `" name
289                                        "'.  Folder name? "))
290                )
291         )
292         name
293     )
294     
295     (get-bboard-name  exists msgg name
296         (setq exists 0)
297         (setq msgg "BBoard name? ")
298         (while (! exists)
299                (setq name (get-tty-string msgg))
300                (if (= 0 (length name))
301                    (error-message "Aborted."))
302                (if (!= (string-to-char (substr name 1 1)) '/')
303                    (setq t-buffer-filename (concat bboard-path "/" name))
304                    (setq t-buffer-filename name)
305                )
306                (setq exists (file-exists t-buffer-filename))
307                (if (!= exists 1)
308                    (setq msgg  (concat "Sorry, no such BBoard as `" name
309                                        "'.  BBoard name? "))
310                )
311         )
312         name
313     )
314 )
315 ; UCI hack for fast-filter-region
316 (defun (fast-filter-region UseUsersShell
317                 (setq UseUsersShell use-users-shell)
318                 (setq use-users-shell 0)
319                 (filter-region
320                     (arg 1 ": fast-filter-region (through command) "))
321                 (setq use-users-shell UseUsersShell)
322        )
323 )
324 ; These functions are the initial entry points to mhe. "startup" is 
325 ; expecting an argv like "emacs -lmh-e.ml -estartup +inbox 100-last
326 (defun
327     (startup
328             (setq stack-trace-on-error 0)
329             (mh (if (> (argc) 3)
330                     (argv 3)
331                     "")
332                 (if (> (argc) 4)
333                     (argv 4)
334                     "")
335             )
336             (error-occured (kill-process "newtime"))
337             (exit-emacs)
338     )
339     
340     (debug-startup
341         (setq mh-progs "/usr/local/src/cmd/mh/progs")
342         (setq stack-trace-on-error 0)
343         (startup)
344     )
345 )
346     (load "mh-util.ml")
347     (load "mh-shell.ml")
348     (load "mh-cache.ml")
349     (autoload "&mh-send" "mh-send.ml")
350     (autoload "&mh-show" "mh-show.ml")
351     (autoload "&mh-edit" "mh-edit.ml")
352     (autoload "&mh-repl" "mh-repl.ml")
353     (autoload "&mh-inc" "mh-inc.ml")
354     (autoload "&mh-help" "mh-help.ml")
355     (autoload "&mh-move" "mh-move.ml")
356     (autoload "&mh-unmark" "mh-unmark.ml")
357     (autoload "&mh-forw" "mh-forw.ml")
358     (autoload "&mh-exit" "mh-exit.ml")
359     (autoload "annotate" "mh-annot.ml")
360     (autoload "mail-mode" "mh-mode.ml")
361     (autoload "&mh-extras" "mh-extras.ml")
362     (autoload "&mh-xpack" "mh-extras.ml")
363     (if (! (is-bound time))
364         (load "time.ml")
365         (time)
366     )
367     (load "mh-keymap.ml")