Github/emacs
2
0
Fork 1
mirror of git://git.sv.gnu.org/emacs.git synced 2026-02-16 17:24:23 +00:00
Code Issues Projects Releases Packages Wiki Activity

* cmdargs.texi (Misc Variables): Remove Sun windows info.

Browse source 
* MACHINES: Remove Sun windows info.

* term/sun-mouse.el:
* obsolete/sun-fns.el:
* obsolete/sun-curs.el: Remove files.

* term/sun.el (select-previous-complex-command):

* sunfns.c: Remove file

* m/sun386.h:
* m/sun2.h:
* m/sparc.h: Remove Sun windows code.
This commit is contained in:
Dan Nicolaescu 2007-11-01 03:06:23 +00:00
parent 88406d6ee8
commit 07e5c0b0b7
14 changed files with 18 additions and 2122 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

4
doc/emacs/ChangeLog
View file

@ -1,3 +1,7 @@
2007-11-01 Dan Nicolaescu <dann@ics.uci.edu>
* cmdargs.texi (Misc Variables): Remove Sun windows info.
2007-10-27 Emanuele Giaquinta <e.giaquinta@glauco.it> (tiny change)
* gnus-faq.texi ([5.12]): Remove reference to discontinued service.

3
doc/emacs/cmdargs.texi
View file

@ -635,9 +635,6 @@ Emacs switches the DOS display to a mode where all 16 colors can be used
for the background, so all four bits of the background color are
actually used.
@item WINDOW_GFX
Used when initializing the Sun windows system.
@item PRELOAD_WINSOCK
On MS-Windows, if you set this variable, Emacs will load and initialize
the network library at startup, instead of waiting until the first

4
etc/ChangeLog
View file

@ -1,3 +1,7 @@
2007-11-01 Dan Nicolaescu <dann@ics.uci.edu>
* MACHINES: Remove Sun windows info.
2007-10-30 Michael Olson <mwolson@gnu.org>
* NEWS: Add entry for Remember Mode.

11
etc/MACHINES
View file

