428
|
1 ;;; apollo.el --- Apollo Graphics Primitive Support Functions
|
|
2
|
|
3 ;; Copyright (C) 1998 by Free Software Foundation, Inc.
|
|
4 ;; Copyright (C) 1991 by Lucid, Inc.
|
|
5
|
|
6 ;; Author: Leonard N. Zubkoff <lnz@dandelion.com>
|
|
7 ;; Keywords: hardware
|
|
8
|
|
9 ;; This file is part of XEmacs.
|
|
10
|
|
11 ;; XEmacs is free software; you can redistribute it and/or modify it
|
|
12 ;; under the terms of the GNU General Public License as published by
|
|
13 ;; the Free Software Foundation; either version 2, or (at your option)
|
|
14 ;; any later version.
|
|
15
|
|
16 ;; XEmacs is distributed in the hope that it will be useful, but
|
|
17 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
|
19 ;; General Public License for more details.
|
|
20
|
|
21 ;; You should have received a copy of the GNU General Public License
|
|
22 ;; along with XEmacs; see the file COPYING. If not, write to the Free
|
|
23 ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
|
|
24 ;; 02111-1307, USA.
|
|
25
|
|
26 ;;; Synched up with: InfoDock 3.6.2.
|
|
27
|
|
28 ;;; Commentary:
|
|
29
|
|
30 ;; GNU Emacs Apollo GPR Support Functions
|
|
31
|
|
32 ;; Leonard N. Zubkoff
|
|
33
|
|
34 ;; lnz@dandelion.com
|
|
35 ;; Lucid, Incorporated
|
|
36 ;; 23 January 1991
|
|
37
|
|
38 ;; This file defines functions that support GNU Emacs using the Apollo
|
|
39 ;; Graphics Primitives (GPR). See the file "APOLLO.README" for a description
|
|
40 ;; of the key bindings set up by this file.
|
|
41
|
|
42 ;; Acknowledgements
|
|
43
|
|
44 ;; The following people have contributed ideas that have helped make this
|
|
45 ;; interface possible: Nathaniel Mishkin, Rob Stanzel, and Mark Weissman of
|
|
46 ;; Apollo Computer, Dave Holcomb of CAECO, Vincent Broman of NOSC, and J. W.
|
|
47 ;; Peterson of the University of Utah.
|
|
48
|
|
49 ;;; Change Log:
|
|
50 ;; Bob Weiner, Motorola, Inc., 2/2/89
|
|
51
|
|
52 ;; Added section to 'apollo-clean-help-file()' to remove underlining
|
|
53 ;; and overstriking (only by the same letter) from Apollo '.hlp' files.
|
|
54 ;; Based on the 'nuke-nroff-bs' function in man.el.
|
|
55 ;; Changed apollo-mouse-{cut,copy,paste} commands so that they work
|
|
56 ;; with the DM paste buffer. This combined with cut,copy,paste
|
|
57 ;; bindings of the mouse keys allows quick and easy copying from
|
|
58 ;; Emacs windows to DM windows.
|
|
59 ;; Added 'unbind-apollo-mouse-button' and 'unbind-apollo-function-key'
|
|
60 ;; commands.
|
|
61 ;; Added 'apollo-mouse-cut-copy-paste' command which provides a
|
|
62 ;; second set of mouse key functions that can be set with one key
|
|
63 ;; press and cleared with another key press. Put default mouse key
|
|
64 ;; bindings into a command called 'apollo-mouse-defaults' so that
|
|
65 ;; they can be used to clear any other mouse bindings.
|
|
66 ;; Both these commands affect the DM mouse key bindings as well.
|
|
67 ;; Added 'apollo-mouse-cancel-cut-copy-paste' command which resets the mouse
|
|
68 ;; key defaults within Emacs and the DM. The variable
|
|
69 ;; '*dm-mouse-key-bindings-file*' should be set within an initialization
|
|
70 ;; file to the pathname of file that executes a user's default DM mouse
|
|
71 ;; key bindings.
|
|
72
|
|
73 ;; Bob Weiner, Motorola, Inc., 2/23/89
|
|
74
|
|
75 ;; Added ':' as valid character within a filename (if not at the end)
|
|
76 ;; in the command 'extract-file-name-around-point'. For remote UNIX
|
|
77 ;; operations such as rcp and rsh commands which use the syntax,
|
|
78 ;; <host>:<path>.
|
|
79
|
|
80 ;; Bob Weiner, Motorola, Inc., 3/09/89
|
|
81 ;;
|
|
82 ;; Modified 'apollo-mouse-find-file' and 'apollo-find-file' so that they
|
|
83 ;; recognize buffer names in addition to directory or file paths. A buffer
|
|
84 ;; name is recognized before a path name, if the match buffer names flag is
|
|
85 ;; enabled. Added the command 'extract-buf-or-file-name-around-point' to
|
|
86 ; support this functionality. Added find file in other window option to
|
|
87 ;; these two find-file commands.
|
|
88
|
|
89 ;; Bob Weiner, Motorola, Inc., 3/20/89
|
|
90
|
|
91 ;; Changed (funcall *apollo-key-bindings-hook*) to (run-hooks
|
|
92 ;; '*apollo-key-bindings-hook*) which is what it should be.
|
|
93
|
|
94 ;; Bob Weiner, Motorola, Inc., 4/20/89
|
|
95
|
|
96 ;; Rebound M2D button to perform different functions by buffer and location in
|
|
97 ;; buffer. Executes 'smart-key-mouse' command found in smart-key.el.
|
|
98 ;; Meta-M2D executes 'smart-key-mouse-meta'. M2U is unbound.
|
|
99
|
|
100 ;; Bob Weiner, Motorola, Inc., 8/1/89
|
|
101
|
|
102 ;; Fixed 'apollo-mouse-move-point' and 'apollo-mouse-move-mark' so they do
|
|
103 ;; not set the mark gratuitously. They are bound to M1D and M1U respectively.
|
|
104
|
|
105 ;; Bob Weiner, Motorola, Inc., 4/11/90
|
|
106
|
|
107 ;; Bound left and right box arrow keys to scroll right and left,
|
|
108 ;; respectively, which most closely emulates their DM functions.
|
|
109
|
|
110 ;;; Code:
|
|
111
|
|
112 (defvar *dm-mouse-key-bindings-file* "/sys/dm/std_keys3"
|
|
113 "Path of the DM key binding file which sets up a user's default mouse key
|
|
114 bindings. If none exists, this value should be set to one of the
|
|
115 /sys/dm/std_key* files which set up DM key defaults.")
|
|
116
|
|
117 ;;; Set this variable in your ".emacs" to a function to call to set up
|
|
118 ;;; additional key bindings.
|
|
119 ;;;
|
|
120 (defvar *apollo-key-bindings-hook* nil)
|
|
121
|
|
122 ;;; Set this variable non-NIL in your ".emacs" to enable preemption of normal
|
|
123 ;;; Display Manager bindings.
|
|
124 ;;;
|
|
125 (defvar *preempt-display-manager-bindings* nil)
|
|
126
|
|
127
|
|
128
|
|
129 ;;; Determine whether or not we're running diskless and define
|
|
130 ;;; *paste-buffer-directory* to point to the paste buffers directory.
|
|
131
|
|
132 (defvar *paste-buffer-directory*
|
|
133 (let ((test-directory (concat "/sys/node_data."
|
|
134 (downcase (getenv "NODEID"))
|
|
135 "paste_buffers/")))
|
|
136 (if (file-directory-p test-directory)
|
|
137 test-directory
|
|
138 "/sys/node_data/paste_buffers/")))
|
|
139
|
|
140
|
|
141 ;;; Bind this variable non-NIL to allow apollo-mouse-move-point to leave the
|
|
142 ;;; minibuffer area.
|
|
143
|
|
144 (defvar *apollo-mouse-move-point-allow-minibuffer-exit* nil)
|
|
145
|
|
146
|
|
147 ;;; Define the Apollo Function Keys.
|
|
148
|
|
149 (defvar *apollo-function-keys*
|
|
150 '(("ESC" . 0) ("L1" . 1) ("L2" . 2) ("L3" . 3)
|
|
151 ("L1A" . 4) ("L2A" . 5) ("L3A" . 6) ("L4" . 7)
|
|
152 ("L5" . 8) ("L6" . 9) ("L7" . 10) ("L8" . 11)
|
|
153 ("L9" . 12) ("LA" . 13) ("LB" . 14) ("LC" . 15)
|
|
154 ("LD" . 16) ("LE" . 17) ("LF" . 18) ("F0" . 19)
|
|
155 ("F1" . 20) ("F2" . 21) ("F3" . 22) ("F4" . 23)
|
|
156 ("F5" . 24) ("F6" . 25) ("F7" . 26) ("F8" . 27)
|
|
157 ("F9" . 28) ("R1" . 29) ("R2" . 30) ("R3" . 31)
|
|
158 ("R4" . 32) ("R5" . 33) ("R6" . 34) ("NP0" . 35)
|
|
159 ("NP1" . 36) ("NP2" . 37) ("NP3" . 38) ("NP4" . 39)
|
|
160 ("NP5" . 40) ("NP6" . 41) ("NP7" . 42) ("NP8" . 43)
|
|
161 ("NP9" . 44) ("NPA" . 45) ("NPB" . 46) ("NPC" . 47)
|
|
162 ("NPD" . 48) ("NPE" . 49) ("NPF" . 50) ("NPG" . 51)
|
|
163 ("NPP" . 52) ("AL" . 53) ("AR" . 54) ("SHL" . 55)
|
|
164 ("SHR" . 56) ("LCK" . 57) ("CTL" . 58) ("RPT" . 59)
|
|
165 ("TAB" . 60) ("RET" . 61) ("BS" . 62) ("DEL" . 63)
|
|
166 ("ESCS" . 64) ("L1S" . 65) ("L2S" . 66) ("L3S" . 67)
|
|
167 ("L1AS" . 68) ("L2AS" . 69) ("L3AS" . 70) ("L4S" . 71)
|
|
168 ("L5S" . 72) ("L6S" . 73) ("L7S" . 74) ("L8S" . 75)
|
|
169 ("L9S" . 76) ("LAS" . 77) ("LBS" . 78) ("LCS" . 79)
|
|
170 ("LDS" . 80) ("LES" . 81) ("LFS" . 82) ("F0S" . 83)
|
|
171 ("F1S" . 84) ("F2S" . 85) ("F3S" . 86) ("F4S" . 87)
|
|
172 ("F5S" . 88) ("F6S" . 89) ("F7S" . 90) ("F8S" . 91)
|
|
173 ("F9S" . 92) ("R1S" . 93) ("R2S" . 94) ("R3S" . 95)
|
|
174 ("R4S" . 96) ("R5S" . 97) ("R6S" . 98) ("NP0S" . 99)
|
|
175 ("NP1S" . 100) ("NP2S" . 101) ("NP3S" . 102) ("NP4S" . 103)
|
|
176 ("NP5S" . 104) ("NP6S" . 105) ("NP7S" . 106) ("NP8S" . 107)
|
|
177 ("NP9S" . 108) ("NPAS" . 109) ("NPBS" . 110) ("NPCS" . 111)
|
|
178 ("NPDS" . 112) ("NPES" . 113) ("NPFS" . 114) ("NPGS" . 115)
|
|
179 ("NPPS" . 116) ("ALS" . 117) ("ARS" . 118) ("SHLS" . 119)
|
|
180 ("SHRS" . 120) ("LCKS" . 121) ("CTLS" . 122) ("RPTS" . 123)
|
|
181 ("TABS" . 124) ("RETS" . 125) ("BSS" . 126) ("DELS" . 127)
|
|
182 ("ESCC" . 128) ("L1C" . 129) ("L2C" . 130) ("L3C" . 131)
|
|
183 ("L1AC" . 132) ("L2AC" . 133) ("L3AC" . 134) ("L4C" . 135)
|
|
184 ("L5C" . 136) ("L6C" . 137) ("L7C" . 138) ("L8C" . 139)
|
|
185 ("L9C" . 140) ("LAC" . 141) ("LBC" . 142) ("LCC" . 143)
|
|
186 ("LDC" . 144) ("LEC" . 145) ("LFC" . 146) ("F0C" . 147)
|
|
187 ("F1C" . 148) ("F2C" . 149) ("F3C" . 150) ("F4C" . 151)
|
|
188 ("F5C" . 152) ("F6C" . 153) ("F7C" . 154) ("F8C" . 155)
|
|
189 ("F9C" . 156) ("R1C" . 157) ("R2C" . 158) ("R3C" . 159)
|
|
190 ("R4C" . 160) ("R5C" . 161) ("R6C" . 162) ("NP0C" . 163)
|
|
191 ("NP1C" . 164) ("NP2C" . 165) ("NP3C" . 166) ("NP4C" . 167)
|
|
192 ("NP5C" . 168) ("NP6C" . 169) ("NP7C" . 170) ("NP8C" . 171)
|
|
193 ("NP9C" . 172) ("NPAC" . 173) ("NPBC" . 174) ("NPCC" . 175)
|
|
194 ("NPDC" . 176) ("NPEC" . 177) ("NPFC" . 178) ("NPGC" . 179)
|
|
195 ("NPPC" . 180) ("ALC" . 181) ("ARC" . 182) ("SHLC" . 183)
|
|
196 ("SHRC" . 184) ("LCKC" . 185) ("CTLC" . 186) ("RPTC" . 187)
|
|
197 ("TABC" . 188) ("RETC" . 189) ("BSC" . 190) ("DELC" . 191)
|
|
198 ("ESCU" . 192) ("L1U" . 193) ("L2U" . 194) ("L3U" . 195)
|
|
199 ("L1AU" . 196) ("L2AU" . 197) ("L3AU" . 198) ("L4U" . 199)
|
|
200 ("L5U" . 200) ("L6U" . 201) ("L7U" . 202) ("L8U" . 203)
|
|
201 ("L9U" . 204) ("LAU" . 205) ("LBU" . 206) ("LCU" . 207)
|
|
202 ("LDU" . 208) ("LEU" . 209) ("LFU" . 210) ("F0U" . 211)
|
|
203 ("F1U" . 212) ("F2U" . 213) ("F3U" . 214) ("F4U" . 215)
|
|
204 ("F5U" . 216) ("F6U" . 217) ("F7U" . 218) ("F8U" . 219)
|
|
205 ("F9U" . 220) ("R1U" . 221) ("R2U" . 222) ("R3U" . 223)
|
|
206 ("R4U" . 224) ("R5U" . 225) ("R6U" . 226) ("NP0U" . 227)
|
|
207 ("NP1U" . 228) ("NP2U" . 229) ("NP3U" . 230) ("NP4U" . 231)
|
|
208 ("NP5U" . 232) ("NP6U" . 233) ("NP7U" . 234) ("NP8U" . 235)
|
|
209 ("NP9U" . 236) ("NPAU" . 237) ("NPBU" . 238) ("NPCU" . 239)
|
|
210 ("NPDU" . 240) ("NPEU" . 241) ("NPFU" . 242) ("NPGU" . 243)
|
|
211 ("NPPU" . 244) ("ALU" . 245) ("ARU" . 246) ("SHLU" . 247)
|
|
212 ("SHRU" . 248) ("LCKU" . 249) ("CTLU" . 250) ("RPTU" . 251)
|
|
213 ("TABU" . 252) ("RETU" . 253) ("BSU" . 254) ("DELU" . 255)
|
|
214 ("MARK" . "L1") ("LINE_DEL" . "L2") ("CHAR_DEL" . "L3")
|
|
215 ("L_BAR_ARROW" . "L4") ("CMD" . "L5") ("R_BAR_ARROW" . "L6")
|
|
216 ("L_BOX_ARROW" . "L7") ("UP_ARROW" . "L8") ("R_BOX_ARROW" . "L9")
|
|
217 ("LEFT_ARROW" . "LA") ("NEXT_WIN" . "LB") ("RIGHT_ARROW" . "LC")
|
|
218 ("UP_BOX_ARROW" . "LD") ("DOWN_ARROW" . "LE") ("DOWN_BOX_ARROW" . "LF")
|
|
219 ("COPY" . "L1A") ("PASTE" . "L2A") ("GROW" . "L3A") ("INS_MODE" . "L1S")
|
|
220 ("SHELL" . "L5S") ("CUT" . "L1AS") ("UNDO" . "L2AS") ("MOVE" . "L3AS")
|
|
221 ("POP" . "R1") ("AGAIN" . "R2") ("READ" . "R3") ("EDIT" . "R4")
|
|
222 ("EXIT" . "R5") ("HOLD" . "R6") ("SAVE" . "R4S") ("ABORT" . "R5S")
|
|
223 ("UNIXHELP" . "R6S") ("AEGISHELP" . "R6C")))
|
|
224
|
|
225
|
|
226 ;;; Define the Apollo Mouse Buttons.
|
|
227
|
|
228 (defvar *apollo-mouse-buttons*
|
|
229 '(("M1D" . 97) ("M2D" . 98) ("M3D" . 99) ("M4D" . 100)
|
|
230 ("M1S" . 33) ("M2S" . 34) ("M3S" . 35) ("M4S" . 36)
|
|
231 ("M1C" . 1) ("M2C" . 2) ("M3C" . 3) ("M4C" . 4)
|
|
232 ("M1U" . 65) ("M2U" . 66) ("M3U" . 67) ("M4U" . 68)))
|
|
233
|
|
234
|
|
235 ;;; Define functions to simplify making function key and mouse button bindings.
|
|
236
|
|
237 (defun bind-apollo-function-key (function-key binding &optional meta-binding)
|
|
238 "Enable an Apollo Function Key and assign a binding to it."
|
|
239 (interactive "sFunction Key: \nCCommand: \nCMeta Command: ")
|
|
240 (let ((numeric-code (cdr (assoc function-key *apollo-function-keys*))))
|
|
241 (if (null numeric-code)
|
|
242 (error "%s is not a legal Apollo Function Key name" function-key))
|
|
243 (if (stringp numeric-code)
|
|
244 (setq numeric-code
|
|
245 (cdr (assoc numeric-code *apollo-function-keys*))))
|
|
246 (enable-apollo-function-key numeric-code)
|
|
247 (let ((normal-sequence
|
|
248 (concat (char-to-string (logior 72 (lsh numeric-code -6)))
|
|
249 (char-to-string (logior 64 (logand numeric-code 63)))))
|
|
250 (meta-sequence
|
|
251 (concat (char-to-string (logior 76 (lsh numeric-code -6)))
|
|
252 (char-to-string (logior 64 (logand numeric-code 63))))))
|
|
253 (define-key 'apollo-prefix normal-sequence binding)
|
|
254 (define-key 'apollo-prefix meta-sequence (or meta-binding binding)))))
|
|
255
|
|
256 (defun unbind-apollo-function-key (function-key)
|
|
257 "Disable an Apollo Function Key and return control of it to the DM."
|
|
258 (interactive "sFunction key: ")
|
|
259 (let ((numeric-code (cdr (assoc function-key *apollo-function-keys*))))
|
|
260 (if (null numeric-code)
|
|
261 (error "%s is not a legal Apollo Function Key name" function-key))
|
|
262 (if (stringp numeric-code)
|
|
263 (setq numeric-code
|
|
264 (cdr (assoc numeric-code *apollo-function-keys*))))
|
|
265 (disable-apollo-function-key numeric-code)))
|
|
266
|
|
267 (defun select-apollo-meta-key (meta-key)
|
|
268 "Select the Function Key used as the Meta Key."
|
|
269 (interactive "sMeta Key: ")
|
|
270 (let ((numeric-code (cdr (assoc meta-key *apollo-function-keys*))))
|
|
271 (if (null numeric-code)
|
|
272 (error "%s is not a legal Apollo Function Key name" meta-key))
|
|
273 (if (stringp numeric-code)
|
|
274 (setq numeric-code
|
|
275 (cdr (assoc numeric-code *apollo-function-keys*))))
|
|
276 (set-apollo-meta-key numeric-code)))
|
|
277
|
|
278 (defun bind-apollo-mouse-button (mouse-button binding &optional meta-binding)
|
|
279 "Enable an Apollo Mouse Button and assign a binding to it."
|
|
280 (interactive "sMouse Button: \nCCommand: \nCMeta Command: ")
|
|
281 (let ((numeric-code (cdr (assoc mouse-button *apollo-mouse-buttons*))))
|
|
282 (if (null numeric-code)
|
|
283 (error "%s is not a legal Apollo Mouse Button name" mouse-button))
|
|
284 (enable-apollo-mouse-button numeric-code)
|
|
285 (let ((normal-sequence (char-to-string numeric-code))
|
|
286 (meta-sequence (char-to-string (+ numeric-code 16))))
|
|
287 (define-key 'apollo-prefix normal-sequence binding)
|
|
288 (define-key 'apollo-prefix meta-sequence (or meta-binding binding)))))
|
|
289
|
|
290 (defun unbind-apollo-mouse-button (mouse-button)
|
|
291 "Disable an Apollo Mouse Button and return control of it to the DM."
|
|
292 (interactive "sMouse Button: ")
|
|
293 (let ((numeric-code (cdr (assoc mouse-button *apollo-mouse-buttons*))))
|
|
294 (if (null numeric-code)
|
|
295 (error "%s is not a legal Apollo Mouse Button name" mouse-button))
|
|
296 (disable-apollo-mouse-button numeric-code)))
|
|
297
|
|
298
|
|
299 ;;; Initialize the Apollo Keymaps.
|
|
300
|
|
301 (define-prefix-command 'apollo-prefix)
|
|
302 (global-set-key "\C-^" 'apollo-prefix)
|
|
303 (define-prefix-command 'apollo-prefix-1)
|
|
304 (define-prefix-command 'apollo-prefix-2)
|
|
305 (define-prefix-command 'apollo-prefix-3)
|
|
306 (define-prefix-command 'apollo-prefix-4)
|
|
307 (define-prefix-command 'apollo-prefix-5)
|
|
308 (define-prefix-command 'apollo-prefix-6)
|
|
309 (define-prefix-command 'apollo-prefix-7)
|
|
310 (define-prefix-command 'apollo-prefix-8)
|
|
311 (define-key 'apollo-prefix "H" 'apollo-prefix-1)
|
|
312 (define-key 'apollo-prefix "I" 'apollo-prefix-2)
|
|
313 (define-key 'apollo-prefix "J" 'apollo-prefix-3)
|
|
314 (define-key 'apollo-prefix "K" 'apollo-prefix-4)
|
|
315 (define-key 'apollo-prefix "L" 'apollo-prefix-5)
|
|
316 (define-key 'apollo-prefix "M" 'apollo-prefix-6)
|
|
317 (define-key 'apollo-prefix "N" 'apollo-prefix-7)
|
|
318 (define-key 'apollo-prefix "O" 'apollo-prefix-8)
|
|
319
|
|
320
|
|
321 ;;; Commands to COPY, CUT, and PASTE.
|
|
322
|
|
323 (defun apollo-copy-region ()
|
|
324 "Copy region between point and mark to the default DM paste buffer."
|
|
325 (interactive)
|
|
326 (write-region-to-default-apollo-paste-buffer (mark) (point))
|
|
327 (message "Region Copied"))
|
|
328
|
|
329 (defun apollo-cut-region ()
|
|
330 "Copy region between point and mark to the default DM paste buffer."
|
|
331 (interactive)
|
|
332 (write-region-to-default-apollo-paste-buffer (mark) (point))
|
|
333 (kill-region (mark) (point))
|
|
334 (message "Region Cut"))
|
|
335
|
|
336 (defun apollo-paste ()
|
|
337 "Copy region between point and mark to the default DM paste buffer."
|
|
338 (interactive)
|
|
339 (let ((x (insert-contents-of-default-apollo-paste-buffer)))
|
|
340 (push-mark (+ (point) x)))
|
|
341 (message "Pasted and Mark set"))
|
|
342
|
|
343
|
|
344 ;;; Miscellaneous Commands.
|
|
345
|
|
346 (defun minibuffer-prompt-length ()
|
|
347 "Returns the length of the current minibuffer prompt."
|
|
348 (let ((window (selected-window))
|
|
349 length)
|
|
350 (select-window (minibuffer-window))
|
|
351 (let ((point (point)))
|
|
352 (goto-char (point-min))
|
|
353 (insert-char ?a 200)
|
|
354 (goto-char (point-min))
|
|
355 (vertical-motion 1)
|
|
356 (setq length (- (frame-width) (point)))
|
|
357 (goto-char (point-min))
|
|
358 (delete-char 200)
|
|
359 (goto-char point))
|
|
360 (select-window window)
|
|
361 length))
|
|
362
|
|
363 (defun extract-file-or-buffer-name-around-point (&optional buffer-flag)
|
|
364 (let ((skip-characters (if buffer-flag
|
|
365 "!#-%*-9=?-{}~:<>"
|
|
366 "!#-%*-9=?-{}~:"))
|
|
367 (skip-at-end (if buffer-flag
|
|
368 '(?@ ?. ?, ?: ?<)
|
|
369 '(?* ?@ ?. ?, ?:))))
|
|
370 (save-excursion
|
|
371 (skip-chars-backward skip-characters)
|
|
372 (let ((start (point)))
|
|
373 (skip-chars-forward skip-characters)
|
|
374 (let* ((filename (buffer-substring start (point)))
|
|
375 (last-char (aref filename (- (length filename) 1))))
|
|
376 (if (memq last-char skip-at-end)
|
|
377 (substring filename 0 -1)
|
|
378 filename))))))
|
|
379 (fset 'extract-file-name-around-point
|
|
380 'extract-file-or-buffer-name-around-point)
|
|
381 (fset 'extract-buf-or-file-name-around-point
|
|
382 'extract-file-or-buffer-name-around-point)
|
|
383
|
|
384 (defun apollo-find-file (&optional find-buffer-flag other-window)
|
|
385 "Find the file or buffer whose name the cursor is over. Buffer names are
|
|
386 matched only if the optional argument FIND-BUFFER-FLAG is non-NIL. If the
|
|
387 optional argument OTHER-WINDOW is non-NIL, the file is displayed in the other
|
|
388 window. When matching file names, ignores trailing '*' or '@' as in 'ls -F'
|
|
389 output."
|
|
390 (interactive)
|
|
391 (let* ((file-or-buffer-name
|
|
392 (extract-file-or-buffer-name-around-point find-buffer-flag))
|
|
393 (buffer (and find-buffer-flag (get-buffer file-or-buffer-name))))
|
|
394 (if (or buffer (file-exists-p file-or-buffer-name))
|
|
395 (funcall (if other-window
|
|
396 'switch-to-buffer-other-window
|
|
397 'switch-to-buffer)
|
|
398 (or buffer (find-file-noselect file-or-buffer-name)))
|
|
399 (error "Cannot find %s \"%s\""
|
|
400 (if find-buffer-flag "buffer or file" "file")
|
|
401 file-or-buffer-name))))
|
|
402
|
|
403 (defun apollo-grow-emacs-window ()
|
|
404 "Grow Emacs's Apollo window with rubberbanding."
|
|
405 (interactive)
|
|
406 (execute-dm-command "WGE"))
|
|
407
|
|
408 (defun apollo-move-emacs-window ()
|
|
409 "Move Emacs's Apollo window with rubberbanding."
|
|
410 (interactive)
|
|
411 (execute-dm-command "WME"))
|
|
412
|
|
413 (defun apollo-again ()
|
|
414 "Copy the remainder of the current line to the end of the buffer."
|
|
415 (interactive)
|
|
416 (set-mark-command nil)
|
|
417 (end-of-line)
|
|
418 (copy-region-as-kill (mark) (point))
|
|
419 (end-of-buffer)
|
|
420 (yank))
|
|
421
|
|
422 (defun apollo-exit ()
|
|
423 "Kill current buffer after saving changes."
|
|
424 (interactive)
|
|
425 (save-buffer)
|
|
426 (kill-buffer (current-buffer)))
|
|
427
|
|
428 (defun apollo-abort ()
|
|
429 "Kill current buffer without saving changes."
|
|
430 (interactive)
|
|
431 (kill-buffer (current-buffer)))
|
|
432
|
|
433 (defun apollo-aegis-help (filename)
|
|
434 "Prompt for topic and find the Apollo help file."
|
|
435 (interactive "sHelp on: ")
|
|
436 (let ((help-file (concat "/sys/help/" filename ".hlp")))
|
|
437 (with-output-to-temp-buffer "*Help File*"
|
|
438 (buffer-disable-undo standard-output)
|
|
439 (save-excursion
|
|
440 (set-buffer standard-output)
|
|
441 (insert-man-file help-file)
|
|
442 (if (> (buffer-size) 0)
|
|
443 (progn
|
|
444 (message "Cleaning help file entry...")
|
|
445 (apollo-clean-help-file)
|
|
446 (message ""))
|
|
447 (message "No help found in %s" help-file))
|
|
448 (set-buffer-modified-p nil)))))
|
|
449 (fset 'apollo-help 'apollo-aegis-help)
|
|
450
|
|
451 ;;; Make sure this will be loaded if necessary.
|
|
452
|
|
453 (autoload 'insert-man-file "man")
|
|
454
|
|
455 (defun apollo-clean-help-file ()
|
|
456 (interactive "*")
|
|
457 ;; Remove underlining and overstriking by the same letter.
|
|
458 (goto-char (point-min))
|
|
459 (while (search-forward "\b" nil t)
|
|
460 (let ((preceding (char-after (- (point) 2)))
|
|
461 (following (following-char)))
|
|
462 (cond ((= preceding following) ; x\bx
|
|
463 (delete-char -2))
|
|
464 ((= preceding ?\_) ; _\b
|
|
465 (delete-char -2))
|
|
466 ((= following ?\_) ; \b_
|
|
467 (delete-region (1- (point)) (1+ (point)))))))
|
|
468 ;; Remove overstriking and carriage returns before newline.
|
|
469 (goto-char (point-min))
|
|
470 (while (re-search-forward "\r$" nil t)
|
|
471 (replace-match ""))
|
|
472 (goto-char (point-min))
|
|
473 (while (re-search-forward "^.*\r" nil t)
|
|
474 (replace-match ""))
|
|
475 ;; Fit in 79 cols rather than 80.
|
|
476 (indent-rigidly (point-min) (point-max) -1)
|
|
477 ;; Delete excess multiple blank lines.
|
|
478 (goto-char (point-min))
|
|
479 (while (re-search-forward "\n\n\n\n*" nil t)
|
|
480 (replace-match "\n\n"))
|
|
481 ;; Remove blank lines at the beginning.
|
|
482 (goto-char (point-min))
|
|
483 (skip-chars-forward "\n")
|
|
484 (delete-region (point-min) (point))
|
|
485 ;; Separate the header from the main subject line.
|
|
486 (end-of-line)
|
|
487 (insert "\n")
|
|
488 (goto-char (point-min)))
|
|
489
|
|
490 (defun kill-whole-line ()
|
|
491 "Kill the line containing point. Try to retain column cursor is on."
|
|
492 (interactive)
|
|
493 (let ((old-column (current-column)))
|
|
494 (beginning-of-line)
|
|
495 (kill-line 1)
|
|
496 (move-to-column old-column)))
|
|
497
|
|
498 (defun apollo-key-undefined ()
|
|
499 "Signal that an Apollo Function Key is undefined."
|
|
500 (interactive)
|
|
501 (error "Apollo Function Key undefined"))
|
|
502
|
|
503
|
|
504 ;;; Define the mouse commands.
|
|
505
|
|
506 (defun apollo-mouse-move-point (&optional no-mark)
|
|
507 "Used so that pressing the left mouse button, moving the cursor, and
|
|
508 releasing the left mouse button leaves the mark set to the initial position
|
|
509 and the point set to the final position. Useful for easily marking regions
|
|
510 of text. If the left mouse button is pressed and released at the same place,
|
|
511 the mark is left at the original position of the character cursor.
|
|
512
|
|
513 Returns (x y) frame coordinates of point in columns and lines."
|
|
514 (interactive)
|
|
515 (let* ((opoint (point))
|
|
516 (owindow (selected-window))
|
|
517 (x (- (read-char) 8))
|
|
518 (y (- (read-char) 8))
|
|
519 (edges (window-edges))
|
|
520 (window nil))
|
|
521 (while (and (not (eq window (selected-window)))
|
|
522 (or (< y (nth 1 edges))
|
|
523 (>= y (nth 3 edges))
|
|
524 (< x (nth 0 edges))
|
|
525 (>= x (nth 2 edges))))
|
|
526 (setq window (next-window window))
|
|
527 (setq edges (window-edges window)))
|
|
528 (if (and window (not (eq window (selected-window))))
|
|
529 (progn
|
|
530 (if (and (not *apollo-mouse-move-point-allow-minibuffer-exit*)
|
|
531 (eq (selected-window) (minibuffer-window)))
|
|
532 (error "Cannot use mouse to leave minibuffer!"))
|
|
533 (if (eq window (minibuffer-window))
|
|
534 (error "Cannot use mouse to enter minibuffer!"))))
|
|
535 (if window (select-window window))
|
|
536 (move-to-window-line (- y (nth 1 edges)))
|
|
537 (let* ((width-1 (1- (window-width window)))
|
|
538 (wraps (/ (current-column) width-1))
|
|
539 (prompt-length (if (eq (selected-window) (minibuffer-window))
|
|
540 (minibuffer-prompt-length)
|
|
541 0)))
|
|
542 (move-to-column (+ (- x (nth 0 edges) prompt-length)
|
|
543 (* wraps width-1))))
|
|
544 (if no-mark
|
|
545 (progn (setq window (selected-window))
|
|
546 (if (eq owindow window)
|
|
547 (if (equal opoint (point))
|
|
548 (pop-mark))
|
|
549 (select-window owindow)
|
|
550 (pop-mark)
|
|
551 (select-window window)))
|
|
552 (set-mark-command nil))
|
|
553 ;; Return (x y) coords of point in column and frame line numbers.
|
|
554 (list x y)))
|
|
555
|
|
556 (defun apollo-mouse-move-mark ()
|
|
557 "Used so that pressing the left mouse button, moving the cursor, and
|
|
558 releasing the left mouse button leaves the mark set to the initial position
|
|
559 and the point set to the final position. Useful for easily marking regions
|
|
560 of text. If the left mouse button is pressed and released at the same place,
|
|
561 the mark is left at the original position of the character cursor."
|
|
562 (interactive)
|
|
563 (apollo-mouse-move-point)
|
|
564 (if (equal (point) (mark))
|
|
565 (pop-mark)))
|
|
566
|
|
567 (defun apollo-mouse-cut ()
|
|
568 "Move point to the location of the mouse cursor and
|
|
569 cut the region to the default DM paste buffer."
|
|
570 (interactive)
|
|
571 (apollo-mouse-move-mark)
|
|
572 (apollo-cut-region))
|
|
573
|
|
574 (defun apollo-mouse-copy ()
|
|
575 "Move point to the location of the mouse cursor and
|
|
576 copy the region to the default DM paste buffer."
|
|
577 (interactive)
|
|
578 (apollo-mouse-move-mark)
|
|
579 (apollo-copy-region))
|
|
580
|
|
581 (defun apollo-mouse-paste ()
|
|
582 "Move point to the location of the mouse cursor and
|
|
583 paste in the default DM paste buffer."
|
|
584 (interactive)
|
|
585 (apollo-mouse-move-point)
|
|
586 (apollo-paste))
|
|
587
|
|
588 (defun apollo-mouse-pop-buffer ()
|
|
589 "Used in conjunction with the 'list-buffers' command, moves
|
|
590 point to cursor location and displays buffer named on current line.
|
|
591 Similar to a DM pop window by name to top."
|
|
592 (interactive)
|
|
593 (apollo-mouse-move-point)
|
|
594 (Buffer-menu-select))
|
|
595
|
|
596 (defun apollo-mouse-find-file ()
|
|
597 "Find the file or buffer whose name the cursor is over. Buffers are only
|
|
598 allowed when in the '*Buffer List*' buffer. When matching file names, ignores
|
|
599 trailing '*' or '@' as in 'ls -F' output."
|
|
600 (interactive)
|
|
601 (apollo-mouse-move-point)
|
|
602 (let ((find-buffer-flag
|
|
603 (equal (buffer-name (current-buffer)) "*Buffer List*")))
|
|
604 (apollo-find-file find-buffer-flag nil)))
|
|
605
|
|
606 (defun apollo-mouse-find-file-other-window ()
|
|
607 "Find the file or buffer whose name the cursor is over. Buffers are only
|
|
608 allowed when in the '*Buffer List*' buffer. When matching file names, ignores
|
|
609 trailing '*' or '@' as in 'ls -F' output. The file or buffer is displayed in
|
|
610 the other window."
|
|
611 (interactive)
|
|
612 (apollo-mouse-move-point)
|
|
613 (let ((find-buffer-flag
|
|
614 (equal (buffer-name (current-buffer)) "*Buffer List*")))
|
|
615 (apollo-find-file find-buffer-flag t))
|
|
616 (other-window 1))
|
|
617
|
|
618
|
|
619 ;;; Define and Enable the Mouse Key Bindings.
|
|
620
|
|
621 (defun apollo-mouse-defaults ()
|
|
622 "Set up default Apollo mouse key bindings for GNU Emacs."
|
|
623 (interactive)
|
|
624 (bind-apollo-mouse-button "M1D" 'apollo-mouse-move-point
|
|
625 'apollo-mouse-move-point) ;MOUSE LEFT DOWN
|
|
626 (bind-apollo-mouse-button "M1U" 'apollo-mouse-move-mark
|
|
627 'apollo-mouse-copy) ;MOUSE LEFT UP
|
|
628 (bind-apollo-mouse-button "M2D" 'sm-depress
|
|
629 'sm-depress-meta) ;MOUSE MIDDLE DOWN
|
|
630 (bind-apollo-mouse-button "M2U" 'smart-key-mouse
|
|
631 'smart-key-mouse-meta) ;MOUSE MIDDLE UP
|
|
632 (bind-apollo-mouse-button "M3D" 'sm-depress-meta) ;MOUSE RIGHT DOWN
|
|
633 (bind-apollo-mouse-button "M3U" 'smart-key-mouse-meta) ;MOUSE RIGHT UP
|
|
634 )
|
|
635 (apollo-mouse-defaults)
|
|
636
|
|
637 (defun apollo-mouse-cut-copy-paste ()
|
|
638 "Sets Apollo mouse keys to perform DM-style cut, copy, and paste.
|
|
639 LEFT MOUSE DOWN moves point to cursor location. LEFT MOUSE UP sets
|
|
640 mark, moves point to cursor location and cuts region. MID MOUSE works
|
|
641 the same way but does a copy. RIGHT MOUSE sets point and pastes at
|
|
642 cursor location. These key bindings are also effective in DM windows
|
|
643 until \\[apollo-mouse-cancel-cut-copy-paste] is executed in the GNU Emacs DM
|
|
644 window."
|
|
645 (interactive)
|
|
646 (bind-apollo-mouse-button "M1D" 'apollo-mouse-move-point) ;MOUSE LEFT DOWN
|
|
647 (bind-apollo-mouse-button "M1U" 'apollo-mouse-cut) ;MOUSE LEFT UP
|
|
648 (bind-apollo-mouse-button "M2D" 'apollo-mouse-move-point) ;MOUSE MIDDLE DOWN
|
|
649 (bind-apollo-mouse-button "M2U" 'apollo-mouse-copy) ;MOUSE MIDDLE UP
|
|
650 (bind-apollo-mouse-button "M3D" 'apollo-mouse-paste) ;MOUSE RIGHT DOWN
|
|
651 (unbind-apollo-mouse-button "M3U") ;MOUSE RIGHT UP
|
|
652 (message "Mouse Edit Mode: left=cut, mid=copy, right=paste")
|
|
653 (execute-dm-command "msg 'Mouse Edit Mode: left=cut, mid=copy, right=paste';kd m1 dr;echo ke;kd m1u xd ke;kd m2 dr;echo ke;kd m2u xc ke; kd m3 xp ke;kd m3u ke")
|
|
654 )
|
|
655
|
|
656 (defun apollo-mouse-cancel-cut-copy-paste ()
|
|
657 "Sets Apollo mouse keys back to defaults with GNU Emacs and personal
|
|
658 settings within the DM."
|
|
659 (interactive)
|
|
660 (apollo-mouse-defaults)
|
|
661 (message "Default mouse key bindings set")
|
|
662 (execute-dm-command
|
|
663 (concat "msg 'Mouse Edit Mode canceled; personal mouse keys restored';"
|
|
664 "cmdf " *dm-mouse-key-bindings-file*))
|
|
665 )
|
|
666
|
|
667 ;;; Define and Enable the Function Key Bindings.
|
|
668
|
|
669 (bind-apollo-function-key "TABS" "\C-I") ;Shift TAB
|
|
670 (bind-apollo-function-key "TABC" "\C-I") ;Control TAB
|
|
671 (bind-apollo-function-key "RETS" "\C-M") ;Shift RET
|
|
672 (bind-apollo-function-key "RETC" "\C-M") ;Control RET
|
|
673 (bind-apollo-function-key "LINE_DEL" 'kill-whole-line) ;LINE DEL
|
|
674 (bind-apollo-function-key "CHAR_DEL" "\C-D") ;CHAR DEL
|
|
675 (bind-apollo-function-key "L_BAR_ARROW" "\C-A") ;LEFT BAR ARROW
|
|
676 (bind-apollo-function-key "R_BAR_ARROW" "\C-E") ;RIGHT BAR ARROW
|
|
677 (bind-apollo-function-key "L_BOX_ARROW" "\C-x>") ;LEFT BOX ARROW
|
|
678 (bind-apollo-function-key "UP_ARROW" "\C-P") ;UP ARROW
|
|
679 (bind-apollo-function-key "L8S" "\M-1\M-V") ;Shift UP ARROW
|
|
680
|
|
681 ;;; RIGHT BOX ARROW is the Default Meta Key. If the Meta Key is changed with
|
|
682 ;;; SELECT-APOLLO-META-KEY, then RIGHT BOX ARROW signals an error.
|
|
683
|
|
684 (select-apollo-meta-key "R1") ; Make POP the META key instead.
|
|
685 (bind-apollo-function-key "R_BOX_ARROW" "\C-x<") ;RIGHT BOX ARROW
|
|
686 (bind-apollo-function-key "LEFT_ARROW" "\C-B") ;LEFT ARROW
|
|
687 (bind-apollo-function-key "RIGHT_ARROW" "\C-F") ;RIGHT ARROW
|
|
688 (bind-apollo-function-key "DOWN_ARROW" "\C-N") ;DOWN ARROW
|
|
689 (bind-apollo-function-key "LES" "\M-1\C-V") ;Shift DOWN ARROW
|
|
690 (bind-apollo-function-key "R3S" 'apollo-find-file) ;Shift READ
|
|
691 (bind-apollo-function-key "MARK" 'set-mark-command) ;MARK
|
|
692 (bind-apollo-function-key "INS_MODE" 'overwrite-mode) ;INS MODE
|
|
693 (bind-apollo-function-key "L2S" "\C-Y") ;Shift LINE DEL
|
|
694 (bind-apollo-function-key "L3S" "\C-D") ;Shift CHAR DEL
|
|
695 (bind-apollo-function-key "COPY" 'apollo-copy-region) ;COPY
|
|
696 (bind-apollo-function-key "CUT" 'apollo-cut-region) ;CUT
|
|
697 (bind-apollo-function-key "PASTE" 'apollo-paste) ;PASTE
|
|
698 (bind-apollo-function-key "UNDO" 'undo) ;UNDO
|
|
699 (bind-apollo-function-key "GROW" 'apollo-grow-emacs-window) ;GROW
|
|
700 (bind-apollo-function-key "MOVE" 'apollo-move-emacs-window) ;MOVE
|
|
701 (bind-apollo-function-key "LAS" "\M-B") ;Shift LEFT ARROW
|
|
702 (bind-apollo-function-key "LCS" "\M-F") ;Shift RIGHT ARROW
|
|
703 (bind-apollo-function-key "UP_BOX_ARROW" "\M-V") ;UP BOX ARROW
|
|
704 (bind-apollo-function-key "LDS" "\M-<") ;Shift UP BOX ARROW
|
|
705 (bind-apollo-function-key "DOWN_BOX_ARROW" "\C-V") ;DOWN BOX ARROW
|
|
706 (bind-apollo-function-key "LFS" "\M->") ;Shift DOWN BOX ARROW
|
|
707 (bind-apollo-function-key "AGAIN" 'apollo-again) ;AGAIN
|
|
708 (bind-apollo-function-key "EXIT" 'apollo-exit) ;EXIT
|
|
709 (bind-apollo-function-key "ABORT" 'apollo-abort) ;ABORT
|
|
710 (bind-apollo-function-key "SAVE" 'save-buffer) ;SAVE
|
|
711 (bind-apollo-function-key "HOLD" 'apollo-key-undefined) ;HOLD
|
|
712
|
|
713 (defun install-apollo-dm-preemptive-key-bindings ()
|
|
714 (bind-apollo-function-key "L4S" "\M-<") ;Shift LEFT BAR ARROW
|
|
715 (bind-apollo-function-key "L5" 'execute-dm-command) ;CMD
|
|
716 (bind-apollo-function-key "L6S" "\M->") ;Shift RIGHT BAR ARROW
|
|
717 (bind-apollo-function-key "LB" 'other-window) ;NEXT WNDW
|
|
718 (bind-apollo-function-key "LBS" 'delete-window) ;Shift NEXT WNDW
|
|
719 (bind-apollo-function-key "READ" 'find-file-read-only) ;READ
|
|
720 (bind-apollo-function-key "EDIT" 'find-file) ;EDIT
|
|
721 (bind-apollo-function-key "SHELL" 'shell) ;SHELL
|
|
722 (bind-apollo-function-key "UNIXHELP" 'manual-entry) ;HELP
|
|
723 (bind-apollo-function-key "AEGISHELP" 'apollo-aegis-help)) ;HELP
|
|
724
|
|
725 (if *preempt-display-manager-bindings*
|
|
726 (install-apollo-dm-preemptive-key-bindings))
|
|
727
|
|
728 (run-hooks '*apollo-key-bindings-hook*)
|
|
729
|
|
730 (provide 'apollo)
|
|
731
|
|
732 ;;; apollo.el ends here
|