Mercurial > emacs
changeset 39022:9a10bb9ac325
*** empty log message ***
| author | Gerd Moellmann <gerd@gnu.org> |
|---|---|
| date | Thu, 30 Aug 2001 07:36:15 +0000 |
| parents | b2a0a21002ae |
| children | c0daac54d3e1 |
| files | lisp/ChangeLog lisp/obsolete/rsz-mini.el lisp/obsolete/sun-curs.el lisp/obsolete/sun-fns.el lisp/obsolete/x-apollo.el lisp/obsolete/x-menu.el |
| diffstat | 6 files changed, 1198 insertions(+), 0 deletions(-) [+] |
line wrap: on
line diff
--- a/lisp/ChangeLog Thu Aug 30 07:34:39 2001 +0000 +++ b/lisp/ChangeLog Thu Aug 30 07:36:15 2001 +0000 @@ -1,3 +1,8 @@ +2001-08-30 Gerd Moellmann <gerd@gnu.org> + + * obsolete/rsz-mini.el, obsolete/sun-curs.el, obsolete/sun-fns.el + * obsolete/x-apollo.el, obsolete/x-menu.el: Moved here from lisp/. + 2001-08-30 Eli Zaretskii <eliz@is.elta.co.il> * toolbar/tool-bar.el (tool-bar-mode): Make it a no-op if images
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/obsolete/rsz-mini.el Thu Aug 30 07:36:15 2001 +0000 @@ -0,0 +1,84 @@ +;;; rsz-mini.el --- dynamically resize minibuffer to display entire contents + +;; Copyright (C) 1990, 1993, 1994, 1995, 1997 Free Software Foundation, Inc. + +;; Author: Noah Friedman <friedman@splode.com> +;; Roland McGrath <roland@gnu.org> +;; Maintainer: Noah Friedman <friedman@splode.com> +;; Keywords: minibuffer, window, frame, display + +;; $Id: rsz-mini.el,v 1.29 2001/07/16 12:22:59 pj Exp $ + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;; This package is obsolete. Emacs now resizes mini-windows +;; automatically. + +;;; Code: + + +(defgroup resize-minibuffer nil + "This customization group is obsolete." + :group 'frames) + +;;;###autoload +(defcustom resize-minibuffer-mode nil + "*This variable is obsolete." + :type 'boolean + :group 'resize-minibuffer + :require 'rsz-mini) + +;;;###autoload +(defcustom resize-minibuffer-window-max-height nil + "*This variable is obsolete." + :type '(choice (const nil) integer) + :group 'resize-minibuffer) + +;;;###autoload +(defcustom resize-minibuffer-window-exactly t + "*This variable is obsolete." + :type 'boolean + :group 'resize-minibuffer) + +;;;###autoload +(defcustom resize-minibuffer-frame nil + "*This variable is obsolete." + :type 'boolean + :group 'resize-minibuffer) + +;;;###autoload +(defcustom resize-minibuffer-frame-max-height nil + "*This variable is obsolete.") + +;;;###autoload +(defcustom resize-minibuffer-frame-exactly t + "*This variable is obsolete." + :type 'boolean + :group 'resize-minibuffer) + + +;;;###autoload +(defun resize-minibuffer-mode (&optional prefix) + "This function is obsolete." + (interactive "P")) + +(provide 'rsz-mini) + +;;; rsz-mini.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/obsolete/sun-curs.el Thu Aug 30 07:36:15 2001 +0000 @@ -0,0 +1,221 @@ +;;; sun-curs.el --- cursor definitions for Sun windows + +;; Copyright (C) 1987 Free Software Foundation, Inc. + +;; Author: Jeff Peck <peck@sun.com> +;; Keywords: hardware + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;;; Code: + +;;; +;;; Added some more cursors and moved the hot spots +;;; Cursor defined by 16 pairs of 16-bit numbers +;;; +;;; 9-dec-86 Jeff Peck, Sun Microsystems Inc. <peck@sun.com> + +(eval-when-compile (require 'cl)) +(require 'sun-fns) + +(eval-and-compile + (defvar sc::cursors nil "List of known cursors")) + +(defmacro defcursor (name x y string) + (if (not (memq name sc::cursors)) + (setq sc::cursors (cons name sc::cursors))) + (list 'defconst name (list 'vector x y string))) + +;;; push should be defined in common lisp, but if not use this: +;(defmacro push (v l) +; "The ITEM is evaluated and consed onto LIST, a list-valued atom" +; (list 'setq l (list 'cons v l))) + +;;; +;;; The standard default cursor +;;; +(defcursor sc:right-arrow 15 0 + (concat '(0 1 0 3 0 7 0 15 0 31 0 63 0 127 0 15 + 0 27 0 25 0 48 0 48 0 96 0 96 0 192 0 192))) + +;;(sc:set-cursor sc:right-arrow) + +(defcursor sc:fat-left-arrow 0 8 + (concat '(1 0 3 0 7 0 15 0 31 0 63 255 127 255 255 255 + 255 255 127 255 63 255 31 0 15 0 7 0 3 0 1 0))) + +(defcursor sc:box 8 8 + (concat '(15 252 8 4 8 4 8 4 8 4 8 4 8 4 8 4 + 8 132 8 4 8 4 8 4 8 4 8 4 8 4 15 252))) + +(defcursor sc:hourglass 8 8 + (concat "\177\376\100\002\040\014\032\070" + "\017\360\007\340\003\300\001\200" + "\001\200\002\100\005\040\010\020" + "\021\210\043\304\107\342\177\376")) + +(defun sc:set-cursor (icon) + "Change the Sun mouse cursor to ICON. +If ICON is nil, switch to the system default cursor, +Otherwise, ICON should be a vector or the name of a vector of [x y 32-chars]" + (interactive "XIcon Name: ") + (if (symbolp icon) (setq icon (symbol-value icon))) + (sun-change-cursor-icon icon)) + +(make-local-variable '*edit-icon*) +(make-variable-buffer-local 'icon-edit) +(setq-default icon-edit nil) +(or (assq 'icon-edit minor-mode-alist) + (push '(icon-edit " IconEdit") minor-mode-alist)) + +(defun sc:edit-cursor (icon) + "convert icon to rectangle, edit, and repack" + (interactive "XIcon Name: ") + (if (not icon) (setq icon (sc::menu-choose-cursor (selected-window) 1 1))) + (if (symbolp icon) (setq icon (symbol-value icon))) + (if (get-buffer "icon-edit") (kill-buffer "icon-edit")) + (switch-to-buffer "icon-edit") + (local-set-mouse '(text right) 'sc::menu-function) + (local-set-mouse '(text left) '(sc::pic-ins-at-mouse 32)) + (local-set-mouse '(text middle) '(sc::pic-ins-at-mouse 64)) + (local-set-mouse '(text left middle) 'sc::hotspot) + (sc::display-icon icon) + (picture-mode) + (setq icon-edit t) ; for mode line display +) + +(defun sc::pic-ins-at-mouse (char) + "Picture insert char at mouse location" + (mouse-move-point *mouse-window* (min 15 *mouse-x*) (min 15 *mouse-y*)) + (move-to-column (1+ (min 15 (current-column))) t) + (delete-char -1) + (insert char) + (sc::goto-hotspot)) + +(defun sc::menu-function (window x y) + (sun-menu-evaluate window (1+ x) y sc::menu)) + +(defmenu sc::menu + ("Cursor Menu") + ("Pack & Use" sc::pack-buffer-to-cursor) + ("Pack to Icon" sc::pack-buffer-to-icon + (sc::menu-choose-cursor *menu-window* *menu-x* *menu-y*)) + ("New Icon" call-interactively 'sc::make-cursor) + ("Edit Icon" sc:edit-cursor + (sc::menu-choose-cursor *menu-window* *menu-x* *menu-y*)) + ("Set Cursor" sc:set-cursor + (sc::menu-choose-cursor *menu-window* *menu-x* *menu-y*)) + ("Reset Cursor" sc:set-cursor nil) + ("Help" sc::edit-icon-help-menu) + ("Quit" sc::quit-edit) + ) + +(defun sc::quit-edit () + (interactive) + (bury-buffer (current-buffer)) + (switch-to-buffer (other-buffer) 'no-record)) + +(defun sc::make-cursor (symbol) + (interactive "SIcon Name: ") + (eval (list 'defcursor symbol 0 0 "")) + (sc::pack-buffer-to-icon (symbol-value symbol))) + +(defmenu sc::edit-icon-help-menu + ("Simple Icon Editor") + ("Left => CLEAR") + ("Middle => SET") + ("L & M => HOTSPOT") + ("Right => MENU")) + +(defun sc::edit-icon-help () + (message "Left=> CLEAR Middle=> SET Left+Middle=> HOTSPOT Right=> MENU")) + +(defun sc::pack-buffer-to-cursor () + (sc::pack-buffer-to-icon *edit-icon*) + (sc:set-cursor *edit-icon*)) + +(defun sc::menu-choose-cursor (window x y) + "Presents a menu of cursor names, and returns one or nil" + (let ((curs sc::cursors) + (items)) + (while curs + (push (sc::menu-item-for-cursor (car curs)) items) + (setq curs (cdr curs))) + (push (list "Choose Cursor") items) + (setq menu (menu-create items)) + (sun-menu-evaluate window x y menu))) + +(defun sc::menu-item-for-cursor (cursor) + "apply function to selected cursor" + (list (symbol-name cursor) 'quote cursor)) + +(defun sc::hotspot (window x y) + (aset *edit-icon* 0 x) + (aset *edit-icon* 1 y) + (sc::goto-hotspot)) + +(defun sc::goto-hotspot () + (goto-line (1+ (aref *edit-icon* 1))) + (move-to-column (aref *edit-icon* 0))) + +(defun sc::display-icon (icon) + (setq *edit-icon* (copy-sequence icon)) + (let ((string (aref *edit-icon* 2)) + (index 0)) + (while (< index 32) + (let ((char (aref string index)) + (bit 128)) + (while (> bit 0) + (insert (sc::char-at-bit char bit)) + (setq bit (lsh bit -1)))) + (if (eq 1 (% index 2)) (newline)) + (setq index (1+ index)))) + (sc::goto-hotspot)) + +(defun sc::char-at-bit (char bit) + (if (> (logand char bit) 0) "@" " ")) + +(defun sc::pack-buffer-to-icon (icon) + "Pack 16 x 16 field into icon string" + (goto-char (point-min)) + (aset icon 0 (aref *edit-icon* 0)) + (aset icon 1 (aref *edit-icon* 1)) + (aset icon 2 (mapconcat 'sc::pack-one-line "1234567890123456" "")) + (sc::goto-hotspot) + ) + +(defun sc::pack-one-line (dummy) + (let* (char chr1 chr2) + (setq char 0 chr1 (mapconcat 'sc::pack-one-char "12345678" "") chr1 char) + (setq char 0 chr2 (mapconcat 'sc::pack-one-char "12345678" "") chr2 char) + (forward-line 1) + (concat (char-to-string chr1) (char-to-string chr2)) + )) + +(defun sc::pack-one-char (dummy) + "pack following char into char, unless eolp" + (if (or (eolp) (char-equal (following-char) 32)) + (setq char (lsh char 1)) + (setq char (1+ (lsh char 1)))) + (if (not (eolp))(forward-char))) + +(provide 'sun-curs) + +;;; sun-curs.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/obsolete/sun-fns.el Thu Aug 30 07:36:15 2001 +0000 @@ -0,0 +1,643 @@ +;;; sun-fns.el --- subroutines of Mouse handling for Sun windows + +;; Copyright (C) 1987 Free Software Foundation, Inc. + +;; Author: Jeff Peck <peck@sun.com> +;; Maintainer: none +;; Keywords: hardware + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;; Submitted Mar. 1987, Jeff Peck +;; Sun Microsystems Inc. <peck@sun.com> +;; Conceived Nov. 1986, Stan Jefferson, +;; Computer Science Lab, SRI International. +;; GoodIdeas Feb. 1987, Steve Greenbaum +;; & UpClicks Reasoning Systems, Inc. +;; +;; +;; Functions for manipulating via the mouse and mouse-map definitions +;; for accessing them. Also definitions of mouse menus. +;; This file you should freely modify to reflect you personal tastes. +;; +;; First half of file defines functions to implement mouse commands, +;; Don't delete any of those, just add what ever else you need. +;; Second half of file defines mouse bindings, do whatever you want there. + +;; +;; Mouse Functions. +;; +;; These functions follow the sun-mouse-handler convention of being called +;; with three arguments: (window x-pos y-pos) +;; This makes it easy for a mouse executed command to know where the mouse is. +;; Use the macro "eval-in-window" to execute a function +;; in a temporarily selected window. +;; +;; If you have a function that must be called with other arguments +;; bind the mouse button to an s-exp that contains the necessary parameters. +;; See "minibuffer" bindings for examples. +;; + +;;; Code: + +(require 'term/sun-mouse) + +(defconst cursor-pause-milliseconds 300 + "*Number of milliseconds to display alternate cursor (usually the mark)") + +(defun indicate-region (&optional pause) + "Bounce cursor to mark for cursor-pause-milliseconds and back again" + (or pause (setq pause cursor-pause-milliseconds)) + (let ((point (point))) + (goto-char (mark)) + (sit-for-millisecs pause) + ;(update-display) + ;(sleep-for-millisecs pause) + (goto-char point))) + + +;;; +;;; Text buffer operations +;;; +(defun mouse-move-point (window x y) + "Move point to mouse cursor." + (select-window window) + (move-to-loc x y) + (if (memq last-command ; support the mouse-copy/delete/yank + '(mouse-copy mouse-delete mouse-yank-move)) + (setq this-command 'mouse-yank-move)) + ) + +(defun mouse-set-mark (window x y) + "Set mark at mouse cursor." + (eval-in-window window ;; use this to get the unwind protect + (let ((point (point))) + (move-to-loc x y) + (set-mark (point)) + (goto-char point) + (indicate-region))) + ) + +(defun mouse-set-mark-and-select (window x y) + "Set mark at mouse cursor, and select that window." + (select-window window) + (mouse-set-mark window x y) + ) + +(defun mouse-set-mark-and-stuff (w x y) + "Set mark at mouse cursor, and put region in stuff buffer." + (mouse-set-mark-and-select w x y) + (sun-select-region (region-beginning) (region-end))) + +;;; +;;; Simple mouse dragging stuff: marking with button up +;;; + +(defvar *mouse-drag-window* nil) +(defvar *mouse-drag-x* -1) +(defvar *mouse-drag-y* -1) + +(defun mouse-drag-move-point (window x y) + "Move point to mouse cursor, and allow dragging." + (mouse-move-point window x y) + (setq *mouse-drag-window* window + *mouse-drag-x* x + *mouse-drag-y* y)) + +(defun mouse-drag-set-mark-stuff (window x y) + "The up click handler that goes with mouse-drag-move-point. +If mouse is in same WINDOW but at different X or Y than when +mouse-drag-move-point was last executed, set the mark at mouse +and put the region in the stuff buffer." + (if (and (eq *mouse-drag-window* window) + (not (and (equal *mouse-drag-x* x) + (equal *mouse-drag-y* y)))) + (mouse-set-mark-and-stuff window x y) + (setq this-command last-command)) ; this was just an upclick no-op. + ) + +(defun mouse-select-or-drag-move-point (window x y) + "Select window if not selected, otherwise do mouse-drag-move-point." + (if (eq (selected-window) window) + (mouse-drag-move-point window x y) + (mouse-select-window window x y))) + +;;; +;;; esoterica: +;;; +(defun mouse-exch-pt-and-mark (window x y) + "Exchange point and mark." + (select-window window) + (exchange-point-and-mark) + ) + +(defun mouse-call-kbd-macro (window x y) + "Invokes last keyboard macro at mouse cursor." + (mouse-move-point window x y) + (call-last-kbd-macro) + ) + +(defun mouse-mark-thing (window x y) + "Set point and mark to text object using syntax table. +The resulting region is put in the sun-window stuff buffer. +Left or right Paren syntax marks an s-expression. +Clicking at the end of a line marks the line including a trailing newline. +If it doesn't recognize one of these it marks the character at point." + (mouse-move-point window x y) + (if (eobp) (open-line 1)) + (let* ((char (char-after (point))) + (syntax (char-syntax char))) + (cond + ((eq syntax ?w) ; word. + (forward-word 1) + (set-mark (point)) + (forward-word -1)) + ;; try to include a single following whitespace (is this a good idea?) + ;; No, not a good idea since inconsistent. + ;;(if (eq (char-syntax (char-after (mark))) ?\ ) + ;; (set-mark (1+ (mark)))) + ((eq syntax ?\( ) ; open paren. + (mark-sexp 1)) + ((eq syntax ?\) ) ; close paren. + (forward-char 1) + (mark-sexp -1) + (exchange-point-and-mark)) + ((eolp) ; mark line if at end. + (set-mark (1+ (point))) + (beginning-of-line 1)) + (t ; mark character + (set-mark (1+ (point))))) + (indicate-region)) ; display region boundary. + (sun-select-region (region-beginning) (region-end)) + ) + +(defun mouse-kill-thing (window x y) + "Kill thing at mouse, and put point there." + (mouse-mark-thing window x y) + (kill-region-and-unmark (region-beginning) (region-end)) + ) + +(defun mouse-kill-thing-there (window x y) + "Kill thing at mouse, leave point where it was. +See mouse-mark-thing for a description of the objects recognized." + (eval-in-window window + (save-excursion + (mouse-mark-thing window x y) + (kill-region (region-beginning) (region-end)))) + ) + +(defun mouse-save-thing (window x y &optional quiet) + "Put thing at mouse in kill ring. +See mouse-mark-thing for a description of the objects recognized." + (mouse-mark-thing window x y) + (copy-region-as-kill (region-beginning) (region-end)) + (if (not quiet) (message "Thing saved")) + ) + +(defun mouse-save-thing-there (window x y &optional quiet) + "Put thing at mouse in kill ring, leave point as is. +See mouse-mark-thing for a description of the objects recognized." + (eval-in-window window + (save-excursion + (mouse-save-thing window x y quiet)))) + +;;; +;;; Mouse yanking... +;;; +(defun mouse-copy-thing (window x y) + "Put thing at mouse in kill ring, yank to point. +See mouse-mark-thing for a description of the objects recognized." + (setq last-command 'not-kill) ;Avoids appending to previous kills. + (mouse-save-thing-there window x y t) + (yank) + (setq this-command 'yank)) + +(defun mouse-move-thing (window x y) + "Kill thing at mouse, yank it to point. +See mouse-mark-thing for a description of the objects recognized." + (setq last-command 'not-kill) ;Avoids appending to previous kills. + (mouse-kill-thing-there window x y) + (yank) + (setq this-command 'yank)) + +(defun mouse-yank-at-point (&optional window x y) + "Yank from kill-ring at point; then cycle thru kill ring." + (if (eq last-command 'yank) + (let ((before (< (point) (mark)))) + (delete-region (point) (mark)) + (insert (current-kill 1)) + (if before (exchange-point-and-mark))) + (yank)) + (setq this-command 'yank)) + +(defun mouse-yank-at-mouse (window x y) + "Yank from kill-ring at mouse; then cycle thru kill ring." + (mouse-move-point window x y) + (mouse-yank-at-point window x y)) + +(defun mouse-save/delete/yank (&optional window x y) + "Context sensitive save/delete/yank. +Consecutive clicks perform as follows: + * first click saves region to kill ring, + * second click kills region, + * third click yanks from kill ring, + * subsequent clicks cycle thru kill ring. +If mouse-move-point is performed after the first or second click, +the next click will do a yank, etc. Except for a possible mouse-move-point, +this command is insensitive to mouse location." + (cond + ((memq last-command '(mouse-delete yank mouse-yank-move)) ; third+ click + (mouse-yank-at-point)) + ((eq last-command 'mouse-copy) ; second click + (kill-region (region-beginning) (region-end)) + (setq this-command 'mouse-delete)) + (t ; first click + (copy-region-as-kill (region-beginning) (region-end)) + (message "Region saved") + (setq this-command 'mouse-copy)) + )) + + +(defun mouse-split-horizontally (window x y) + "Splits the window horizontally at mouse cursor." + (eval-in-window window (split-window-horizontally (1+ x)))) + +(defun mouse-split-vertically (window x y) + "Split the window vertically at the mouse cursor." + (eval-in-window window (split-window-vertically (1+ y)))) + +(defun mouse-select-window (window x y) + "Selects the window, restoring point." + (select-window window)) + +(defun mouse-delete-other-windows (window x y) + "Deletes all windows except the one mouse is in." + (delete-other-windows window)) + +(defun mouse-delete-window (window x y) + "Deletes the window mouse is in." + (delete-window window)) + +(defun mouse-undo (window x y) + "Invokes undo in the window mouse is in." + (eval-in-window window (undo))) + +;;; +;;; Scroll operations +;;; + +;;; The move-to-window-line is used below because otherwise +;;; scrolling a non-selected process window with the mouse, after +;;; the process has written text past the bottom of the window, +;;; gives an "End of buffer" error, and then scrolls. The +;;; move-to-window-line seems to force recomputing where things are. +(defun mouse-scroll-up (window x y) + "Scrolls the window upward." + (eval-in-window window (move-to-window-line 1) (scroll-up nil))) + +(defun mouse-scroll-down (window x y) + "Scrolls the window downward." + (eval-in-window window (scroll-down nil))) + +(defun mouse-scroll-proportional (window x y) + "Scrolls the window proportionally corresponding to window +relative X divided by window width." + (eval-in-window window + (if (>= x (1- (window-width))) + ;; When x is maximum (equal to or 1 less than window width), + ;; goto end of buffer. We check for this special case + ;; because the calculated goto-char often goes short of the + ;; end due to roundoff error, and we often really want to go + ;; to the end. + (goto-char (point-max)) + (progn + (goto-char (+ (point-min) ; For narrowed regions. + (* x (/ (- (point-max) (point-min)) + (1- (window-width)))))) + (beginning-of-line)) + ) + (what-cursor-position) ; Report position. + )) + +(defun mouse-line-to-top (window x y) + "Scrolls the line at the mouse cursor up to the top." + (eval-in-window window (scroll-up y))) + +(defun mouse-top-to-line (window x y) + "Scrolls the top line down to the mouse cursor." + (eval-in-window window (scroll-down y))) + +(defun mouse-line-to-bottom (window x y) + "Scrolls the line at the mouse cursor to the bottom." + (eval-in-window window (scroll-up (+ y (- 2 (window-height)))))) + +(defun mouse-bottom-to-line (window x y) + "Scrolls the bottom line up to the mouse cursor." + (eval-in-window window (scroll-down (+ y (- 2 (window-height)))))) + +(defun mouse-line-to-middle (window x y) + "Scrolls the line at the mouse cursor to the middle." + (eval-in-window window (scroll-up (- y -1 (/ (window-height) 2))))) + +(defun mouse-middle-to-line (window x y) + "Scrolls the line at the middle to the mouse cursor." + (eval-in-window window (scroll-up (- (/ (window-height) 2) y 1)))) + + +;;; +;;; main emacs menu. +;;; +(defmenu expand-menu + ("Vertically" mouse-expand-vertically *menu-window*) + ("Horizontally" mouse-expand-horizontally *menu-window*)) + +(defmenu delete-window-menu + ("This One" delete-window *menu-window*) + ("All Others" delete-other-windows *menu-window*)) + +(defmenu mouse-help-menu + ("Text Region" + mouse-help-region *menu-window* *menu-x* *menu-y* 'text) + ("Scrollbar" + mouse-help-region *menu-window* *menu-x* *menu-y* 'scrollbar) + ("Modeline" + mouse-help-region *menu-window* *menu-x* *menu-y* 'modeline) + ("Minibuffer" + mouse-help-region *menu-window* *menu-x* *menu-y* 'minibuffer) + ) + +(defmenu emacs-quit-menu + ("Suspend" suspend-emacstool) + ("Quit" save-buffers-kill-emacs)) + +(defmenu emacs-menu + ("Emacs Menu") + ("Stuff Selection" sun-yank-selection) + ("Expand" . expand-menu) + ("Delete Window" . delete-window-menu) + ("Previous Buffer" mouse-select-previous-buffer *menu-window*) + ("Save Buffers" save-some-buffers) + ("List Directory" list-directory nil) + ("Dired" dired nil) + ("Mouse Help" . mouse-help-menu) + ("Quit" . emacs-quit-menu)) + +(defun emacs-menu-eval (window x y) + "Pop-up menu of editor commands." + (sun-menu-evaluate window (1+ x) (1- y) 'emacs-menu)) + +(defun mouse-expand-horizontally (window) + (eval-in-window window + (enlarge-window 4 t) + (update-display) ; Try to redisplay, since can get confused. + )) + +(defun mouse-expand-vertically (window) + (eval-in-window window (enlarge-window 4))) + +(defun mouse-select-previous-buffer (window) + "Switch buffer in mouse window to most recently selected buffer." + (eval-in-window window (switch-to-buffer (other-buffer)))) + +;;; +;;; minibuffer menu +;;; +(defmenu minibuffer-menu + ("Minibuffer" message "Just some miscellaneous minibuffer commands") + ("Stuff" sun-yank-selection) + ("Do-It" exit-minibuffer) + ("Abort" abort-recursive-edit) + ("Suspend" suspend-emacs)) + +(defun minibuffer-menu-eval (window x y) + "Pop-up menu of commands." + (sun-menu-evaluate window x (1- y) 'minibuffer-menu)) + +(defun mini-move-point (window x y) + ;; -6 is good for most common cases + (mouse-move-point window (- x 6) 0)) + +(defun mini-set-mark-and-stuff (window x y) + ;; -6 is good for most common cases + (mouse-set-mark-and-stuff window (- x 6) 0)) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Buffer-mode Mouse commands +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun Buffer-at-mouse (w x y) + "Calls Buffer-menu-buffer from mouse click." + (save-window-excursion + (mouse-move-point w x y) + (beginning-of-line) + (Buffer-menu-buffer t))) + +(defun mouse-buffer-bury (w x y) + "Bury the indicated buffer." + (bury-buffer (Buffer-at-mouse w x y)) + ) + +(defun mouse-buffer-select (w x y) + "Put the indicated buffer in selected window." + (switch-to-buffer (Buffer-at-mouse w x y)) + (list-buffers) + ) + +(defun mouse-buffer-delete (w x y) + "mark indicated buffer for delete" + (save-window-excursion + (mouse-move-point w x y) + (Buffer-menu-delete) + )) + +(defun mouse-buffer-execute (w x y) + "execute buffer-menu selections" + (save-window-excursion + (mouse-move-point w x y) + (Buffer-menu-execute) + )) + +(defun enable-mouse-in-buffer-list () + "Call this to enable mouse selections in *Buffer List* + LEFT puts the indicated buffer in the selected window. + MIDDLE buries the indicated buffer. + RIGHT marks the indicated buffer for deletion. + MIDDLE-RIGHT deletes the marked buffers. +To unmark a buffer marked for deletion, select it with LEFT." + (save-window-excursion + (list-buffers) ; Initialize *Buffer List* + (set-buffer "*Buffer List*") + (local-set-mouse '(text middle) 'mouse-buffer-bury) + (local-set-mouse '(text left) 'mouse-buffer-select) + (local-set-mouse '(text right) 'mouse-buffer-delete) + (local-set-mouse '(text middle right) 'mouse-buffer-execute) + ) + ) + + +;;;******************************************************************* +;;; +;;; Global Mouse Bindings. +;;; +;;; There is some sense to this mouse binding madness: +;;; LEFT and RIGHT scrolls are inverses. +;;; SHIFT makes an opposite meaning in the scroll bar. +;;; SHIFT is an alternative to DOUBLE (but double chords do not exist). +;;; META makes the scrollbar functions work in the text region. +;;; MIDDLE operates the mark +;;; LEFT operates at point + +;;; META commands are generally non-destructive, +;;; SHIFT is a little more dangerous. +;;; CONTROL is for the really complicated ones. + +;;; CONTROL-META-SHIFT-RIGHT gives help on that region. + +;;; +;;; Text Region mousemap +;;; +;; The basics: Point, Mark, Menu, Sun-Select: +(global-set-mouse '(text left) 'mouse-drag-move-point) +(global-set-mouse '(text up left) 'mouse-drag-set-mark-stuff) +(global-set-mouse '(text shift left) 'mouse-exch-pt-and-mark) +(global-set-mouse '(text double left) 'mouse-exch-pt-and-mark) + +(global-set-mouse '(text middle) 'mouse-set-mark-and-stuff) + +(global-set-mouse '(text right) 'emacs-menu-eval) +(global-set-mouse '(text shift right) '(sun-yank-selection)) +(global-set-mouse '(text double right) '(sun-yank-selection)) + +;; The Slymoblics multi-command for Save, Kill, Copy, Move: +(global-set-mouse '(text shift middle) 'mouse-save/delete/yank) +(global-set-mouse '(text double middle) 'mouse-save/delete/yank) + +;; Save, Kill, Copy, Move Things: +;; control-left composes with control middle/right to produce copy/move +(global-set-mouse '(text control middle ) 'mouse-save-thing-there) +(global-set-mouse '(text control right ) 'mouse-kill-thing-there) +(global-set-mouse '(text control left) 'mouse-yank-at-point) +(global-set-mouse '(text control middle left) 'mouse-copy-thing) +(global-set-mouse '(text control right left) 'mouse-move-thing) +(global-set-mouse '(text control right middle) 'mouse-mark-thing) + +;; The Universal mouse help command (press all buttons): +(global-set-mouse '(text shift control meta right) 'mouse-help-region) +(global-set-mouse '(text double control meta right) 'mouse-help-region) + +;;; Meta in Text Region is like meta version in scrollbar: +(global-set-mouse '(text meta left) 'mouse-line-to-top) +(global-set-mouse '(text meta shift left) 'mouse-line-to-bottom) +(global-set-mouse '(text meta double left) 'mouse-line-to-bottom) +(global-set-mouse '(text meta middle) 'mouse-line-to-middle) +(global-set-mouse '(text meta shift middle) 'mouse-middle-to-line) +(global-set-mouse '(text meta double middle) 'mouse-middle-to-line) +(global-set-mouse '(text meta control middle) 'mouse-split-vertically) +(global-set-mouse '(text meta right) 'mouse-top-to-line) +(global-set-mouse '(text meta shift right) 'mouse-bottom-to-line) +(global-set-mouse '(text meta double right) 'mouse-bottom-to-line) + +;; Miscellaneous: +(global-set-mouse '(text meta control left) 'mouse-call-kbd-macro) +(global-set-mouse '(text meta control right) 'mouse-undo) + +;;; +;;; Scrollbar mousemap. +;;; Are available in the Scrollbar Region, or with Meta Text (or Meta Scrollbar) +;;; +(global-set-mouse '(scrollbar left) 'mouse-line-to-top) +(global-set-mouse '(scrollbar shift left) 'mouse-line-to-bottom) +(global-set-mouse '(scrollbar double left) 'mouse-line-to-bottom) + +(global-set-mouse '(scrollbar middle) 'mouse-line-to-middle) +(global-set-mouse '(scrollbar shift middle) 'mouse-middle-to-line) +(global-set-mouse '(scrollbar double middle) 'mouse-middle-to-line) +(global-set-mouse '(scrollbar control middle) 'mouse-split-vertically) + +(global-set-mouse '(scrollbar right) 'mouse-top-to-line) +(global-set-mouse '(scrollbar shift right) 'mouse-bottom-to-line) +(global-set-mouse '(scrollbar double right) 'mouse-bottom-to-line) + +(global-set-mouse '(scrollbar meta left) 'mouse-line-to-top) +(global-set-mouse '(scrollbar meta shift left) 'mouse-line-to-bottom) +(global-set-mouse '(scrollbar meta double left) 'mouse-line-to-bottom) +(global-set-mouse '(scrollbar meta middle) 'mouse-line-to-middle) +(global-set-mouse '(scrollbar meta shift middle) 'mouse-middle-to-line) +(global-set-mouse '(scrollbar meta double middle) 'mouse-middle-to-line) +(global-set-mouse '(scrollbar meta control middle) 'mouse-split-vertically) +(global-set-mouse '(scrollbar meta right) 'mouse-top-to-line) +(global-set-mouse '(scrollbar meta shift right) 'mouse-bottom-to-line) +(global-set-mouse '(scrollbar meta double right) 'mouse-bottom-to-line) + +;; And the help menu: +(global-set-mouse '(scrollbar shift control meta right) 'mouse-help-region) +(global-set-mouse '(scrollbar double control meta right) 'mouse-help-region) + +;;; +;;; Modeline mousemap. +;;; +;;; Note: meta of any single button selects window. + +(global-set-mouse '(modeline left) 'mouse-scroll-up) +(global-set-mouse '(modeline meta left) 'mouse-select-window) + +(global-set-mouse '(modeline middle) 'mouse-scroll-proportional) +(global-set-mouse '(modeline meta middle) 'mouse-select-window) +(global-set-mouse '(modeline control middle) 'mouse-split-horizontally) + +(global-set-mouse '(modeline right) 'mouse-scroll-down) +(global-set-mouse '(modeline meta right) 'mouse-select-window) + +;;; control-left selects this window, control-right deletes it. +(global-set-mouse '(modeline control left) 'mouse-delete-other-windows) +(global-set-mouse '(modeline control right) 'mouse-delete-window) + +;; in case of confusion, just select it: +(global-set-mouse '(modeline control left right)'mouse-select-window) + +;; even without confusion (and without the keyboard) select it: +(global-set-mouse '(modeline left right) 'mouse-select-window) + +;; And the help menu: +(global-set-mouse '(modeline shift control meta right) 'mouse-help-region) +(global-set-mouse '(modeline double control meta right) 'mouse-help-region) + +;;; +;;; Minibuffer Mousemap +;;; Demonstrating some variety: +;;; +(global-set-mouse '(minibuffer left) 'mini-move-point) + +(global-set-mouse '(minibuffer middle) 'mini-set-mark-and-stuff) + +(global-set-mouse '(minibuffer shift middle) '(select-previous-complex-command)) +(global-set-mouse '(minibuffer double middle) '(select-previous-complex-command)) +(global-set-mouse '(minibuffer control middle) '(next-complex-command 1)) +(global-set-mouse '(minibuffer meta middle) '(previous-complex-command 1)) + +(global-set-mouse '(minibuffer right) 'minibuffer-menu-eval) + +(global-set-mouse '(minibuffer shift control meta right) 'mouse-help-region) +(global-set-mouse '(minibuffer double control meta right) 'mouse-help-region) + +(provide 'sun-fns) + +;;; sun-fns.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/obsolete/x-apollo.el Thu Aug 30 07:36:15 2001 +0000 @@ -0,0 +1,96 @@ +;;; x-apollo.el --- Apollo support functions + +;; Copyright (C) 1995 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;;; Code: + +(defun apollo-kill-entire-line () + "Kill the entire line containing point." + (interactive) + (beginning-of-line) + (kill-line 1)) + +(defun apollo-scroll-window-right () + "Scroll window to right ten columns." + (interactive) + (scroll-left 10)) + +(defun apollo-scroll-window-left () + "Scroll window to left ten columns." + (interactive) + (scroll-right 10)) + +(defun apollo-scroll-window-forward-line () + "Move window forward one line leaving cursor at position in window." + (interactive) + (scroll-up 1)) + +(defun apollo-scroll-window-backward-line () + "Move window backward one line leaving cursor at position in window." + (interactive) + (scroll-down 1)) + +;;; Define and Enable the Function Key Bindings. + +(global-set-key [S-tab] "\C-i") ;Shift TAB +(global-set-key [C-tab] "\C-i") ;Control TAB +(global-set-key [S-return] "\C-m") ;Shift RET +(global-set-key [C-return] "\C-m") ;Control RET +(global-set-key [linedel] 'apollo-kill-entire-line) ;LINE DEL +(global-set-key [chardel] 'delete-char) ;CHAR DEL +(global-set-key [leftbar] 'beginning-of-line) ;LEFT BAR ARROW +(global-set-key [rightbar] 'end-of-line) ;RIGHT BAR ARROW +(global-set-key [leftbox] 'apollo-scroll-window-left) ;LEFT BOX ARROW +(global-set-key [rightbox] 'apollo-scroll-window-right) ;RIGHT BOX ARROW +(global-set-key [S-up] 'apollo-scroll-window-backward-line) ;Shift UP ARROW +(global-set-key [S-down] 'apollo-scroll-window-forward-line) ;Shift DOWN ARROW +(global-set-key [select] 'set-mark-command) ;MARK +(global-set-key [S-insert] 'overwrite-mode) ;INS MODE +(global-set-key [S-linedel] 'yank) ;Shift LINE DEL +(global-set-key [S-chardel] 'delete-char) ;Shift CHAR DEL +(global-set-key [copy] 'copy-region-as-kill) ;COPY +(global-set-key [S-cut] 'kill-region) ;CUT +(global-set-key [paste] 'yank) ;PASTE +(global-set-key [S-undo] 'undo) ;UNDO +(global-set-key [S-left] 'backward-word) ;Shift LEFT ARROW +(global-set-key [S-right] 'forward-word) ;Shift RIGHT ARROW +(global-set-key [upbox] 'scroll-down) ;UP BOX ARROW +(global-set-key [S-upbox] 'beginning-of-buffer) ;Shift UP BOX ARROW +(global-set-key [downbox] 'scroll-up) ;DOWN BOX ARROW +(global-set-key [S-downbox] 'end-of-buffer) ;Shift DOWN BOX ARROW +(global-set-key [S-redo] 'toggle-read-only) ;Shift AGAIN +(global-set-key [exit] 'save-buffer) ;EXIT +(global-set-key [S-cancel] 'kill-buffer) ;ABORT +(global-set-key [S-save] 'save-buffer) ;SAVE +(global-set-key [S-leftbar] 'beginning-of-buffer) ;Shift LEFT BAR ARROW +(global-set-key [cmd] 'execute-extended-command) ;CMD +(global-set-key [S-rightbar] 'end-of-buffer) ;Shift RIGHT BAR ARROW +(global-set-key [next] 'other-window) ;NEXT WNDW +(global-set-key [S-next] 'delete-window) ;Shift NEXT WNDW +(global-set-key [read] 'find-file-read-only) ;READ +(global-set-key [edit] 'find-file) ;EDIT +(global-set-key [S-shell] 'shell) ;SHELL +(global-set-key [S-help] 'manual-entry) ;HELP + +(provide 'x-apollo) + +;;; x-apollo.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/obsolete/x-menu.el Thu Aug 30 07:36:15 2001 +0000 @@ -0,0 +1,149 @@ +;;; x-menu.el --- menu support for X + +;; Copyright (C) 1986 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;;; Code: + +(defun x-menu-mode () + "Major mode for creating permanent menus for use with X. +These menus are implemented entirely in Lisp; popup menus, implemented +with x-popup-menu, are implemented using XMenu primitives." + (make-local-variable 'x-menu-items-per-line) + (make-local-variable 'x-menu-item-width) + (make-local-variable 'x-menu-items-alist) + (make-local-variable 'x-process-mouse-hook) + (make-local-variable 'x-menu-assoc-buffer) + (setq buffer-read-only t) + (setq truncate-lines t) + (setq x-process-mouse-hook 'x-menu-pick-entry) + (setq mode-line-buffer-identification '("MENU: %32b"))) + +(defvar x-menu-max-width 0) +(defvar x-menu-items-per-line 0) +(defvar x-menu-item-width 0) +(defvar x-menu-items-alist nil) +(defvar x-menu-assoc-buffer nil) + +(defvar x-menu-item-spacing 1 + "*Minimum horizontal spacing between objects in a permanent X menu.") + +(defun x-menu-create-menu (name) + "Create a permanent X menu. +Returns an item which should be used as a +menu object whenever referring to the menu." + (let ((old (current-buffer)) + (buf (get-buffer-create name))) + (set-buffer buf) + (x-menu-mode) + (setq x-menu-assoc-buffer old) + (set-buffer old) + buf)) + +(defun x-menu-change-associated-buffer (menu buffer) + "Change associated buffer of MENU to BUFFER. +BUFFER should be a buffer object." + (let ((old (current-buffer))) + (set-buffer menu) + (setq x-menu-assoc-buffer buffer) + (set-buffer old))) + +(defun x-menu-add-item (menu item binding) + "Add to MENU an item with name ITEM, associated with BINDING. +Following a sequence of calls to x-menu-add-item, a call to x-menu-compute +should be performed before the menu will be made available to the user. + +BINDING should be a function of one argument, which is the numerical +button/key code as defined in x-menu.el." + (let ((old (current-buffer)) + elt) + (set-buffer menu) + (if (setq elt (assoc item x-menu-items-alist)) + (rplacd elt binding) + (setq x-menu-items-alist (append x-menu-items-alist + (list (cons item binding))))) + (set-buffer old) + item)) + +(defun x-menu-delete-item (menu item) + "Delete from MENU the item named ITEM. +Call `x-menu-compute' before making the menu available to the user." + (let ((old (current-buffer)) + elt) + (set-buffer menu) + (if (setq elt (assoc item x-menu-items-alist)) + (rplaca elt nil)) + (set-buffer old) + item)) + +(defun x-menu-activate (menu) + "Compute all necessary parameters for MENU. +This must be called whenever a menu is modified before it is made +available to the user. This also creates the menu itself." + (let ((buf (current-buffer))) + (pop-to-buffer menu) + (let (buffer-read-only) + (setq x-menu-max-width (1- (frame-width))) + (setq x-menu-item-width 0) + (let (items-head + (items-tail x-menu-items-alist)) + (while items-tail + (if (car (car items-tail)) + (progn (setq items-head (cons (car items-tail) items-head)) + (setq x-menu-item-width + (max x-menu-item-width + (length (car (car items-tail))))))) + (setq items-tail (cdr items-tail))) + (setq x-menu-items-alist (reverse items-head))) + (setq x-menu-item-width (+ x-menu-item-spacing x-menu-item-width)) + (setq x-menu-items-per-line + (max 1 (/ x-menu-max-width x-menu-item-width))) + (erase-buffer) + (let ((items-head x-menu-items-alist)) + (while items-head + (let ((items 0)) + (while (and items-head + (<= (setq items (1+ items)) x-menu-items-per-line)) + (insert (format (concat "%" + (int-to-string x-menu-item-width) "s") + (car (car items-head)))) + (setq items-head (cdr items-head)))) + (insert ?\n))) + (shrink-window (max 0 + (- (window-height) + (1+ (count-lines (point-min) (point-max)))))) + (goto-char (point-min))) + (pop-to-buffer buf))) + +(defun x-menu-pick-entry (position event) + "Internal function for dispatching on mouse/menu events" + (let* ((x (min (1- x-menu-items-per-line) + (/ (current-column) x-menu-item-width))) + (y (- (count-lines (point-min) (point)) + (if (zerop (current-column)) 0 1))) + (item (+ x (* y x-menu-items-per-line))) + (litem (cdr (nth item x-menu-items-alist)))) + (and litem (funcall litem event))) + (pop-to-buffer x-menu-assoc-buffer)) + +(provide 'x-menu) + +;;; x-menu.el ends here