@ -1158,17 +1158,6 @@ Sun 3, Sun 4 (sparc), Sun 386 (m68k-sun-sunos, sparc-sun-sunos, i386-sun-sunos,
src/s/sunos4-1.h to src/config.h. This problem is due to obsolete
software in the nonshared standard library.
If you want to use SunWindows, define HAVE_SUN_WINDOWS
in config.h to enable a special interface called `emacstool'.
The definition must *precede* the #include "machine.h".
System version 3.2 is required for this facility to work.
We recommend that you instead use the X window system, which
has technical advantages, is an industry standard, and is also
free software. The FSF does not support the SunWindows code;
we installed it only on the understanding we would not let it
divert our efforts from what we think is important.
If you are compiling for X windows, and the X window library was
compiled to use the 68881, then you must edit config.h according
the comments at the end of `src/m/sun3.h'.

2
etc/NEWS
View file

@ -33,6 +33,8 @@ a GIF library.
** Support for systems without alloca has been removed.
** Support for Sun windows has been removed.
** The `emacstool' utility has been removed.

234
lisp/obsolete/sun-curs.el
View file

@ -1,234 +0,0 @@
;;; sun-curs.el --- cursor definitions for Sun windows
;; Copyright (C) 1987, 2001, 2002, 2003, 2004, 2005,
;; 2006, 2007 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 3, 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., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, 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))
(defvar *edit-icon*)
(defvar char)
;; These are from term/sun-mouse.el
(defvar *mouse-window*)
(defvar *mouse-x*)
(defvar *mouse-y*)
(defvar menu)
(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))
;; This does not make much sense...
(make-local-variable '*edit-icon*)
(defvar icon-edit nil)
(make-variable-buffer-local 'icon-edit)
(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))
(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::menu-function (window x y)
(sun-menu-evaluate window (1+ x) y sc::menu))
(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)
;;; arch-tag: 7cc861e5-e2d9-4191-b211-2baaaab54e78
;;; sun-curs.el ends here

644
lisp/obsolete/sun-fns.el
View file

@ -1,644 +0,0 @@
;;; sun-fns.el --- subroutines of Mouse handling for Sun windows
;; Copyright (C) 1987, 2001, 2002, 2003, 2004, 2005,
;; 2006, 2007 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 3, 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., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, 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 (&optional 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)))
;;;
;;; 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 (&optional window x y)
"Selects the window, restoring point."
(select-window window))
(defun mouse-delete-other-windows (&optional window x y)
"Deletes all windows except the one mouse is in."
(delete-other-windows window))
(defun mouse-delete-window (window &optional 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
("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)
;;; arch-tag: 1c4c1192-f71d-4d5f-b883-ae659c28e132
;;; sun-fns.el ends here

667
lisp/term/sun-mouse.el
View file

@ -1,667 +0,0 @@
;;; sun-mouse.el --- mouse handling for Sun windows
;; Copyright (C) 1987, 2001, 2002, 2003, 2004, 2005,
;; 2006, 2007 Free Software Foundation, Inc.
;; Author: Jeff Peck
;; Maintainer: FSF
;; 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 3, 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., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;; Commentary:
;; Jeff Peck, Sun Microsystems, Jan 1987.
;; Original idea by Stan Jefferson
;; Modeled after the GNUEMACS keymap interface.
;;
;; User Functions:
;; make-mousemap, copy-mousemap,
;; define-mouse, global-set-mouse, local-set-mouse,
;; use-global-mousemap, use-local-mousemap,
;; mouse-lookup, describe-mouse-bindings
;;
;; Options:
;; extra-click-wait, scrollbar-width
;;; Code:
(defvar extra-click-wait 150
"*Number of milliseconds to wait for an extra click.
Set this to zero if you don't want chords or double clicks.")
(defvar scrollbar-width 5
"*The character width of the scrollbar.
The cursor is deemed to be in the right edge scrollbar if it is this near the
right edge, and more than two chars past the end of the indicated line.
Setting to nil limits the scrollbar to the edge or vertical dividing bar.")
;;;
;;; Mousemaps
;;;
(defun make-mousemap ()
"Returns a new mousemap."
(cons 'mousemap nil))
;;; initialize mouse maps
(defvar current-global-mousemap (make-mousemap))
(defvar current-local-mousemap nil)
(make-variable-buffer-local 'current-local-mousemap)
(defun copy-mousemap (mousemap)
"Return a copy of mousemap."
(copy-alist mousemap))
(defun define-mouse (mousemap mouse-list def)
"Args MOUSEMAP, MOUSE-LIST, DEF. Define MOUSE-LIST in MOUSEMAP as DEF.
MOUSE-LIST is a list of atoms specifying a mouse hit according to these rules:
* One of these atoms specifies the active region of the definition.
text, scrollbar, modeline, minibuffer
* One or two or these atoms specify the button or button combination.
left, middle, right, double
* Any combination of these atoms specify the active shift keys.
control, shift, meta
* With a single unshifted button, you can add
up
to indicate an up-click.
The atom `double' is used with a button designator to denote a double click.
Two button chords are denoted by listing the two buttons.
See sun-mouse-handler for the treatment of the form DEF."
(mousemap-set (mouse-list-to-mouse-code mouse-list) mousemap def))
(defun global-set-mouse (mouse-list def)
"Give MOUSE-EVENT-LIST a local definition of DEF.
See define-mouse for a description of MOUSE-EVENT-LIST and DEF.
Note that if MOUSE-EVENT-LIST has a local definition in the current buffer,
that local definition will continue to shadow any global definition."
(interactive "xMouse event: \nxDefinition: ")
(define-mouse current-global-mousemap mouse-list def))
(defun local-set-mouse (mouse-list def)
"Give MOUSE-EVENT-LIST a local definition of DEF.
See define-mouse for a description of the arguments.
The definition goes in the current buffer's local mousemap.
Normally buffers in the same major mode share a local mousemap."
(interactive "xMouse event: \nxDefinition: ")
(if (null current-local-mousemap)
(setq current-local-mousemap (make-mousemap)))
(define-mouse current-local-mousemap mouse-list def))
(defun use-global-mousemap (mousemap)
"Selects MOUSEMAP as the global mousemap."
(setq current-global-mousemap mousemap))
(defun use-local-mousemap (mousemap)
"Selects MOUSEMAP as the local mousemap.
nil for MOUSEMAP means no local mousemap."
(setq current-local-mousemap mousemap))
;;;
;;; Interface to the Mouse encoding defined in Emacstool.c
;;;
;;; Called when mouse-prefix is sent to emacs, additional
;;; information is read in as a list (button x y time-delta)
;;;
;;; First, some generally useful functions:
;;;
(defun logtest (x y)
"True if any bits set in X are also set in Y.
Just like the Common Lisp function of the same name."
(not (zerop (logand x y))))
;;;
;;; Hit accessors.
;;;
(defconst sm::ButtonBits 7) ; Lowest 3 bits.
(defconst sm::ShiftmaskBits 56) ; Second lowest 3 bits (56 = 63 - 7).
(defconst sm::DoubleBits 64) ; Bit 7.
(defconst sm::UpBits 128) ; Bit 8.
;;; All the useful code bits
(defmacro sm::hit-code (hit)
`(nth 0 ,hit))
;;; The button, or buttons if a chord.
(defmacro sm::hit-button (hit)
`(logand sm::ButtonBits (nth 0 ,hit)))
;;; The shift, control, and meta flags.
(defmacro sm::hit-shiftmask (hit)
`(logand sm::ShiftmaskBits (nth 0 ,hit)))
;;; Set if a double click (but not a chord).
(defmacro sm::hit-double (hit)
`(logand sm::DoubleBits (nth 0 ,hit)))
;;; Set on button release (as opposed to button press).
(defmacro sm::hit-up (hit)
`(logand sm::UpBits (nth 0 ,hit)))
;;; Screen x position.
(defmacro sm::hit-x (hit) (list 'nth 1 hit))
;;; Screen y position.
(defmacro sm::hit-y (hit) (list 'nth 2 hit))
;;; Milliseconds since last hit.
(defmacro sm::hit-delta (hit) (list 'nth 3 hit))
(defmacro sm::hit-up-p (hit) ; A predicate.
`(not (zerop (sm::hit-up ,hit))))
;;;
;;; Loc accessors. for sm::window-xy
;;;
(defmacro sm::loc-w (loc) (list 'nth 0 loc))
(defmacro sm::loc-x (loc) (list 'nth 1 loc))
(defmacro sm::loc-y (loc) (list 'nth 2 loc))
(defmacro eval-in-buffer (buffer &rest forms)
"Macro to switches to BUFFER, evaluates FORMS, returns to original buffer."
;; When you don't need the complete window context of eval-in-window
`(let ((StartBuffer (current-buffer)))
(unwind-protect
(progn
(set-buffer ,buffer)
,@forms)
(set-buffer StartBuffer))))
(put 'eval-in-buffer 'lisp-indent-function 1)
;;; this is used extensively by sun-fns.el
;;;
(defmacro eval-in-window (window &rest forms)
"Switch to WINDOW, evaluate FORMS, return to original window."
`(let ((OriginallySelectedWindow (selected-window)))
(unwind-protect
(progn
(select-window ,window)
,@forms)
(select-window OriginallySelectedWindow))))
(put 'eval-in-window 'lisp-indent-function 1)
;;;
;;; handy utility, generalizes window_loop
;;;
;;; It's a macro (and does not evaluate its arguments).
(defmacro eval-in-windows (form &optional yesmini)
"Switches to each window and evaluates FORM. Optional argument
YESMINI says to include the minibuffer as a window.
This is a macro, and does not evaluate its arguments."
`(let ((OriginallySelectedWindow (selected-window)))
(unwind-protect
(while (progn
,form
(not (eq OriginallySelectedWindow
(select-window
(next-window nil ,yesmini))))))
(select-window OriginallySelectedWindow))))
(put 'eval-in-window 'lisp-indent-function 0)
(defun move-to-loc (x y)
"Move cursor to window location X, Y.
Handles wrapped and horizontally scrolled lines correctly."
(move-to-window-line y)
;; window-line-end expects this to return the window column it moved to.
(let ((cc (current-column))
(nc (move-to-column
(if (zerop (window-hscroll))
(+ (current-column)
(min (- (window-width) 2) ; To stay on the line.
x))
(+ (window-hscroll) -1
(min (1- (window-width)) ; To stay on the line.
x))))))
(- nc cc)))
(defun minibuffer-window-p (window)
"True if this WINDOW is minibuffer."
(= (frame-height)
(nth 3 (window-edges window)) ; The bottom edge.
))
(defun sun-mouse-handler (&optional hit)
"Evaluates the function or list associated with a mouse hit.
Expecting to read a hit, which is a list: (button x y delta).
A form bound to button by define-mouse is found by mouse-lookup.
The variables: *mouse-window*, *mouse-x*, *mouse-y* are bound.
If the form is a symbol (symbolp), it is funcall'ed with *mouse-window*,
*mouse-x*, and *mouse-y* as arguments; if the form is a list (listp),
the form is eval'ed; if the form is neither of these, it is an error.
Returns nil."
(interactive)
(if (null hit) (setq hit (sm::combined-hits)))
(let ((loc (sm::window-xy (sm::hit-x hit) (sm::hit-y hit))))
(let ((*mouse-window* (sm::loc-w loc))
(*mouse-x* (sm::loc-x loc))
(*mouse-y* (sm::loc-y loc))
(mouse-code (mouse-event-code hit loc)))
(let ((form (eval-in-buffer (window-buffer *mouse-window*)
(mouse-lookup mouse-code))))
(cond ((null form)
(if (not (sm::hit-up-p hit)) ; undefined up hits are ok.
(error "Undefined mouse event: %s"
(prin1-to-string
(mouse-code-to-mouse-list mouse-code)))))
((symbolp form)
(setq this-command form)
(funcall form *mouse-window* *mouse-x* *mouse-y*))
((listp form)
(setq this-command (car form))
(eval form))
(t
(error "Mouse action must be symbol or list, but was: %s"
form))))))
;; Don't let 'sun-mouse-handler get on last-command,
;; since this function should be transparent.
(if (eq this-command 'sun-mouse-handler)
(setq this-command last-command))
;; (message (prin1-to-string this-command)) ; to see what your buttons did
nil)
(defun sm::combined-hits ()
"Read and return next mouse-hit, include possible double click"
(let ((hit1 (mouse-hit-read)))
(if (not (sm::hit-up-p hit1)) ; Up hits don't start doubles or chords.
(let ((hit2 (mouse-second-hit extra-click-wait)))
(if hit2 ; we cons'd it, we can smash it.
; (setf (sm::hit-code hit1) (logior (sm::hit-code hit1) ...))
(setcar hit1 (logior (sm::hit-code hit1)
(sm::hit-code hit2)
(if (= (sm::hit-button hit1)
(sm::hit-button hit2))
sm::DoubleBits 0))))))
hit1))
(defun mouse-hit-read ()
"Read mouse-hit list from keyboard. Like (read 'read-char),
but that uses minibuffer, and mucks up last-command."
(let ((char-list nil) (char nil))
(while (not (equal 13 ; Carriage return.
(prog1 (setq char (read-char))
(setq char-list (cons char char-list))))))
(read (mapconcat 'char-to-string (nreverse char-list) ""))
))
;;; Second Click Hackery....
;;; if prefix is not mouse-prefix, need a way to unread the char...
;;; or else have mouse flush input queue, or else need a peek at next char.
;;; There is no peek, but since one character can be unread, we only
;;; have to flush the queue when the command after a mouse click
;;; starts with mouse-prefix1 (see below).
;;; Something to do later: We could buffer the read commands and
;;; execute them ourselves after doing the mouse command (using
;;; lookup-key ??).
(defvar mouse-prefix1 24 ; C-x
"First char of mouse-prefix. Used to detect double clicks and chords.")
(defvar mouse-prefix2 0 ; C-@
"Second char of mouse-prefix. Used to detect double clicks and chords.")
(defun mouse-second-hit (hit-wait)
"Returns the next mouse hit occurring within HIT-WAIT milliseconds."
(if (sit-for-millisecs hit-wait) nil ; No input within hit-wait millisecs.
(let ((pc1 (read-char)))
(if (or (not (equal pc1 mouse-prefix1))
(sit-for-millisecs 3)) ; a mouse prefix will have second char
;; Can get away with one unread.
(progn (setq unread-command-events (list pc1))
nil) ; Next input not mouse event.
(let ((pc2 (read-char)))
(if (not (equal pc2 mouse-prefix2))
(progn (setq unread-command-events (list pc1)) ; put back the ^X
;;; Too bad can't do two: (setq unread-command-event (list pc1 pc2))
;;; Well, now we can, but I don't understand this code well enough to fix it...
(ding) ; user will have to retype that pc2.
nil) ; This input is not a mouse event.
;; Next input has mouse prefix and is within time limit.
(let ((new-hit (mouse-hit-read))) ; Read the new hit.
(if (sm::hit-up-p new-hit) ; Ignore up events when timing.
(mouse-second-hit (- hit-wait (sm::hit-delta new-hit)))
new-hit ; New down hit within limit, return it.
))))))))
(defun sm::window-xy (x y)
"Find window containing screen coordinates X and Y.
Returns list (window x y) where x and y are relative to window."
(or
(catch 'found
(eval-in-windows
(let ((we (window-edges (selected-window))))
(let ((le (nth 0 we))
(te (nth 1 we))
(re (nth 2 we))
(be (nth 3 we)))
(if (= re (frame-width))
;; include the continuation column with this window
(setq re (1+ re)))
(if (= be (frame-height))
;; include partial line at bottom of frame with this window
;; id est, if window is not multiple of char size.
(setq be (1+ be)))
(if (and (>= x le) (< x re)
(>= y te) (< y be))
(throw 'found
(list (selected-window) (- x le) (- y te))))))
t)) ; include minibuffer in eval-in-windows
;;If x,y from a real mouse click, we shouldn't get here.
(list nil x y)
))
(defun sm::window-region (loc)
"Parse LOC into a region symbol.
Returns one of (text scrollbar modeline minibuffer)"
(let ((w (sm::loc-w loc))
(x (sm::loc-x loc))
(y (sm::loc-y loc)))
(let ((right (1- (window-width w)))
(bottom (1- (window-height w))))
(cond ((minibuffer-window-p w) 'minibuffer)
((>= y bottom) 'modeline)
((>= x right) 'scrollbar)
;; far right column (window separator) is always a scrollbar
((and scrollbar-width
;; mouse within scrollbar-width of edge.
(>= x (- right scrollbar-width))
;; mouse a few chars past the end of line.
(>= x (+ 2 (window-line-end w x y))))
'scrollbar)
(t 'text)))))
(defun window-line-end (w x y)
"Return WINDOW column (ignore X) containing end of line Y"
(eval-in-window w (save-excursion (move-to-loc (frame-width) y))))
;;;
;;; The encoding of mouse events into a mousemap.
;;; These values must agree with coding in emacstool:
;;;
(defconst sm::keyword-alist
'((left . 1) (middle . 2) (right . 4)
(shift . 8) (control . 16) (meta . 32) (double . 64) (up . 128)
(text . 256) (scrollbar . 512) (modeline . 1024) (minibuffer . 2048)
))
(defun mouse-event-code (hit loc)
"Maps MOUSE-HIT and LOC into a mouse-code."
;;;Region is a code for one of text, modeline, scrollbar, or minibuffer.
(logior (sm::hit-code hit)
(mouse-region-to-code (sm::window-region loc))))
(defun mouse-region-to-code (region)
"Returns partial mouse-code for specified REGION."
(cdr (assq region sm::keyword-alist)))
(defun mouse-list-to-mouse-code (mouse-list)
"Map a MOUSE-LIST to a mouse-code."
(apply 'logior
(mapcar (function (lambda (x)
(cdr (assq x sm::keyword-alist))))
mouse-list)))
(defun mouse-code-to-mouse-list (mouse-code)
"Map a MOUSE-CODE to a mouse-list."
(apply 'nconc (mapcar
(function (lambda (x)
(if (logtest mouse-code (cdr x))
(list (car x)))))
sm::keyword-alist)))
(defun mousemap-set (code mousemap value)
(let* ((alist (cdr mousemap))
(assq-result (assq code alist)))
(if assq-result
(setcdr assq-result value)
(setcdr mousemap (cons (cons code value) alist)))))
(defun mousemap-get (code mousemap)
(cdr (assq code (cdr mousemap))))
(defun mouse-lookup (mouse-code)
"Look up MOUSE-EVENT and return the definition. nil means undefined."
(or (mousemap-get mouse-code current-local-mousemap)
(mousemap-get mouse-code current-global-mousemap)))
;;;
;;; I (jpeck) don't understand the utility of the next four functions
;;; ask Steven Greenbaum <froud@kestrel>
;;;
(defun mouse-mask-lookup (mask list)
"Args MASK (a bit mask) and LIST (a list of (code . form) pairs).
Returns a list of elements of LIST whose code or'ed with MASK is non-zero."
(let ((result nil))
(while list
(if (logtest mask (car (car list)))
(setq result (cons (car list) result)))
(setq list (cdr list)))
result))
(defun mouse-union (l l-unique)
"Return the union of list of mouse (code . form) pairs L and L-UNIQUE,
where L-UNIQUE is considered to be union'ized already."
(let ((result l-unique))
(while l
(let ((code-form-pair (car l)))
(if (not (assq (car code-form-pair) result))
(setq result (cons code-form-pair result))))
(setq l (cdr l)))
result))
(defun mouse-union-first-preferred (l1 l2)
"Return the union of lists of mouse (code . form) pairs L1 and L2,
based on the code's, with preference going to elements in L1."
(mouse-union l2 (mouse-union l1 nil)))
(defun mouse-code-function-pairs-of-region (region)
"Return a list of (code . function) pairs, where each code is
currently set in the REGION."
(let ((mask (mouse-region-to-code region)))
(mouse-union-first-preferred
(mouse-mask-lookup mask (cdr current-local-mousemap))
(mouse-mask-lookup mask (cdr current-global-mousemap))
)))
;;;
;;; Functions for DESCRIBE-MOUSE-BINDINGS
;;; And other mouse documentation functions
;;; Still need a good procedure to print out a help sheet in readable format.
;;;
(defun one-line-doc-string (function)
"Returns first line of documentation string for FUNCTION.
If there is no documentation string, then the string
\"No documentation\" is returned."
(while (consp function) (setq function (car function)))
(let ((doc (documentation function)))
(if (null doc)
"No documentation."
(string-match "^.*$" doc)
(substring doc 0 (match-end 0)))))
(defun print-mouse-format (binding)
(princ (car binding))
(princ ": ")
(mapc (function
(lambda (mouse-list)
(princ mouse-list)
(princ " ")))
(cdr binding))
(terpri)
(princ " ")
(princ (one-line-doc-string (car binding)))
(terpri)
)
(defun print-mouse-bindings (region)
"Prints mouse-event bindings for REGION."
(mapcar 'print-mouse-format (sm::event-bindings region)))
(defun sm::event-bindings (region)
"Returns an alist of (function . (mouse-list1 ... mouse-listN)) for REGION,
where each mouse-list is bound to the function in REGION."
(let ((mouse-bindings (mouse-code-function-pairs-of-region region))
(result nil))
(while mouse-bindings
(let* ((code-function-pair (car mouse-bindings))
(current-entry (assoc (cdr code-function-pair) result)))
(if current-entry
(setcdr current-entry
(cons (mouse-code-to-mouse-list (car code-function-pair))
(cdr current-entry)))
(setq result (cons (cons (cdr code-function-pair)
(list (mouse-code-to-mouse-list
(car code-function-pair))))
result))))
(setq mouse-bindings (cdr mouse-bindings))
)
result))
(defun describe-mouse-bindings ()
"Lists all current mouse-event bindings."
(interactive)
(with-output-to-temp-buffer "*Help*"
(princ "Text Region") (terpri)
(princ "---- ------") (terpri)
(print-mouse-bindings 'text) (terpri)
(princ "Modeline Region") (terpri)
(princ "-------- ------") (terpri)
(print-mouse-bindings 'modeline) (terpri)
(princ "Scrollbar Region") (terpri)
(princ "--------- ------") (terpri)
(print-mouse-bindings 'scrollbar)))
(defun describe-mouse-briefly (mouse-list)
"Print a short description of the function bound to MOUSE-LIST."
(interactive "xDescribe mouse list briefly: ")
(let ((function (mouse-lookup (mouse-list-to-mouse-code mouse-list))))
(if function
(message "%s runs the command %s" mouse-list function)
(message "%s is undefined" mouse-list))))
(defun mouse-help-menu (function-and-binding)
(cons (prin1-to-string (car function-and-binding))
(menu-create ; Two sub-menu items of form ("String" . nil)
(list (list (one-line-doc-string (car function-and-binding)))
(list (prin1-to-string (cdr function-and-binding)))))))
(defun mouse-help-region (w x y &optional region)
"Displays a menu of mouse functions callable in this region."
(let* ((region (or region (sm::window-region (list w x y))))
(mlist (mapcar (function mouse-help-menu)
(sm::event-bindings region)))
(menu (menu-create (cons (list (symbol-name region)) mlist)))
(item (sun-menu-evaluate w 0 y menu))
)))
;;;
;;; Menu interface functions
;;;
;;; use defmenu, because this interface is subject to change
;;; really need a menu-p, but we use vectorp and the context...
;;;
(defun menu-create (items)
"Functional form for defmenu, given a list of ITEMS returns a menu.
Each ITEM is a (STRING . VALUE) pair."
(apply 'vector items)
)
(defmacro defmenu (menu &rest itemlist)
"Defines MENU to be a menu, the ITEMS are (STRING . VALUE) pairs.
See sun-menu-evaluate for interpretation of ITEMS."
(list 'defconst menu (funcall 'menu-create itemlist))
)
(defun sun-menu-evaluate (*menu-window* *menu-x* *menu-y* menu)
"Display a pop-up menu in WINDOW at X Y and evaluate selected item
of MENU. MENU (or its symbol-value) should be a menu defined by defmenu.
A menu ITEM is a (STRING . FORM) pair;
the FORM associated with the selected STRING is evaluated,
and the resulting value is returned. Generally these FORMs are
evaluated for their side-effects rather than their values.
If the selected form is a menu or a symbol whose value is a menu,
then it is displayed and evaluated as a pullright menu item.
If the FORM of the first ITEM is nil, the STRING of the item
is used as a label for the menu, i.e. it's inverted and not selectable."
(if (symbolp menu) (setq menu (symbol-value menu)))
(eval (sun-menu-internal *menu-window* *menu-x* *menu-y* 4 menu)))
(defun sun-get-frame-data (code)
"Sends the tty-sub-window escape sequence CODE to terminal,
and returns a cons of the two numbers in returned escape sequence.
That is it returns (cons <car> <cdr>) from \"\\E[n;<car>;<cdr>t\".
CODE values: 13 = Tool-Position, 14 = Size-in-Pixels, 18 = Size-in-Chars."
(send-string-to-terminal (concat "\033[" (int-to-string code) "t"))
(let (char str x y)
(while (not (equal 116 (setq char (read-char)))) ; #\t = 116
(setq str (cons char str)))
(setq str (mapconcat 'char-to-string (nreverse str) ""))
(string-match ";[0-9]*" str)
(setq y (substring str (1+ (match-beginning 0)) (match-end 0)))
(setq str (substring str (match-end 0)))
(string-match ";[0-9]*" str)
(setq x (substring str (1+ (match-beginning 0)) (match-end 0)))
(cons (string-to-number y) (string-to-number x))))
(defun sm::font-size ()
"Returns font size in pixels: (cons Ysize Xsize)"
(let ((pix (sun-get-frame-data 14)) ; returns size in pixels
(chr (sun-get-frame-data 18))) ; returns size in chars
(cons (/ (car pix) (car chr)) (/ (cdr pix) (cdr chr)))))
(defvar sm::menu-kludge-x nil
"Cached frame-to-window X-Offset for sm::menu-kludge")
(defvar sm::menu-kludge-y nil
"Cached frame-to-window Y-Offset for sm::menu-kludge")
(defun sm::menu-kludge ()
"If sunfns.c uses <Menu_Base_Kludge> this function must be here!"
(or sm::menu-kludge-y
(let ((fs (sm::font-size)))
(setq sm::menu-kludge-y (+ 8 (car fs)) ; a title line and borders
sm::menu-kludge-x 4))) ; best values depend on .defaults/Menu
(let ((wl (sun-get-frame-data 13))) ; returns frame location
(cons (+ (car wl) sm::menu-kludge-y)
(+ (cdr wl) sm::menu-kludge-x))))
;;;
;;; Function interface to selection/region
;;; primitive functions are defined in sunfns.c
;;;
(defun sun-yank-selection ()
"Set mark and yank the contents of the current sunwindows selection.
Insert contents into the current buffer at point."
(interactive "*")
(set-mark-command nil)
(insert (sun-get-selection)))
(defun sun-select-region (beg end)
"Set the sunwindows selection to the region in the current buffer."
(interactive "r")
(sun-set-selection (buffer-substring beg end)))
(provide 'sun-mouse)
(provide 'term/sun-mouse) ; have to (require 'term/sun-mouse)
;;; arch-tag: 6e879372-b899-4509-833f-d7f6250e309a
;;; sun-mouse.el ends here

8
lisp/term/sun.el
View file

@ -47,14 +47,6 @@
(setq this-command 'kill-region-and-unmark)
(set-mark-command t))
(defun select-previous-complex-command ()
"Select Previous-complex-command"
(interactive)
(if (zerop (minibuffer-depth))
(repeat-complex-command 1)
;; FIXME: this function does not seem to exist. -stef'01
(previous-complex-command 1)))
(defun rerun-prev-command ()
"Repeat Previous-complex-command."
(interactive)

8
src/ChangeLog
View file

@ -1,3 +1,11 @@
2007-11-01 Dan Nicolaescu <dann@ics.uci.edu>
* sunfns.c: Remove file
* m/sun386.h:
* m/sun2.h:
* m/sparc.h: Remove Sun windows code.
2007-10-31 Stefan Monnier <monnier@iro.umontreal.ca>
* keyboard.c (syms_of_keyboard): Initialize the initial_kboard.

12
src/m/sparc.h
View file

@ -64,18 +64,6 @@ NOTE-END */
#define SEGMENT_MASK (SEGSIZ - 1)
/* Arrange to link with sun windows, if requested. */
/* For details on emacstool and sunfns, see etc/SUN-SUPPORT */
/* These programs require Sun UNIX 4.2 Release 3.2 or greater */
#ifdef HAVE_SUN_WINDOWS
#define OTHER_FILES ${etcdir}emacstool
#define LIBS_MACHINE -lsuntool -lsunwindow -lpixrect
#define OBJECTS_MACHINE sunfns.o
#define SYMS_MACHINE syms_of_sunfns ()
#define PURESIZE 130000
#endif
#if !defined (__NetBSD__) && !defined (__linux__) && !defined (__OpenBSD__)
/* This really belongs in s/sun.h. */

12
src/m/sun2.h
View file

@ -85,17 +85,5 @@ NOTE-END */
#define SEGMENT_MASK (SEGSIZ - 1)
/* Arrange to link with sun windows, if requested. */
/* For details on emacstool and sunfns, see etc/SUN-SUPPORT */
/* These programs require Sun UNIX 4.2 Release 3.2 or greater */
#ifdef HAVE_SUN_WINDOWS
#define OTHER_FILES ${libsrc}emacstool
#define LIBS_MACHINE -lsuntool -lsunwindow -lpixrect
#define OBJECTS_MACHINE sunfns.o
#define SYMS_MACHINE syms_of_sunfns ()
#define PURESIZE 132000
#endif
/* arch-tag: 543c3570-74ca-4099-aa47-db7c7b691c8e
(do not change this comment) */

12
src/m/sun386.h
View file

@ -56,18 +56,6 @@ NOTE-END */
#define LIBS_TERMCAP -ltermcap
/* Arrange to link with sun windows, if requested. */
/* For details on emacstool and sunfns, see etc/SUN-SUPPORT */
/* These programs require Sun UNIX 4.2 Release 3.2 or greater */
#ifdef HAVE_SUN_WINDOWS
#define OTHER_FILES ${etcdir}emacstool
#define LIBS_MACHINE -lsuntool -lsunwindow -lpixrect
#define OBJECTS_MACHINE sunfns.o
#define SYMS_MACHINE syms_of_sunfns ()
#define PURESIZE 132000
#endif
/* Roadrunner uses 'COFF' format */
#define COFF

519
src/sunfns.c
View file

@ -1,519 +0,0 @@
/* Functions for Sun Windows menus and selection buffer.
Copyright (C) 1987, 1999, 2001, 2002, 2003, 2004,
2005, 2006, 2007 Free Software Foundation, Inc.
This file is probably totally obsolete. In any case, the FSF is
unwilling to support it. We agreed to include it in our distribution
only on the understanding that we would spend no time at all on it.
If you have complaints about this file, send them to peck@sun.com.
If no one at Sun wants to maintain this, then consider it not
maintained at all. It would be a bad thing for the GNU project if
this file took our effort away from higher-priority things.
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 3, 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., 51 Franklin Street, Fifth Floor,
Boston, MA 02110-1301, USA. */
/* Author: Jeff Peck, Sun Microsystems, Inc. <peck@sun.com>
Original ideas by David Kastan and Eric Negaard, SRI International
Major help from: Steve Greenbaum, Reasoning Systems, Inc.
<froud@kestrel.arpa>
who first discovered the Menu_Base_Kludge.
*/
/*
* Emacs Lisp-Callable functions for sunwindows
*/
#include <config.h>
#include <stdio.h>
#include <errno.h>
#include <signal.h>
#include <sunwindow/window_hs.h>
#include <suntool/selection.h>
#include <suntool/menu.h>
#include <suntool/walkmenu.h>
#include <suntool/frame.h>
#include <suntool/window.h>
#include <fcntl.h>
#undef NULL /* We don't need sunview's idea of NULL */
#include "lisp.h"
#include "window.h"
#include "buffer.h"
#include "termhooks.h"
/* conversion to/from character & frame coordinates */
/* From Gosling Emacs SunWindow driver by Chris Torek */
/* Chars to frame coords. Note that we speak in zero origin. */
#define CtoSX(cx) ((cx) * Sun_Font_Xsize)
#define CtoSY(cy) ((cy) * Sun_Font_Ysize)
/* Frame coords to chars */
#define StoCX(sx) ((sx) / Sun_Font_Xsize)
#define StoCY(sy) ((sy) / Sun_Font_Ysize)
#define CHECK_GFX(x) if((win_fd<0)&&(Fsun_window_init(),(win_fd<0)))return(x)
int win_fd = -1;
struct pixfont *Sun_Font; /* The font */
int Sun_Font_Xsize; /* Width of font */
int Sun_Font_Ysize; /* Height of font */
#define Menu_Base_Kludge /* until menu_show_using_fd gets fixed */
#ifdef Menu_Base_Kludge
static Frame Menu_Base_Frame;
static int Menu_Base_fd;
static Lisp_Object sm_kludge_string;
#endif
struct cursor CurrentCursor; /* The current cursor */
static short CursorData[16]; /* Build cursor here */
static mpr_static(CursorMpr, 16, 16, 1, CursorData);
static struct cursor NewCursor = {0, 0, PIX_SRC ^ PIX_DST, &CursorMpr};
#define RIGHT_ARROW_CURSOR /* if you want the right arrow */
#ifdef RIGHT_ARROW_CURSOR
/* The default right-arrow cursor, with XOR drawing. */
static short ArrowCursorData[16] = {
0x0001,0x0003,0x0007,0x000F,0x001F,0x003F,0x007F,0x000F,
0x001B,0x0019,0x0030,0x0030,0x0060,0x0060,0x00C0,0x00C0};
static mpr_static(ArrowCursorMpr, 16, 16, 1, ArrowCursorData);
struct cursor DefaultCursor = {15, 0, PIX_SRC ^ PIX_DST, &ArrowCursorMpr};
#else
/* The default left-arrow cursor, with XOR drawing. */
static short ArrowCursorData[16] = {
0x8000,0xC000,0xE000,0xF000,0xF800,0xFC00,0xFE00,0xF000,
0xD800,0x9800,0x0C00,0x0C00,0x0600,0x0600,0x0300,0x0300};
static mpr_static(ArrowCursorMpr, 16, 16, 1, ArrowCursorData);
struct cursor DefaultCursor = {0, 0, PIX_SRC ^ PIX_DST, &ArrowCursorMpr};
#endif
/*
* Initialize window
*/
DEFUN ("sun-window-init", Fsun_window_init, Ssun_window_init, 0, 1, 0,
doc: /* One time setup for using Sun Windows with mouse.
Unless optional argument FORCE is non-nil, is a noop after its first call.
Returns a number representing the file descriptor of the open Sun Window,
or -1 if can not open it. */)
(force)
Lisp_Object force;
{
char *cp;
static int already_initialized = 0;
if ((! already_initialized) || (!NILP(force))) {
cp = getenv("WINDOW_GFX");
if (cp != 0) win_fd = emacs_open (cp, O_RDWR, 0);
if (win_fd > 0)
{
Sun_Font = pf_default();
Sun_Font_Xsize = Sun_Font->pf_defaultsize.x;
Sun_Font_Ysize = Sun_Font->pf_defaultsize.y;
Fsun_change_cursor_icon (Qnil); /* set up the default cursor */
already_initialized = 1;
#ifdef Menu_Base_Kludge
/* Make a frame to use for putting the menu on, and get its fd. */
Menu_Base_Frame = window_create(0, FRAME,
WIN_X, 0, WIN_Y, 0,
WIN_ROWS, 1, WIN_COLUMNS, 1,
WIN_SHOW, FALSE,
FRAME_NO_CONFIRM, 1,
0);
Menu_Base_fd = (int) window_get(Menu_Base_Frame, WIN_FD);
#endif
}
}
return(make_number(win_fd));
}
/*
* Mouse sit-for (allows a shorter interval than the regular sit-for
* and can be interrupted by the mouse)
*/
DEFUN ("sit-for-millisecs", Fsit_for_millisecs, Ssit_for_millisecs, 1, 1, 0,
doc: /* Like sit-for, but ARG is milliseconds.
Perform redisplay, then wait for ARG milliseconds or until
input is available. Returns t if wait completed with no input.
Redisplay does not happen if input is available before it starts. */)
(n)
Lisp_Object n;
{
struct timeval Timeout;
int waitmask = 1;
CHECK_NUMBER (n);
Timeout.tv_sec = XINT(n) / 1000;
Timeout.tv_usec = (XINT(n) - (Timeout.tv_sec * 1000)) * 1000;
if (detect_input_pending()) return(Qnil);
redisplay_preserve_echo_area (16);
/*
* Check for queued keyboard input/mouse hits again
* (A bit screen update can take some time!)
*/
if (detect_input_pending()) return(Qnil);
select(1,&waitmask,0,0,&Timeout);
if (detect_input_pending()) return(Qnil);
return(Qt);
}
/*
* Sun sleep-for (allows a shorter interval than the regular sleep-for)
*/
DEFUN ("sleep-for-millisecs",
Fsleep_for_millisecs,
Ssleep_for_millisecs, 1, 1, 0,
doc: /* Pause, without updating display, for ARG milliseconds. */)
(n)
Lisp_Object n;
{
unsigned useconds;
CHECK_NUMBER (n);
useconds = XINT(n) * 1000;
usleep(useconds);
return(Qt);
}
DEFUN ("update-display", Fupdate_display, Supdate_display, 0, 0, 0,
doc: /* Perform redisplay. */)
()
{
redisplay_preserve_echo_area (17);
return(Qt);
}
/*
* Change the Sun mouse icon
*/
DEFUN ("sun-change-cursor-icon",
Fsun_change_cursor_icon,
Ssun_change_cursor_icon, 1, 1, 0,
doc: /* Change the Sun mouse cursor icon.
ICON is a lisp vector whose 1st element
is the X offset of the cursor hot-point, whose 2nd element is the Y offset
of the cursor hot-point and whose 3rd element is the cursor pixel data
expressed as a string. If ICON is nil then the original arrow cursor is used. */)
(Icon)
Lisp_Object Icon;
{
register unsigned char *cp;
register short *p;
register int i;
Lisp_Object X_Hot, Y_Hot, Data;
CHECK_GFX (Qnil);
/*
* If the icon is null, we just restore the DefaultCursor
*/
if (NILP(Icon))
CurrentCursor = DefaultCursor;
else {
/*
* extract the data from the vector
*/
CHECK_VECTOR (Icon);
if (XVECTOR(Icon)->size < 3) return(Qnil);
X_Hot = XVECTOR(Icon)->contents[0];
Y_Hot = XVECTOR(Icon)->contents[1];
Data = XVECTOR(Icon)->contents[2];
CHECK_NUMBER (X_Hot);
CHECK_NUMBER (Y_Hot);
CHECK_STRING (Data);
if (SCHARS (Data) != 32) return(Qnil);
/*
* Setup the new cursor
*/
NewCursor.cur_xhot = X_Hot;
NewCursor.cur_yhot = Y_Hot;
cp = SDATA (Data);
p = CursorData;
i = 16;
while(--i >= 0)
*p++ = (cp[0] << 8) | cp[1], cp += 2;
CurrentCursor = NewCursor;
}
win_setcursor(win_fd, &CurrentCursor);
return(Qt);
}
/*
* Interface for sunwindows selection
*/
static Lisp_Object Current_Selection;
static
sel_write (sel, file)
struct selection *sel;
FILE *file;
{
fwrite (SDATA (Current_Selection), sizeof (char),
sel->sel_items, file);
}
static
sel_clear (sel, windowfd)
struct selection *sel;
int windowfd;
{
}
static
sel_read (sel, file)
struct selection *sel;
FILE *file;
{
register int i, n;
register char *cp;
Current_Selection = empty_unibyte_string;
if (sel->sel_items <= 0)
return (0);
cp = (char *) malloc(sel->sel_items);
if (cp == (char *)0) {
error("malloc failed in sel_read");
return(-1);
}
n = fread(cp, sizeof(char), sel->sel_items, file);
if (n > sel->sel_items) {
error("fread botch in sel_read");
return(-1);
} else if (n < 0) {
error("Error reading selection");
return(-1);
}
/*
* The shelltool select saves newlines as carriage returns,
* but emacs wants newlines.
*/
for (i = 0; i < n; i++)
if (cp[i] == '\r') cp[i] = '\n';
Current_Selection = make_string (cp, n);
free (cp);
return (0);
}
/*
* Set the window system "selection" to be the arg STRING
*/
DEFUN ("sun-set-selection", Fsun_set_selection, Ssun_set_selection, 1, 1,
"sSet selection to: ",
doc: /* Set the current sunwindow selection to STRING. */)
(str)
Lisp_Object str;
{
struct selection selection;
CHECK_STRING (str);
Current_Selection = str;
CHECK_GFX (Qnil);
selection.sel_type = SELTYPE_CHAR;
selection.sel_items = SCHARS (str);
selection.sel_itembytes = 1;
selection.sel_pubflags = 1;
selection_set(&selection, sel_write, sel_clear, win_fd);
return (Qt);
}
/*
* Stuff the current window system selection into the current buffer
*/
DEFUN ("sun-get-selection", Fsun_get_selection, Ssun_get_selection, 0, 0, 0,
doc: /* Return the current sunwindows selection as a string. */)
()
{
CHECK_GFX (Current_Selection);
selection_get (sel_read, win_fd);
return (Current_Selection);
}
Menu sun_menu_create();
Menu_item
sun_item_create (Pair)
Lisp_Object Pair;
{
/* In here, we depend on Lisp supplying zero terminated strings in the data*/
/* so we can just pass the pointers, and not recopy anything */
Menu_item menu_item;
Menu submenu;
Lisp_Object String;
Lisp_Object Value;
CHECK_LIST_CONS (Pair, Pair);
String = Fcar(Pair);
CHECK_STRING(String);
Value = Fcdr(Pair);
if (SYMBOLP (Value))
Value = SYMBOL_VALUE (Value);
if (VECTORP (Value)) {
submenu = sun_menu_create (Value);
menu_item = menu_create_item
(MENU_RELEASE, MENU_PULLRIGHT_ITEM, SDATA (String), submenu, 0);
} else {
menu_item = menu_create_item
(MENU_RELEASE, MENU_STRING_ITEM, SDATA (String), Value, 0);
}
return menu_item;
}
Menu
sun_menu_create (Vector)
Lisp_Object Vector;
{
Menu menu;
int i;
CHECK_VECTOR(Vector);
menu=menu_create(0);
for(i = 0; i < XVECTOR(Vector)->size; i++) {
menu_set (menu, MENU_APPEND_ITEM,
sun_item_create(XVECTOR(Vector)->contents[i]), 0);
}
return menu;
}
/*
* If the first item of the menu has nil as its value, then make the
* item look like a label by inverting it and making it unselectable.
* Returns 1 if the label was made, 0 otherwise.
*/
int
make_menu_label (menu)
Menu menu;
{
int made_label_p = 0;
if (( menu_get(menu, MENU_NITEMS) > 0 ) && /* At least one item */
((Lisp_Object) menu_get(menu_get(menu, MENU_NTH_ITEM, 1),
MENU_VALUE) == Qnil )) {
menu_set(menu_get(menu, MENU_NTH_ITEM, 1),
MENU_INVERT, TRUE,
MENU_FEEDBACK, FALSE,
0);
made_label_p = 1;
}
return made_label_p;
}
/*
* Do a pop-up menu and return the selected value
*/
DEFUN ("sun-menu-internal",
Fsun_menu_internal,
Ssun_menu_internal, 5, 5, 0,
doc: /* Set up a SunView pop-up menu and return the user's choice.
Arguments WINDOW, X, Y, BUTTON, and MENU.
*** User code should generally use sun-menu-evaluate ***
Arguments WINDOW, X, Y, BUTTON, and MENU.
Put MENU up in WINDOW at position X, Y.
The BUTTON argument specifies the button to be released that selects an item:
1 = LEFT BUTTON
2 = MIDDLE BUTTON
4 = RIGHT BUTTON
The MENU argument is a vector containing (STRING . VALUE) pairs.
The VALUE of the selected item is returned.
If the VALUE of the first pair is nil, then the first STRING will be used
as a menu label. */)
(window, X_Position, Y_Position, Button, MEnu)
Lisp_Object window, X_Position, Y_Position, Button, MEnu;
{
Menu menu;
int button, xpos, ypos;
Event event0;
Event *event = &event0;
Lisp_Object Value, Pair;
CHECK_NUMBER(X_Position);
CHECK_NUMBER(Y_Position);
CHECK_LIVE_WINDOW(window);
CHECK_NUMBER(Button);
CHECK_VECTOR(MEnu);
CHECK_GFX (Qnil);
xpos = CtoSX (WINDOW_LEFT_EDGE_COL (XWINDOW (window))
+ WINDOW_LEFT_SCROLL_BAR_COLS (XWINDOW (window))
+ XINT(X_Position));
ypos = CtoSY (WINDOW_TOP_EDGE_LINE (XWINDOW(window)) + XINT(Y_Position));
#ifdef Menu_Base_Kludge
{static Lisp_Object symbol[2];
symbol[0] = Fintern (sm_kludge_string, Qnil);
Pair = Ffuncall (1, symbol);
xpos += XINT (XCDR (Pair));
ypos += XINT (XCAR (Pair));
}
#endif
button = XINT(Button);
if(button == 4) button = 3;
event_set_id (event, BUT(button));
event_set_down (event);
event_set_x (event, xpos);
event_set_y (event, ypos);
menu = sun_menu_create(MEnu);
make_menu_label(menu);
#ifdef Menu_Base_Kludge
Value = (Lisp_Object) menu_show(menu, Menu_Base_Frame, event, 0);
#else
/* This confuses the notifier or something: */
Value = (Lisp_Object) menu_show_using_fd(menu, win_fd, event, 0);
/*
* Right button gets lost, and event sequencing or delivery gets mixed up
* So, until that gets fixed, we use this <Menu_Base_Frame> kludge:
*/
#endif
menu_destroy (menu);
return ((int)Value ? Value : Qnil);
}
/*
* Define everything
*/
syms_of_sunfns()
{
#ifdef Menu_Base_Kludge
/* i'm just too lazy to re-write this into C code */
/* so we will call this elisp function from C */
sm_kludge_string = make_pure_string ("sm::menu-kludge", 15, 15, 0);
#endif /* Menu_Base_Kludge */
defsubr(&Ssun_window_init);
defsubr(&Ssit_for_millisecs);
defsubr(&Ssleep_for_millisecs);
defsubr(&Supdate_display);
defsubr(&Ssun_change_cursor_icon);
defsubr(&Ssun_set_selection);
defsubr(&Ssun_get_selection);
defsubr(&Ssun_menu_internal);
}
/* arch-tag: 2d7decb7-58f6-41aa-b45b-077ccfab7158
(do not change this comment) */