Mercurial > hg > xemacs-beta

comparison lisp/term/apollo.el @ 239:41f2f0e326e9 r20-5b18

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-5b18
author cvs
date Mon, 13 Aug 2007 10:15:48 +0200
parents 376386a54a3c
children
comparison
equal deleted inserted replaced
238:b5f2e56b938d 239:41f2f0e326e9
1 (load "term/vt100" nil t) 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