diplodocus.org Git - nmh/blob - docs/historical/mh-6.8.5/miscellany/mhe/mh-extras.ml

   1 ;  This autoloaded file implements the "x" key of mhe: extended commands.
   2 (defun
   3     (&mh-extras
   4         (save-excursion
   5             (pop-to-buffer "mh-xcommands")
   6             (use-local-map "&mh-x-keymap")
   7             (if (= 0 (buffer-size))
   8                 (insert-string
   9                     "Key        Meaning         (Type extended command character:  )\n"
  10                     " q Quit: get out of this extended command mode\n"
  11                     " p Pack the current folder (renumber messages to be 1-N)\n"
  12                     " c Close the current folder (process deletes and moves).\n"
  13                     " s Scavenge the current folder (regenerate header buffer)\n"
  14                     " f Show a list of the existing folders\n"
  15                     " l Print the current message on the line printer.\n"
  16                     " m Make a new folder.\n"
  17                     " k Kill a folder (erase it and all of its contents)\n"
  18                 )
  19             )
  20             (setq mode-line-format
  21                   "mhe extended command mode. Type 'q' to quit this mode   %M")
  22             (setq buffer-is-modified 0)
  23             (beginning-of-file) (end-of-line) (backward-character)
  24             (backward-character)
  25             (local-bind-to-key "&mh-xpack" "p")
  26             (local-bind-to-key "&mh-xclose" "c")
  27             (local-bind-to-key "&mh-xscavenge" "s")
  28             (local-bind-to-key "&mh-xfolders" "f")
  29             (local-bind-to-key "&mh-xlprint" "l")
  30             (local-bind-to-key "&mh-xmake" "m")
  31             (local-bind-to-key "&mh-xkill" "k")
  32             (recursive-edit)
  33             (pop-to-buffer "mh-xcommands")
  34             (delete-window)
  35         )
  36     )
  37     (&mh-beep (error-message "Use 'q' to quit this extended command mode."))
  38
  39     (&mh-xpack
  40         (pop-to-buffer (concat "+" mh-folder))
  41         (&mh-pack-folder)
  42         (&mh-adjust-window)
  43         (exit-emacs)
  44     )
  45
  46     (&mh-xclose
  47         (message "C: close folder...") (sit-for 0)
  48         (pop-to-buffer (concat "+" mh-folder))
  49         (message "C: close folder...") (sit-for 1)
  50         (&mh-close-folder)
  51         (exit-emacs)
  52     )
  53
  54     (&mh-xscavenge sm
  55         (pop-to-buffer (concat "+" mh-folder))
  56         (setq sm mode-line-format)
  57         (&mh-regenerate-headers)
  58         (setq mode-line-format sm)
  59         (exit-emacs)
  60     )
  61
  62     (&mh-xfolders
  63         (message "F: list folders...")
  64         (pop-to-buffer "mh-temp")
  65         (use-local-map "&mh-keymap")
  66         (erase-buffer) (sit-for 0)
  67         (send-to-shell (concat mh-progs "/folders"))
  68         (exit-emacs)
  69     )
  70
  71     (&mh-xlprint
  72         (error-message "L: command not implemented.")
  73     )
  74
  75     (&mh-xmake exists msgg name
  76         (message "M: make a new folder...")
  77         (setq exists 1)
  78         (setq msgg "M: make a new folder...name for it? ")
  79         (while exists
  80                (setq name (get-tty-string msgg))
  81                (if (= 0 (length name))
  82                    (progn
  83                           (message "Aborted.") (sit-for 5)
  84                           (exit-emacs)))
  85                (if (!= (string-to-char (substr name 1 1)) '/')
  86                    (setq t-buffer-filename (concat mh-path "/" name))
  87                    (setq t-buffer-filename name)
  88                )
  89                (setq exists (file-exists t-buffer-filename))
  90                (if (= exists 1)
  91                           (setq msgg (concat "Folder +" name " already exists. Try another name? "))
  92                )
  93         )
  94         (send-to-shell
  95             (concat "mkdir " t-buffer-filename))
  96         (exit-emacs)
  97     )
  98
  99     (&mh-xkill exists action name msgg
 100         (message "K: kill a folder, erasing all of its contents...")
 101         (setq exists 0)
 102         (setq msgg "K: kill a folder, erasing all of its contents...which folder? ")
 103         (while (! exists)
 104                (setq name (get-tty-string msgg))
 105                (if (= 0 (length name))
 106                    (progn
 107                           (message "Aborted.") (sit-for 5)
 108                           (exit-emacs)))
 109                (if (!= (string-to-char (substr name 1 1)) '/')
 110                    (setq t-buffer-filename (concat mh-path "/" name))
 111                    (setq t-buffer-filename name)
 112                )
 113                (setq exists (file-exists t-buffer-filename))
 114                (if (= exists 0)
 115                           (setq msgg (concat "Folder +" name " does not exist. Try another name? "))
 116                )
 117         )
 118         (setq action
 119               (get-response (concat "Do you really want to destroy folder +"
 120                                     name " and all its contents? ")
 121                   "yYnN\3" "Please answer y or n"))
 122         (if (= name "inbox")
 123             (setq action
 124                   (get-response "That's your one and only inbox you are asking me to destroy. Still sure? "
 125                       "yYnN\3" "Please answer y or n: destroy inbox??? ")))
 126         (if (= action 'y')
 127             (progn
 128                    (send-to-shell (concat "rmf +" name))
 129                    (message "OK, the deed is done... +" name " destroyed.")
 130             )
 131             (message "Nothing has been destroyed.")
 132         )
 133         (sit-for 10)
 134         (exit-emacs)
 135     )
 136 )