Return to electric.el CVS log

Up to [CSRG BSD Unix] / 43BSD / contrib / emacs / lisp

Annotation of 43BSD/contrib/emacs/lisp/electric.el, revision 1.1

1.1     ! root        1: ;; electric -- Window maker and Command loop for `electric' modes.
        !             2: ;; adapted by shane after mly
        !             3: 
        !             4: ;; Copyright (C) 1985 Richard M. Stallman and K. Shane Hartman
        !             5: 
        !             6: ;; This file is part of GNU Emacs.
        !             7: 
        !             8: ;; GNU Emacs is distributed in the hope that it will be useful,
        !             9: ;; but WITHOUT ANY WARRANTY.  No author or distributor
        !            10: ;; accepts responsibility to anyone for the consequences of using it
        !            11: ;; or for whether it serves any particular purpose or works at all,
        !            12: ;; unless he says so in writing.  Refer to the GNU Emacs General Public
        !            13: ;; License for full details.
        !            14: 
        !            15: ;; Everyone is granted permission to copy, modify and redistribute
        !            16: ;; GNU Emacs, but only under the conditions described in the
        !            17: ;; GNU Emacs General Public License.   A copy of this license is
        !            18: ;; supposed to have been given to you along with GNU Emacs so you
        !            19: ;; can know your rights and responsibilities.  It should be in a
        !            20: ;; file named COPYING.  Among other things, the copyright notice
        !            21: ;; and this notice must be preserved on all copies.
        !            22: 
        !            23: 
        !            24: (provide 'electric)                           ; zaaaaaaap
        !            25: 
        !            26: ;; This loop is the guts for non-standard modes which retain control
        !            27: ;; until some event occurs.  It is a `do-forever', the only way out is to
        !            28: ;; throw.  It assumes that you have set up the keymap, window, and
        !            29: ;; everything else: all it does is read commands and execute them -
        !            30: ;; providing error messages should one occur (if there is no loop
        !            31: ;; function - which see).  The required argument is a tag which should
        !            32: ;; expect a value of nil if the user decides to punt.  The user is
        !            33: ;; offered a chance to flush the loop by typing Space as the very first
        !            34: ;; character.  Thereafter Space is just a normal character.  The
        !            35: ;; second argument is a prompt string (defaults to "->").  Given third
        !            36: ;; argument non-nil, it INHIBITS quitting unless the user types C-g at
        !            37: ;; toplevel.  This is so user can do things like C-u C-g and not get
        !            38: ;; thrown out.  Fourth argument, if non-nil, should be a function of two
        !            39: ;; arguments which is called after every command is executed.  The fifth
        !            40: ;; argument, if provided, is the state variable for the function.  If the
        !            41: ;; loop-function gets an error, the loop will abort WITHOUT throwing
        !            42: ;; (moral: use unwind-protect around call to this function for any
        !            43: ;; critical stuff).  The second argument for the loop function is the
        !            44: ;; conditions for any error that occurred or nil if none.
        !            45: 
        !            46: (defun Electric-command-loop (return-tag &optional prompt inhibit-quit
        !            47:                                         loop-function loop-state)
        !            48:   (if (not prompt) (setq prompt "->"))
        !            49:   (message "<<< Type Space to flush >>>")
        !            50:   (let ((cmd (read-char))
        !            51:        (err))
        !            52:     (if (memq cmd '(?\ ?\C-g))
        !            53:        (throw return-tag nil)
        !            54:       (setq unread-command-char cmd cmd nil))
        !            55:     (while t
        !            56:       (setq cmd (read-key-sequence prompt))
        !            57:       (setq last-command-char (aref cmd (1- (length cmd)))
        !            58:            this-command (key-binding cmd)
        !            59:            cmd this-command)
        !            60:       (if (or (prog1 quit-flag (setq quit-flag nil))
        !            61:              (= last-input-char ?\C-g))
        !            62:          (progn (setq unread-command-char -1
        !            63:                       prefix-arg nil)
        !            64:                 ;; If it wasn't cancelling a prefix character, then quit.
        !            65:                 (if (or (= (length (this-command-keys)) 1)
        !            66:                         (not inhibit-quit)); safety
        !            67:                     (progn (ding)
        !            68:                            (message "Quit")
        !            69:                            (throw return-tag nil))
        !            70:                   (setq cmd nil))))
        !            71:       (setq current-prefix-arg prefix-arg)
        !            72:       (if cmd
        !            73:          (condition-case conditions
        !            74:              (progn (command-execute cmd)
        !            75:                     (if (or (prog1 quit-flag (setq quit-flag nil))
        !            76:                             (= last-input-char ?\C-g))
        !            77:                         (progn (setq unread-command-char -1)
        !            78:                                (if (not inhibit-quit)
        !            79:                                    (progn (ding)
        !            80:                                           (message "Quit")
        !            81:                                           (throw return-tag nil))
        !            82:                                  (ding)))))
        !            83:            (buffer-read-only (if loop-function
        !            84:                                  (setq err conditions)
        !            85:                                (ding)
        !            86:                                (message "Buffer is read-only")
        !            87:                                (sit-for 2)))
        !            88:            (beginning-of-buffer (if loop-function
        !            89:                                     (setq err conditions)
        !            90:                                   (ding)
        !            91:                                   (message "Beginning of Buffer")
        !            92:                                   (sit-for 2)))
        !            93:            (end-of-buffer (if loop-function
        !            94:                               (setq err conditions)
        !            95:                             (ding)
        !            96:                             (message "End of Buffer")
        !            97:                             (sit-for 2)))
        !            98:            (error (if loop-function
        !            99:                       (setq err conditions)
        !           100:                     (ding)
        !           101:                     (message "%s" (or (car (cdr conditions)) "Huh?"))
        !           102:                     (sit-for 2))))
        !           103:        (ding))
        !           104:       (if loop-function (funcall loop-function loop-state err))))
        !           105:   (ding)
        !           106:   (throw return-tag nil))
        !           107: 
        !           108: ;; This function is like pop-to-buffer, sort of. 
        !           109: ;; The algorithm is
        !           110: ;; If there is a window displaying buffer
        !           111: ;;     Select it
        !           112: ;; Else if there is only one window
        !           113: ;;     Split it, selecting the window on the bottom with height being
        !           114: ;;     the lesser of max-height (if non-nil) and the number of lines in
        !           115: ;;      the buffer to be displayed subject to window-min-height constraint.
        !           116: ;; Else
        !           117: ;;     Switch to buffer in the current window.
        !           118: ;;
        !           119: ;; Then if max-height is nil, and not all of the lines in the buffer
        !           120: ;; are displayed, grab the whole screen.
        !           121: ;;
        !           122: ;; Returns selected window on buffer positioned at point-min.
        !           123: 
        !           124: (defun Electric-pop-up-window (buffer &optional max-height)
        !           125:   (let* ((win (or (get-buffer-window buffer) (selected-window)))
        !           126:         (buf (get-buffer buffer))
        !           127:         (one-window (eq win (next-window)))
        !           128:         (pop-up-windows t)
        !           129:         (target-height)
        !           130:         (lines))
        !           131:     (if (not buf)
        !           132:        (error "Buffer %s does not exist" buffer)
        !           133:       (save-excursion
        !           134:        (set-buffer buf)
        !           135:        (setq lines (count-lines (point-min) (point-max)))
        !           136:        (setq target-height
        !           137:              (min (max (if max-height (min max-height (1+ lines)) (1+ lines))
        !           138:                        window-min-height)
        !           139:                   (save-window-excursion
        !           140:                     (delete-other-windows)
        !           141:                     (1- (window-height (selected-window)))))))
        !           142:       (cond ((and (eq (window-buffer win) buf))
        !           143:             (select-window win))
        !           144:            (one-window
        !           145:             (goto-char (window-start win))
        !           146:             (pop-to-buffer buffer)
        !           147:             (setq win (selected-window))
        !           148:             (enlarge-window (- target-height (window-height win))))
        !           149:            (t
        !           150:             (switch-to-buffer buf)))
        !           151:       (if (and (not max-height)
        !           152:               (> target-height (window-height (selected-window))))
        !           153:          (progn (goto-char (window-start win))
        !           154:                 (enlarge-window (- target-height (window-height win)))))
        !           155:       (goto-char (point-min))
        !           156:       win)))

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