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