Return to mh-e.ml CVS log

Up to [CSRG BSD Unix] / 43BSD / contrib / mh / miscellany / mhe

Annotation of 43BSD/contrib/mh/miscellany/mhe/mh-e.ml, revision 1.1

1.1     ! root        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 ""))
        !           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\"
        !           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")

This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.