lisp/term/apollo.el

   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