diplodocus.org Git - nmh/blob - 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")