![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to x-menu.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 x-menu.el CVS log | Up to [CSRG BSD Unix] / 43BSDReno / contrib / emacs-18.55 / lisp |
1.1 ! root 1: ;; Copyright (C) 1986 Free Software Foundation, Inc. ! 2: ! 3: ;; This file is part of GNU Emacs. ! 4: ! 5: ;; GNU Emacs is distributed in the hope that it will be useful, ! 6: ;; but WITHOUT ANY WARRANTY. No author or distributor ! 7: ;; accepts responsibility to anyone for the consequences of using it ! 8: ;; or for whether it serves any particular purpose or works at all, ! 9: ;; unless he says so in writing. Refer to the GNU Emacs General Public ! 10: ;; License for full details. ! 11: ! 12: ;; Everyone is granted permission to copy, modify and redistribute ! 13: ;; GNU Emacs, but only under the conditions described in the ! 14: ;; GNU Emacs General Public License. A copy of this license is ! 15: ;; supposed to have been given to you along with GNU Emacs so you ! 16: ;; can know your rights and responsibilities. It should be in a ! 17: ;; file named COPYING. Among other things, the copyright notice ! 18: ;; and this notice must be preserved on all copies. ! 19: ! 20: ! 21: (defmacro caar (conscell) ! 22: (list 'car (list 'car conscell))) ! 23: ! 24: (defmacro cdar (conscell) ! 25: (list 'cdr (list 'car conscell))) ! 26: ! 27: (defun x-menu-mode () ! 28: "Major mode for creating permanent menus for use with X. ! 29: These menus are implemented entirely in Lisp; popup menus, implemented ! 30: with x-popup-menu, are implemented using XMenu primitives." ! 31: (make-local-variable 'x-menu-items-per-line) ! 32: (make-local-variable 'x-menu-item-width) ! 33: (make-local-variable 'x-menu-items-alist) ! 34: (make-local-variable 'x-process-mouse-hook) ! 35: (make-local-variable 'x-menu-assoc-buffer) ! 36: (setq buffer-read-only t) ! 37: (setq truncate-lines t) ! 38: (setq x-process-mouse-hook 'x-menu-pick-entry) ! 39: (setq mode-line-buffer-identification '("MENU: %32b"))) ! 40: ! 41: (defvar x-menu-max-width 0) ! 42: (defvar x-menu-items-per-line 0) ! 43: (defvar x-menu-item-width 0) ! 44: (defvar x-menu-items-alist nil) ! 45: (defvar x-menu-assoc-buffer nil) ! 46: ! 47: (defvar x-menu-item-spacing 1 ! 48: "*Minimum horizontal spacing between objects in a permanent X menu.") ! 49: ! 50: (defun x-menu-create-menu (name) ! 51: "Create a permanent X menu. Returns an item which should be used as a ! 52: menu object whenever referring to the menu." ! 53: (let ((old (current-buffer)) ! 54: (buf (get-buffer-create name))) ! 55: (set-buffer buf) ! 56: (x-menu-mode) ! 57: (setq x-menu-assoc-buffer old) ! 58: (set-buffer old) ! 59: buf)) ! 60: ! 61: (defun x-menu-change-associated-buffer (menu buffer) ! 62: "Change associated buffer of MENU to BUFFER. BUFFER should be a buffer ! 63: object." ! 64: (let ((old (current-buffer))) ! 65: (set-buffer menu) ! 66: (setq x-menu-assoc-buffer buffer) ! 67: (set-buffer old))) ! 68: ! 69: (defun x-menu-add-item (menu item binding) ! 70: "Adds to MENU an item with name ITEM, associated with BINDING. ! 71: Following a sequence of calls to x-menu-add-item, a call to x-menu-compute ! 72: should be performed before the menu will be made available to the user. ! 73: ! 74: BINDING should be a function of one argument, which is the numerical ! 75: button/key code as defined in x-menu.el." ! 76: (let ((old (current-buffer)) ! 77: elt) ! 78: (set-buffer menu) ! 79: (if (setq elt (assoc item x-menu-items-alist)) ! 80: (rplacd elt binding) ! 81: (setq x-menu-items-alist (append x-menu-items-alist ! 82: (list (cons item binding))))) ! 83: (set-buffer old) ! 84: item)) ! 85: ! 86: (defun x-menu-delete-item (menu item) ! 87: "Deletes from MENU the item named ITEM. x-menu-compute should be called ! 88: before the menu is made available to the user." ! 89: (let ((old (current-buffer)) ! 90: elt) ! 91: (set-buffer menu) ! 92: (if (setq elt (assoc item x-menu-items-alist)) ! 93: (rplaca elt nil)) ! 94: (set-buffer old) ! 95: item)) ! 96: ! 97: (defun x-menu-activate (menu) ! 98: "Computes all necessary parameters for MENU. This must be called whenever ! 99: a menu is modified before it is made available to the user. ! 100: ! 101: This also creates the menu itself." ! 102: (let ((buf (current-buffer))) ! 103: (pop-to-buffer menu) ! 104: (let (buffer-read-only) ! 105: (setq x-menu-max-width (1- (screen-width))) ! 106: (setq x-menu-item-width 0) ! 107: (let (items-head ! 108: (items-tail x-menu-items-alist)) ! 109: (while items-tail ! 110: (if (caar items-tail) ! 111: (progn (setq items-head (cons (car items-tail) items-head)) ! 112: (setq x-menu-item-width ! 113: (max x-menu-item-width ! 114: (length (caar items-tail)))))) ! 115: (setq items-tail (cdr items-tail))) ! 116: (setq x-menu-items-alist (reverse items-head))) ! 117: (setq x-menu-item-width (+ x-menu-item-spacing x-menu-item-width)) ! 118: (setq x-menu-items-per-line ! 119: (max 1 (/ x-menu-max-width x-menu-item-width))) ! 120: (erase-buffer) ! 121: (let ((items-head x-menu-items-alist)) ! 122: (while items-head ! 123: (let ((items 0)) ! 124: (while (and items-head ! 125: (<= (setq items (1+ items)) x-menu-items-per-line)) ! 126: (insert (format (concat "%" ! 127: (int-to-string x-menu-item-width) "s") ! 128: (caar items-head))) ! 129: (setq items-head (cdr items-head)))) ! 130: (insert ?\n))) ! 131: (shrink-window (max 0 ! 132: (- (window-height) ! 133: (1+ (count-lines (point-min) (point-max)))))) ! 134: (goto-char (point-min))) ! 135: (pop-to-buffer buf))) ! 136: ! 137: (defun x-menu-pick-entry (position event) ! 138: "Internal function for dispatching on mouse/menu events" ! 139: (let* ((x (min (1- x-menu-items-per-line) ! 140: (/ (current-column) x-menu-item-width))) ! 141: (y (- (count-lines (point-min) (point)) ! 142: (if (zerop (current-column)) 0 1))) ! 143: (item (+ x (* y x-menu-items-per-line))) ! 144: (litem (cdr (nth item x-menu-items-alist)))) ! 145: (and litem (funcall litem event))) ! 146: (pop-to-buffer x-menu-assoc-buffer))
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.