![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to electric.el CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 43BSDReno / contrib / emacs-18.55 / lisp|
Return to electric.el CVS log | Up to [CSRG BSD Unix] / 43BSDReno / contrib / emacs-18.55 / lisp |
1.1 ! root 1: ;; electric -- Window maker and Command loop for `electric' modes. ! 2: ;; Copyright (C) 1985, 1986 Free Software Foundation, Inc. ! 3: ;; Principal author K. Shane Hartman ! 4: ! 5: ;; This file is part of GNU Emacs. ! 6: ! 7: ;; GNU Emacs is distributed in the hope that it will be useful, ! 8: ;; but WITHOUT ANY WARRANTY. No author or distributor ! 9: ;; accepts responsibility to anyone for the consequences of using it ! 10: ;; or for whether it serves any particular purpose or works at all, ! 11: ;; unless he says so in writing. Refer to the GNU Emacs General Public ! 12: ;; License for full details. ! 13: ! 14: ;; Everyone is granted permission to copy, modify and redistribute ! 15: ;; GNU Emacs, but only under the conditions described in the ! 16: ;; GNU Emacs General Public License. A copy of this license is ! 17: ;; supposed to have been given to you along with GNU Emacs so you ! 18: ;; can know your rights and responsibilities. It should be in a ! 19: ;; file named COPYING. Among other things, the copyright notice ! 20: ;; and this notice must be preserved on all copies. ! 21: ! 22: ! 23: (provide 'electric) ; zaaaaaaap ! 24: ! 25: ;; perhaps this should be in subr.el... ! 26: (defun shrink-window-if-larger-than-buffer (window) ! 27: (save-excursion ! 28: (set-buffer (window-buffer window)) ! 29: (let ((w (selected-window)) ;save-window-excursion can't win ! 30: (buffer-file-name buffer-file-name) ! 31: (p (point)) ! 32: (n 0) ! 33: (window-min-height 0) ! 34: (buffer-read-only nil) ! 35: (modified (buffer-modified-p))) ! 36: (unwind-protect ! 37: (progn ! 38: (select-window window) ! 39: (goto-char (point-min)) ! 40: (while (pos-visible-in-window-p (point-max)) ! 41: ;; defeat file locking... don't try this at home, kids! ! 42: (setq buffer-file-name nil) ! 43: (insert ?\n) (setq n (1+ n))) ! 44: (if (> n 0) (shrink-window (1- n)))) ! 45: (delete-region (point-min) (point)) ! 46: (set-buffer-modified-p modified) ! 47: (goto-char p) ! 48: (select-window w))))) ! 49: ! 50: ! 51: ;; This loop is the guts for non-standard modes which retain control ! 52: ;; until some event occurs. It is a `do-forever', the only way out is to ! 53: ;; throw. It assumes that you have set up the keymap, window, and ! 54: ;; everything else: all it does is read commands and execute them - ! 55: ;; providing error messages should one occur (if there is no loop ! 56: ;; function - which see). The required argument is a tag which should ! 57: ;; expect a value of nil if the user decides to punt. The ! 58: ;; second argument is a prompt string (defaults to "->"). Given third ! 59: ;; argument non-nil, it INHIBITS quitting unless the user types C-g at ! 60: ;; toplevel. This is so user can do things like C-u C-g and not get ! 61: ;; thrown out. Fourth argument, if non-nil, should be a function of two ! 62: ;; arguments which is called after every command is executed. The fifth ! 63: ;; argument, if provided, is the state variable for the function. If the ! 64: ;; loop-function gets an error, the loop will abort WITHOUT throwing ! 65: ;; (moral: use unwind-protect around call to this function for any ! 66: ;; critical stuff). The second argument for the loop function is the ! 67: ;; conditions for any error that occurred or nil if none. ! 68: ! 69: (defun Electric-command-loop (return-tag ! 70: &optional prompt inhibit-quit ! 71: loop-function loop-state) ! 72: (if (not prompt) (setq prompt "->")) ! 73: (let (cmd (err nil)) ! 74: (while t ! 75: (setq cmd (read-key-sequence (if (stringp prompt) ! 76: prompt (funcall prompt)))) ! 77: (setq last-command-char (aref cmd (1- (length cmd))) ! 78: this-command (key-binding cmd) ! 79: cmd this-command) ! 80: (if (or (prog1 quit-flag (setq quit-flag nil)) ! 81: (= last-input-char ?\C-g)) ! 82: (progn (setq unread-command-char -1 ! 83: prefix-arg nil) ! 84: ;; If it wasn't cancelling a prefix character, then quit. ! 85: (if (or (= (length (this-command-keys)) 1) ! 86: (not inhibit-quit)) ; safety ! 87: (progn (ding) ! 88: (message "Quit") ! 89: (throw return-tag nil)) ! 90: (setq cmd nil)))) ! 91: (setq current-prefix-arg prefix-arg) ! 92: (if cmd ! 93: (condition-case conditions ! 94: (progn (command-execute cmd) ! 95: (if (or (prog1 quit-flag (setq quit-flag nil)) ! 96: (= last-input-char ?\C-g)) ! 97: (progn (setq unread-command-char -1) ! 98: (if (not inhibit-quit) ! 99: (progn (ding) ! 100: (message "Quit") ! 101: (throw return-tag nil)) ! 102: (ding))))) ! 103: (buffer-read-only (if loop-function ! 104: (setq err conditions) ! 105: (ding) ! 106: (message "Buffer is read-only") ! 107: (sit-for 2))) ! 108: (beginning-of-buffer (if loop-function ! 109: (setq err conditions) ! 110: (ding) ! 111: (message "Beginning of Buffer") ! 112: (sit-for 2))) ! 113: (end-of-buffer (if loop-function ! 114: (setq err conditions) ! 115: (ding) ! 116: (message "End of Buffer") ! 117: (sit-for 2))) ! 118: (error (if loop-function ! 119: (setq err conditions) ! 120: (ding) ! 121: (message "Error: %s" ! 122: (if (eq (car conditions) 'error) ! 123: (car (cdr conditions)) ! 124: (prin1-to-string conditions))) ! 125: (sit-for 2)))) ! 126: (ding)) ! 127: (if loop-function (funcall loop-function loop-state err)))) ! 128: (ding) ! 129: (throw return-tag nil)) ! 130: ! 131: ;; This function is like pop-to-buffer, sort of. ! 132: ;; The algorithm is ! 133: ;; If there is a window displaying buffer ! 134: ;; Select it ! 135: ;; Else if there is only one window ! 136: ;; Split it, selecting the window on the bottom with height being ! 137: ;; the lesser of max-height (if non-nil) and the number of lines in ! 138: ;; the buffer to be displayed subject to window-min-height constraint. ! 139: ;; Else ! 140: ;; Switch to buffer in the current window. ! 141: ;; ! 142: ;; Then if max-height is nil, and not all of the lines in the buffer ! 143: ;; are displayed, grab the whole screen. ! 144: ;; ! 145: ;; Returns selected window on buffer positioned at point-min. ! 146: ! 147: (defun Electric-pop-up-window (buffer &optional max-height) ! 148: (let* ((win (or (get-buffer-window buffer) (selected-window))) ! 149: (buf (get-buffer buffer)) ! 150: (one-window (one-window-p t)) ! 151: (pop-up-windows t) ! 152: (target-height) ! 153: (lines)) ! 154: (if (not buf) ! 155: (error "Buffer %s does not exist" buffer) ! 156: (save-excursion ! 157: (set-buffer buf) ! 158: (setq lines (count-lines (point-min) (point-max))) ! 159: (setq target-height ! 160: (min (max (if max-height (min max-height (1+ lines)) (1+ lines)) ! 161: window-min-height) ! 162: (save-window-excursion ! 163: (delete-other-windows) ! 164: (1- (window-height (selected-window))))))) ! 165: (cond ((and (eq (window-buffer win) buf)) ! 166: (select-window win)) ! 167: (one-window ! 168: (goto-char (window-start win)) ! 169: (pop-to-buffer buffer) ! 170: (setq win (selected-window)) ! 171: (enlarge-window (- target-height (window-height win)))) ! 172: (t ! 173: (switch-to-buffer buf))) ! 174: (if (and (not max-height) ! 175: (> target-height (window-height (selected-window)))) ! 176: (progn (goto-char (window-start win)) ! 177: (enlarge-window (- target-height (window-height win))))) ! 178: (goto-char (point-min)) ! 179: win)))
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.