Mercurial > hg > xemacs-beta
comparison lisp/packages/mode-motion+.el @ 0:376386a54a3c r19-14
Import from CVS: tag r19-14
| author | cvs |
|---|---|
| date | Mon, 13 Aug 2007 08:45:50 +0200 |
| parents | |
| children | ac2d302a0011 |
comparison
equal
deleted
inserted
replaced
| -1:000000000000 | 0:376386a54a3c |
|---|---|
| 1 ;; -*- Syntax: Emacs-Lisp; Mode: emacs-lisp -*- | |
| 2 ;; | |
| 3 ;; Per mode and per buffer mouse tracking with highlighting | |
| 4 ;; | |
| 5 ;; Copyright (C) 1992, 1993 by Guido Bosch <Guido.Bosch@loria.fr> | |
| 6 | |
| 7 ;; This file is written in GNU Emacs Lisp, It is a part of XEmacs. | |
| 8 | |
| 9 ;; The software contained in this file is free software; you can | |
| 10 ;; redistribute it and/or modify it under the terms of the GNU General | |
| 11 ;; Public License as published by the Free Software Foundation; either | |
| 12 ;; version 2, or (at your option) any later version. | |
| 13 | |
| 14 ;; GNU Emacs is distributed in the hope that it will be useful, | |
| 15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
| 16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
| 17 ;; GNU General Public License for more details. | |
| 18 | |
| 19 ;; You should have received a copy of the GNU General Public License | |
| 20 ;; along with GNU Emacs; see the file COPYING. If not, write to | |
| 21 ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. | |
| 22 ;; | |
| 23 ;;; Synched up with: Not in FSF. | |
| 24 | |
| 25 ;; Please send bugs and comments to Russell.Ritchie@gssec.bt.co.uk or | |
| 26 ;; tlp00@spg.amdahl.com. | |
| 27 ;; | |
| 28 ;; <DISCLAIMER> | |
| 29 ;; This program is still under development. Neither the author nor any | |
| 30 ;; of the maintainers accepts responsibility to anyone for the consequences of | |
| 31 ;; using it or for whether it serves any particular purpose or works | |
| 32 ;; at all. | |
| 33 | |
| 34 ; Change History | |
| 35 ; Revision 3.15 Thu Feb 15 14:26:34 GMT 1996 Russell.Ritchie@gssec.bt.co.uk | |
| 36 ; lisp-interaction-popup-menu => lisp-interaction-mode-popup-menu, | |
| 37 ; emacs-lisp-popup-menu => emacs-lisp-mode-popup-menu. | |
| 38 | |
| 39 ; Revision 3.14 Tue Nov 14 11:14:38 GMT 1995 Russell.Ritchie@gssec.bt.co.uk | |
| 40 ; Made nil the default value for mode-motion-focus-on-window. Too many people | |
| 41 ; hate it when the cursor warps into Dired and GNUS buffers because some | |
| 42 ; window managers auto-raise the window with keyboard focus with predictably | |
| 43 ; nauseous results. | |
| 44 | |
| 45 ; Revision 3.13 Thu Sep 14 10:30:04 1995 Russell.Ritchie@gssec.bt.co.uk | |
| 46 ; Fix the `spontaneous scrolling' problem (at last). It's funny how | |
| 47 ; easy things are once you actually understand the issues involved. | |
| 48 ; As ever, what we sought was the right question... | |
| 49 | |
| 50 ; Revision 3.12 Wed Jul 12 11:30:43 1995 Russell.Ritchie@gssec.bt.co.uk | |
| 51 ; Track `don't highlight non-file lines in dired buffers' functionality (in a | |
| 52 ; pretty tasteless manner if I say so myself :-)). | |
| 53 | |
| 54 ; Revision 3.11 Fri Jul 7 16:26:56 1995 Russell.Ritchie@gssec.bt.co.uk | |
| 55 ; Minor extent detaching bug fix. | |
| 56 | |
| 57 ; Revision 3.10 Thu Jun 15 11:36:56 1995 Russell.Ritchie@gssec.bt.co.uk | |
| 58 ; Quiet, faster, non-interactive initialistion, mild list-motion-handlers | |
| 59 ; chrome and minor formatting clean-ups. | |
| 60 | |
| 61 ; Revision 3.9 Thu Jun 15 11:36:56 1995 Russell.Ritchie@gssec.bt.co.uk | |
| 62 ; Fixed the `mouse-motion whilst reading filename in minibuffer auto-ftp' bug. | |
| 63 | |
| 64 ; Revision 3.8 Thus Mar 23 1995 tlp00@spg.amdahl.com | |
| 65 ; added in menu controls from paquette@atomas.crim.ca | |
| 66 ; re-added minibuffer support (from 3.5) | |
| 67 ; | |
| 68 ; Revision 3.7 Tue Feb 21 11:06:38 1995 Russell.Ritchie@gssec.bt.co.uk | |
| 69 ; Extended mode-motion+-religion and made the defaulting frame-buffer aware. | |
| 70 ; Reworked and added new mode-motion-handlers. | |
| 71 ; Doc string clean up. | |
| 72 ; Fixed unintentional frame/screen reversion. | |
| 73 | |
| 74 ; Revision 3.6 Mon Feb 20 11:46:32 1995 Russell.Ritchie@gssec.bt.co.uk | |
| 75 ; Made mouse tracking use mode-motion-hook for better integration with | |
| 76 ; the default mouse-motion system (help-echo and friends now work). | |
| 77 | |
| 78 ; Revision 3.5 1995/02/16 13:40:00 tlp00@spg.amdahl.com | |
| 79 ; fixed sporatic scroll bug | |
| 80 ; added M-button2 binding for mode-motion-copy | |
| 81 ; | |
| 82 ; Revision 3.4 1995/02/14 14:30:15 Russell.Ritchie@gssec.bt.co.uk | |
| 83 ; Small code cleanups: let* -> let, duplicate defvars. | |
| 84 ; Chromed list-motion-handlers a little. | |
| 85 ; Added variable mode-motion+-religion for easy choice twixt underline & bold. | |
| 86 | |
| 87 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;tlp00 changes ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 88 | |
| 89 ; tlp00@spg.amdahl.com 2/11/93 | |
| 90 ; modified mode-motion-track-pointer to move cursor cross windows | |
| 91 ; renamed mode-motion-delete to mode-motion-kill to follow kill | |
| 92 ; convention | |
| 93 ; mode-motion-highlight-with-handler to put cursor at beginning of line | |
| 94 ; follow operations. | |
| 95 ; mode-motion-copy/delete and mode-motion-kill to position cursor at | |
| 96 ; delete point start. Also set this-command to avoid appends | |
| 97 ; set mode-motion-extent priority to 1, so it will override font-lock | |
| 98 ; changed default handlers for buffer-mode, c-mode, dired-mode, added occur | |
| 99 ; and compilation mode. | |
| 100 ; fixed bug in minibuffer-selection-boundaries where C-g was leaving the wrong | |
| 101 ; syntax table. | |
| 102 ; added support for pending-delete. | |
| 103 ; adds the copy/delete motion-extent to the clipboard even if kill-hooks is nil. | |
| 104 ; | |
| 105 ; Revision 3.3 1995/02/13 tlp00@spg.amdahl.com | |
| 106 ; merged Russell.Ritchie@gssec.bt.co.uk versions with molli/bosch versions | |
| 107 ; renamed versioning 3.0+ for molli/bosch versions. | |
| 108 ; | |
| 109 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Russell Ritchie changes;;;;;;;;;;;;;;;;;;;;;;;; | |
| 110 ; !Log: mode-motion+.el,v ! | |
| 111 ; Revision 2.14.R 1994/09/09 10:19:18 rieke@darmstadt.gmd.de | |
| 112 ; Merged in my changes to support motion-gray. This needs a file | |
| 113 ; named "gray1.xbm" in your data-directory (etc) like the following. | |
| 114 ; -------------------------------snip-------------------------- | |
| 115 ; #define bg2_width 16 | |
| 116 ; #define bg2_height 16 | |
| 117 ; static char bg2_bits[] = { | |
| 118 ; 0x55, 0x55, 0x00, 0x00, 0x55, 0x55, 0x00, 0x00, 0x55, 0x55, 0x00, 0x00, | |
| 119 ; 0x55, 0x55, 0x00, 0x00, 0x55, 0x55, 0x00, 0x00, 0x55, 0x55, 0x00, 0x00, | |
| 120 ; 0x55, 0x55, 0x00, 0x00, 0x55, 0x55, 0x00, 0x00}; | |
| 121 ; -------------------------------snip-------------------------- | |
| 122 ; This one looks good on SUN 19'' screens with 10x20 font, | |
| 123 ; black foreground and khaki background. | |
| 124 ; To use the gray-handlers instead of the underline-handlers | |
| 125 ; include the following into your .emacs: | |
| 126 ; (set-mode-motion-handler 'emacs-lisp-mode 'gray-thing) | |
| 127 ; (set-mode-motion-handler 'lisp-interaction-mode 'gray-thing) | |
| 128 ; (set-mode-motion-handler 'c++-mode 'gray-c) | |
| 129 ; (set-mode-motion-handler 'c-mode 'gray-c) | |
| 130 ; (set-mode-motion-handler 'tcl-mode 'gray-tcl) | |
| 131 ; (set-mode-motion-handler 'dired-mode 'gray-line@) | |
| 132 ; (set-mode-motion-handler 'gnus-group-mode 'gray-vline@) | |
| 133 ; (set-mode-motion-handler 'gnus-summary-mode 'gray-vline@) | |
| 134 ; (set-mode-motion-handler 'texinfo-mode 'gray-Texinfo) | |
| 135 ; (setq default-motion-handler (find-motion-handler 'gray-thing)) | |
| 136 ; | |
| 137 ; | |
| 138 ; Revision 2.13.R 1994/08/08 19:47:34 Russell.Ritchie@gssec.bt.co.uk | |
| 139 ; Made default handler be underline-thing, as most bold fonts seem to | |
| 140 ; be greater in height than their corresponding normal versions, | |
| 141 ; causing irritating screen flicker. | |
| 142 ; | |
| 143 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Molli/bosch changes;;;;;;;;;;;;;;;;;;;;;;;; | |
| 144 ; | |
| 145 ; Revision 3.2 1994/09/28 15:14:29 molli | |
| 146 ; add "(set-mode-motion-handler 'latex-mode 'raise-LaTeX)". Barry | |
| 147 ; Waraw's C/C++ mode is now changed to cc-mode ... | |
| 148 ; | |
| 149 ; Revision 3.1 1994/09/28 15:10:36 molli | |
| 150 ; Initial revision | |
| 151 ; | |
| 152 ; Revision 2.15 1993/11/18 08:13:28 bosch | |
| 153 ; Constant `mode-motion+-version' added. | |
| 154 ; Minor bug fix in `tcl-forward-sexp1'. | |
| 155 ; | |
| 156 ; Revision 2.14 1993/10/29 20:04:59 bosch | |
| 157 ; Minibuffer name matching improved. Made `tcl-boundaries' smarter by | |
| 158 ; use of new function `tcl-forward-sexp1'. `tcl-commands' list updated | |
| 159 ; -- should be complete now. A message is printed if the syntax scanner | |
| 160 ; matched or failed for known tcl/tk commands. Seperated `tcl-commands' | |
| 161 ; from `tk-commands' -- `tk-commands' not yet complete. New motion | |
| 162 ; handler `raise-LaTeX' added, for tex-mode. | |
| 163 ; | |
| 164 ; Revision 2.13 1993/10/08 09:43:00 bosch | |
| 165 ; New user option `mode-motion-setup-cut-and-paste-bindings'. Function | |
| 166 ; `mode-motion-copy/delete' now takes into account the primary and the | |
| 167 ; motion selection. | |
| 168 ; | |
| 169 ; Revision 2.12 1993/10/08 09:08:46 bosch | |
| 170 ; Avoid highlighting empty lines, even if | |
| 171 ; `mode-motion-highlight-lines-when-behind' is non-nil. | |
| 172 | |
| 173 ; Revision 2.12 1994/07/07 18:33:38 Russell.Ritchie@gssec.bt.co.uk | |
| 174 ; Made list-motion-handlers and mode-motion-set-handler work in lemacs-19.10. | |
| 175 ; | |
| 176 ; Revision 2.11 1993/09/20 08:29:15 bosch | |
| 177 ; Code reorganized: variables declared before used. | |
| 178 ; Compatibility hack patched again. | |
| 179 ; | |
| 180 ; Revision 2.10 1993/09/17 18:50:33 bosch | |
| 181 ; Bug in the compatibility hack fixed. Call to `make-cursor' replaced by | |
| 182 ; `x-pointer-cache'. Compatibility hack for Lemacs 19.8 removed. Tcl | |
| 183 ; motion handler improved (needs still some work). | |
| 184 ; | |
| 185 ; Revision 2.9 1993/09/15 17:52:53 bosch | |
| 186 ; Compatibility patch for Lucid Emacs 19.8. tcl motion handler added. | |
| 187 ; | |
| 188 ; Revision 2.8 1993/08/27 15:17:07 bosch | |
| 189 ; Select window conflict between motion handlers and process filters | |
| 190 ; resolved by using `enqueue-eval-event' for selecting a different | |
| 191 ; window (functions `mode-motion-track-pointer' and | |
| 192 ; `mode-motion-highlight-with-handler' modified). This fixes the nasty | |
| 193 ; bug that made GNUS hanging during NNTP activity while the mouse was | |
| 194 ; moved. | |
| 195 ; | |
| 196 ; Revision 2.7 1993/08/27 12:50:10 bosch | |
| 197 ; TeX and LaTeX motion handler generalized. Motion handler | |
| 198 ; `highlight-Texinfo' added. | |
| 199 ; | |
| 200 ; Revision 2.6 1993/06/24 11:58:52 bosch | |
| 201 ; Mode motion+ support for pcl-cvs added. #undef syntax for C added. | |
| 202 ; | |
| 203 ; Revision 2.5 1993/06/09 12:04:31 bosch | |
| 204 ; Delivery motion handlers for `c++-c-mode', `gnus-group-mode', and | |
| 205 ; `gnus-summary-mode' added. Mode motion commands bound to copy/cut/past | |
| 206 ; keys for Sun keyboards (f16, f18, f20). Comment added. | |
| 207 ; | |
| 208 ; Revision 2.4 1993/02/15 12:59:47 bosch | |
| 209 ; Modifications sent by Tibor Polgar integrated: | |
| 210 ; Optional parameter added to `mode-motion-copy/delete'. User option | |
| 211 ; `mode-motion-focus-on-window' added. It controls window selection for | |
| 212 ; the motion handlers. Minor changes of the delivery motion handlers. | |
| 213 ; | |
| 214 ; Revision 2.3 1993/02/04 18:10:09 bosch | |
| 215 ; User option `mode-motion-minibuffer-completion' added. It controls | |
| 216 ; the minibuffer completion highlighting. | |
| 217 ; | |
| 218 ; Revision 2.2 1993/01/27 13:08:12 bosch | |
| 219 ; Improved clearing of `sticky' mode-motion-extents when leaving screen | |
| 220 ; or buffer. Function `mode-motion-clear-extent' added. | |
| 221 ; Highlight line mouse cursor is behind. | |
| 222 ; `mode-motion-highlight-with-handler' now takes an event as argument. | |
| 223 ; Cut and paste functions renamed and rewritten. Now they are called: | |
| 224 ; `mode-motion-move', `mode-motion-delete', `mode-motion-copy', | |
| 225 ; `mode-motion-copy-as-kill'. Bug fixes in the C scanner stuff. | |
| 226 ; Motion handler `underline-c' added. | |
| 227 ; | |
| 228 ; Revision 2.1 1993/01/19 18:29:58 bosch | |
| 229 ; Scanner and motion handler for C syntax added. | |
| 230 ; Function `set-default-motion-handler' added. | |
| 231 ; Minor improvements on the `list-motion-handlers' interface done. | |
| 232 ; Minor bug fixes. | |
| 233 ; | |
| 234 ; Revision 2.0 1993/01/14 19:17:29 bosch | |
| 235 ; Lot of things rewritten and reorganized. This version fits in only | |
| 236 ; one file (beside the required package thing.el). | |
| 237 ; | |
| 238 ; New basic features are: | |
| 239 ; - buffer, mode and default motion handlers | |
| 240 ; - easy composition of own motion handlers | |
| 241 ; - listing of motion handlers in tabular form | |
| 242 ; - menu interface for changing motion handlers | |
| 243 ; - only two elisp files: mode-motion+.el, thing.el | |
| 244 ; | |
| 245 | |
| 246 (require 'thing) | |
| 247 (require 'mode-motion) | |
| 248 (defconst mode-motion+-version "3.15") | |
| 249 | |
| 250 ;;; This file defines a set of mouse motion handlers that do some | |
| 251 ;;; highlighting of the text when the mouse moves over. | |
| 252 ;;; An exhaustive list of the motion handlers defined in this file may be | |
| 253 ;;; obtained with M-x list-motion-handlers. | |
| 254 ;;; User Options and their Custommisation | |
| 255 ;;; | |
| 256 ;;; Mode-motion+ provides four user options, defined beyond. See their | |
| 257 ;;; documentation string to know what they are good for. If you want | |
| 258 ;;; to modify their default values, just setq them in your ~/.emacs. | |
| 259 | |
| 260 (defvar mode-motion+-religion nil ; Initialised in mode-motion-init. | |
| 261 "*Default highlight religion: one of bold, gray, highlight, invert or underline. | |
| 262 | |
| 263 Unless you setq this otherwise, it defaults to underline when | |
| 264 (x-display-color-p) is non-nil and invert otherwise. | |
| 265 Setting it to 'highlight should cause mode-motion+ extents to be | |
| 266 indistinguishable from any other type of highlighted extent which may or may | |
| 267 not be advisable, depending on your point of view.") | |
| 268 | |
| 269 (defvar mode-motion-highlight-lines-when-behind t | |
| 270 "*If non-nil highlight the whole line if the mouse is past the end.") | |
| 271 | |
| 272 (defvar mode-motion-focus-on-window nil | |
| 273 "*Controls whether moving the mouse into another window selects this window. | |
| 274 The following values are possible: | |
| 275 | |
| 276 nil - Window selection isn't influenced at all by mode motion. | |
| 277 | |
| 278 t - Window selection always follows the mouse cursor. Copying motion | |
| 279 active regions doesn't work any longer between different buffers. | |
| 280 | |
| 281 any other - window selection follows the mouse cursor if the motion handler | |
| 282 of the buffer under the mouse has the follow-point property set. | |
| 283 Useful for selecting line mode buffers just by moving the mouse | |
| 284 inside in order to execute commands there (VM summary, | |
| 285 GNUS Group and Subject, DIRED, Buffer menu etc.)") | |
| 286 | |
| 287 (defvar mode-motion-setup-cut-and-paste-bindings t | |
| 288 "*If non-nil, bind commands to the Copy, Paste and Cut keys.") | |
| 289 | |
| 290 ;; Options sub-menu for mode-motion+ | |
| 291 (defvar mode-motion+-options-menu | |
| 292 '("Motion Highlighting" | |
| 293 "For Current Buffer" | |
| 294 "---" | |
| 295 ["None" | |
| 296 (progn | |
| 297 (set-buffer-motion-handler (current-buffer) 'no-thing) | |
| 298 (mode-motion-clear-extent)) | |
| 299 :style radio | |
| 300 :selected (eq (mode-motion+-buffer-handler-religion (current-buffer)) | |
| 301 'no) | |
| 302 :active (mode-motion+-active-p)] | |
| 303 ["Bold" | |
| 304 (progn | |
| 305 (modify-buffer-motion-handler (current-buffer) 'bold)) | |
| 306 :style radio | |
| 307 :selected (eq (mode-motion+-buffer-handler-religion (current-buffer)) | |
| 308 'bold) | |
| 309 :active (mode-motion+-active-p)] | |
| 310 ["Underline" | |
| 311 (progn | |
| 312 (modify-buffer-motion-handler (current-buffer) 'underline)) | |
| 313 :style radio | |
| 314 :selected (eq (mode-motion+-buffer-handler-religion (current-buffer)) | |
| 315 'underline) | |
| 316 :active (mode-motion+-active-p)] | |
| 317 ["Gray" | |
| 318 (progn | |
| 319 (modify-buffer-motion-handler (current-buffer) 'gray)) | |
| 320 :style radio | |
| 321 :selected (eq (mode-motion+-buffer-handler-religion (current-buffer)) | |
| 322 'gray) | |
| 323 :active (mode-motion+-active-p)] | |
| 324 ["Highlight" | |
| 325 (progn | |
| 326 (modify-buffer-motion-handler (current-buffer) 'highlight)) | |
| 327 :style radio | |
| 328 :selected (eq (mode-motion+-buffer-handler-religion (current-buffer)) | |
| 329 'highlight) | |
| 330 :active (mode-motion+-active-p)] | |
| 331 ["Invert" | |
| 332 (progn | |
| 333 (modify-buffer-motion-handler (current-buffer) 'invert)) | |
| 334 :style radio | |
| 335 :selected (eq (mode-motion+-buffer-handler-religion (current-buffer)) | |
| 336 'invert) | |
| 337 :active (mode-motion+-active-p)] | |
| 338 "---" | |
| 339 "For Current Mode" | |
| 340 "---" | |
| 341 ["None" | |
| 342 (progn | |
| 343 (set-mode-motion-handler major-mode 'no-thing) | |
| 344 (mode-motion-clear-extent)) | |
| 345 :style radio | |
| 346 :selected (eq (mode-motion+-mode-handler-religion major-mode) 'no) | |
| 347 :active (mode-motion+-active-p)] | |
| 348 ["Bold" | |
| 349 (progn | |
| 350 (modify-mode-motion-handler major-mode 'bold)) | |
| 351 :style radio | |
| 352 :selected (eq (mode-motion+-mode-handler-religion major-mode) 'bold) | |
| 353 :active (mode-motion+-active-p)] | |
| 354 ["Underline" | |
| 355 (progn | |
| 356 (modify-mode-motion-handler major-mode 'underline)) | |
| 357 :style radio | |
| 358 :selected (eq (mode-motion+-mode-handler-religion major-mode) 'underline) | |
| 359 :active (mode-motion+-active-p)] | |
| 360 ["Gray" | |
| 361 (progn | |
| 362 (modify-mode-motion-handler major-mode 'gray)) | |
| 363 :style radio | |
| 364 :selected (eq (mode-motion+-mode-handler-religion major-mode) 'gray) | |
| 365 :active (mode-motion+-active-p)] | |
| 366 ["Highlight" | |
| 367 (progn | |
| 368 (modify-mode-motion-handler major-mode 'highlight)) | |
| 369 :style radio | |
| 370 :selected (eq (mode-motion+-mode-handler-religion major-mode) 'highlight) | |
| 371 :active (mode-motion+-active-p)] | |
| 372 ["Invert" | |
| 373 (progn | |
| 374 (modify-mode-motion-handler major-mode 'invert)) | |
| 375 :style radio | |
| 376 :selected (eq (mode-motion+-mode-handler-religion major-mode) 'invert) | |
| 377 :active (mode-motion+-active-p)] | |
| 378 "---" | |
| 379 "For All" | |
| 380 "---" | |
| 381 ["None" | |
| 382 (progn | |
| 383 (setq mode-motion+-religion 'no) | |
| 384 (mode-motion-init-handlers-according-to-religion 'force) | |
| 385 (mode-motion-clear-extent)) | |
| 386 :style radio | |
| 387 :selected (eq mode-motion+-religion 'no) | |
| 388 :active (mode-motion+-active-p)] | |
| 389 ["Bold" | |
| 390 (progn | |
| 391 (setq mode-motion+-religion 'bold) | |
| 392 (mode-motion-init-handlers-according-to-religion 'force)) | |
| 393 :style radio | |
| 394 :selected (eq mode-motion+-religion 'bold) | |
| 395 :active (mode-motion+-active-p)] | |
| 396 ["Underline" | |
| 397 (progn | |
| 398 (setq mode-motion+-religion 'underline) | |
| 399 (mode-motion-init-handlers-according-to-religion 'force)) | |
| 400 :style radio | |
| 401 :selected (eq mode-motion+-religion 'underline) | |
| 402 :active (mode-motion+-active-p)] | |
| 403 ["Gray" | |
| 404 (progn | |
| 405 (setq mode-motion+-religion 'gray) | |
| 406 (mode-motion-init-handlers-according-to-religion 'force)) | |
| 407 :style radio | |
| 408 :selected (eq mode-motion+-religion 'gray) | |
| 409 :active (mode-motion+-active-p)] | |
| 410 ["Highlight" | |
| 411 (progn | |
| 412 (setq mode-motion+-religion 'highlight) | |
| 413 (mode-motion-init-handlers-according-to-religion 'force)) | |
| 414 :style radio | |
| 415 :selected (eq mode-motion+-religion 'highlight) | |
| 416 :active (mode-motion+-active-p)] | |
| 417 ["Invert" | |
| 418 (progn | |
| 419 (setq mode-motion+-religion 'invert) | |
| 420 (mode-motion-init-handlers-according-to-religion 'force)) | |
| 421 :style radio | |
| 422 :selected (eq mode-motion+-religion 'invert) | |
| 423 :active (mode-motion+-active-p)] | |
| 424 "---" | |
| 425 ["Minibuffer highlighting" (setq mode-motion-use-minibuffer-motion-handler | |
| 426 (not mode-motion-use-minibuffer-motion-handler)) | |
| 427 :style toggle :selected mode-motion-use-minibuffer-motion-handler] | |
| 428 | |
| 429 ["Customize..." | |
| 430 (list-motion-handlers) | |
| 431 t | |
| 432 ;; nil | |
| 433 ] | |
| 434 ["Revert Customization" | |
| 435 (call-interactively 'mode-motion+-motion-hook-revert) | |
| 436 (and (boundp 'mode-motion+-previous-hook) mode-motion+-previous-hook) | |
| 437 ]) | |
| 438 "Menu for changing mode-motion+ religion and other things.") | |
| 439 | |
| 440 (defun mode-motion+-active-p () | |
| 441 (cond ((symbolp mode-motion-hook) | |
| 442 (eq mode-motion-hook 'mode-motion+-highlight)) | |
| 443 ((listp mode-motion-hook) | |
| 444 (memq 'mode-motion+-highlight mode-motion-hook)) | |
| 445 (t nil))) | |
| 446 | |
| 447 (defun mode-motion+-buffer-handler-religion (buffer) | |
| 448 (let* ((current-handler-name (symbol-name (motion-handler-name | |
| 449 (get-current-motion-handler)))) | |
| 450 (religion-name (substring current-handler-name | |
| 451 0 | |
| 452 (string-match "-" current-handler-name)))) | |
| 453 (intern-soft religion-name))) | |
| 454 | |
| 455 (defun mode-motion+-mode-handler-religion (buffer) | |
| 456 (let* ((mode-handler (or (get major-mode 'mode-motion-handler) | |
| 457 default-motion-handler)) | |
| 458 (current-handler (symbol-name (motion-handler-name mode-handler))) | |
| 459 (religion (substring current-handler | |
| 460 0 | |
| 461 (string-match "-" current-handler)))) | |
| 462 (intern-soft religion))) | |
| 463 | |
| 464 (defun modify-buffer-motion-handler (buffer religion) | |
| 465 (let* ((current-handler (symbol-name (motion-handler-name | |
| 466 (get-current-motion-handler)))) | |
| 467 (suffix (substring current-handler | |
| 468 (string-match "-" current-handler)))) | |
| 469 (set-buffer-motion-handler buffer | |
| 470 (intern-soft (concat (symbol-name religion) | |
| 471 suffix))))) | |
| 472 | |
| 473 (defun modify-mode-motion-handler (mode religion) | |
| 474 (let* ((mode-handler (or (get major-mode 'mode-motion-handler) | |
| 475 default-motion-handler)) | |
| 476 (current-handler (symbol-name (motion-handler-name mode-handler))) | |
| 477 (suffix (substring current-handler | |
| 478 (string-match "-" current-handler)))) | |
| 479 (set-mode-motion-handler mode (intern-soft (concat (symbol-name | |
| 480 religion) | |
| 481 suffix))))) | |
| 482 | |
| 483 ;;;; This does not work. I would like to be able to modify in-place | |
| 484 ;;;; the non-selectable items, but I don't know how. | |
| 485 ;;;; --paquette, Wed Mar 8 23:32:32 1995 (Marc Paquette) | |
| 486 ;;; Sensitize the mode motion+ options submenu, a la | |
| 487 ;;; sensitize-file-and-edit-menus-hook. | |
| 488 (defun mode-motion+-sensitize-options-menu-hook () | |
| 489 "Hook function that will adjust title items in the mode-motion+ submenu in Options" | |
| 490 (let* ((mm+-menu (cdr (car (find-menu-item | |
| 491 current-menubar | |
| 492 '("Options" "Motion Highlighting"))))) | |
| 493 (buffer-item (find-menu-item mm+-menu '("For Current Buffer"))) | |
| 494 (mode-item (find-menu-item mm+-menu '("For Current Mode")))) | |
| 495 (setcar buffer-item (format "For Buffer `%s'" (buffer-name nil))) | |
| 496 (setcar mode-item (format "For Mode `%s'" major-mode)) | |
| 497 nil)) | |
| 498 | |
| 499 ;;(add-hook 'activate-menubar-hook 'mode-motion+-sensitize-options-menu-hook) | |
| 500 | |
| 501 | |
| 502 ;; Motion Handler Format: | |
| 503 ;; | |
| 504 ;; A motion handler is vector with the following format | |
| 505 ;; [<name> - a symbol | |
| 506 ;; <region computing function> - a function or name of function | |
| 507 ;; that returns (<startpos> . <endpos>) | |
| 508 ;; or nil. | |
| 509 ;; <face or face name> - as it says ... | |
| 510 ;; <highlight-p> - non-nil means that the motion extent | |
| 511 ;; will be highlighted using the function | |
| 512 ;; `highlight-extent' | |
| 513 ;; <follow-point-p> - non-nil means that point will follow the | |
| 514 ;; mouse motion. | |
| 515 ;; ] | |
| 516 | |
| 517 ;; accessor functions | |
| 518 (defsubst motion-handler-name (handler) (aref handler 0)) | |
| 519 (defsubst motion-handler-boundary-function (handler) (aref handler 1)) | |
| 520 (defsubst motion-handler-face (handler) (aref handler 2)) | |
| 521 (defsubst motion-handler-highlight (handler) (aref handler 3)) | |
| 522 (defsubst motion-handler-follow-point (handler) (aref handler 4)) | |
| 523 | |
| 524 ;; modifier functions | |
| 525 (defsubst set-motion-handler-boundary-function (handler x) (aset handler 1 x)) | |
| 526 (defsubst set-motion-handler-face (handler x) (aset handler 2 x)) | |
| 527 (defsubst set-motion-handler-highlight (handler x) (aset handler 3 x)) | |
| 528 (defsubst set-motion-handler-follow-point (handler x) (aset handler 4 x)) | |
| 529 | |
| 530 ;; Internal global variables | |
| 531 (defvar motion-handler-alist () | |
| 532 "Alist with entries of the form \(<name> . <handler>\).") | |
| 533 | |
| 534 ;; Minibuffer motion handler | |
| 535 (defvar mode-motion-use-minibuffer-motion-handler t | |
| 536 "*Enable mousable highlighting when the minibuffer is active. When false only extents with the | |
| 537 highlight property are selectable (*Completion*)") | |
| 538 | |
| 539 (defvar mode-motion-extent nil) | |
| 540 (make-variable-buffer-local 'mode-motion-extent) | |
| 541 (defvar buffer-motion-handler nil) | |
| 542 (make-variable-buffer-local 'buffer-motion-handler) | |
| 543 (defvar mode-motion-last-extent nil "The last used mode motion extent.") | |
| 544 (defvar default-motion-handler nil) ; Initialised in mode-motion-init. | |
| 545 | |
| 546 ;; Creation of motion handlers | |
| 547 | |
| 548 (defun find-motion-handler (name) | |
| 549 (or (symbolp name) | |
| 550 (setq name (intern-soft name))) | |
| 551 (cdr (assq name motion-handler-alist))) | |
| 552 | |
| 553 ;; internal motion handler creator | |
| 554 (defsubst make-motion-handler-internal | |
| 555 (name boundary-function face highlight follow-cursor) | |
| 556 (vector name boundary-function (get-face face) highlight follow-cursor)) | |
| 557 | |
| 558 (defun make-motion-handler | |
| 559 (name boundary-function &optional face highlight follow-cursor) | |
| 560 "Create a motion handler named NAME (a symbol or string) using REGION-FUNCTION. | |
| 561 | |
| 562 REGION-FUNCTION is the function that computes the region to be highlighted. | |
| 563 Optional arguments are: | |
| 564 | |
| 565 FACE: A face or face name to be used to highlight the region computed | |
| 566 by REGION-FUNCTION. 'default is the default. | |
| 567 | |
| 568 HIGHLIGHT: Flag that indicates whether the highlight attribute of the | |
| 569 mode-motion-extent should be set or not. If FACE is the default face, | |
| 570 HIGHLIGHT defaults to t, otherwise to nil. | |
| 571 | |
| 572 FOLLOW-CURSOR: Flag that indicates whether the cursor should follow | |
| 573 the mouse motion. Default is nil." | |
| 574 | |
| 575 ;; required arguments | |
| 576 (or name (error "motion handler name required.")) | |
| 577 (or (symbolp name) | |
| 578 (stringp name) | |
| 579 (error "motion handler name must be a string or symbol: %s" name)) | |
| 580 (or boundary-function | |
| 581 (error "motion handler region function required.")) | |
| 582 (or (fboundp boundary-function) | |
| 583 (error "not a function: %s." boundary-function)) | |
| 584 ;; defaults | |
| 585 (or face (setq face 'default)) | |
| 586 | |
| 587 ;; store the mode motion handler on the 'mode-motion-handler property of | |
| 588 ;; its name symbol | |
| 589 (let ((old-handler (cdr (assq name motion-handler-alist))) | |
| 590 new-handler) | |
| 591 (if old-handler | |
| 592 (progn | |
| 593 (set-motion-handler-boundary-function old-handler boundary-function) | |
| 594 (set-motion-handler-face old-handler (get-face face)) | |
| 595 (set-motion-handler-highlight old-handler highlight) | |
| 596 (set-motion-handler-follow-point old-handler follow-cursor)) | |
| 597 (setq motion-handler-alist | |
| 598 (cons (cons name | |
| 599 (setq new-handler (make-motion-handler-internal | |
| 600 name | |
| 601 boundary-function | |
| 602 (get-face face) | |
| 603 highlight | |
| 604 follow-cursor))) | |
| 605 motion-handler-alist))) | |
| 606 (or old-handler new-handler))) | |
| 607 | |
| 608 (defvar list-motion-handlers-buffer-to-customize nil | |
| 609 "Name of buffer from where list-motion-handlers was called.") | |
| 610 (make-variable-buffer-local 'list-motion-handlers-buffer-to-customize) | |
| 611 (defvar list-motion-handlers-buffer-mode nil | |
| 612 "Name of mode of buffer from where list-motion-handlers was called.") | |
| 613 (make-variable-buffer-local 'list-motion-handlers-buffer-mode) | |
| 614 ;; Listing available motion handlers in tabular form. | |
| 615 | |
| 616 (defvar basic-motion-handlers (list 'mode-motion-highlight-line | |
| 617 'mode-motion-highlight-word | |
| 618 'mode-motion-highlight-symbol | |
| 619 'mode-motion-highlight-sexp) | |
| 620 "The basic motion handlers provided by the underlying XEmacs.") | |
| 621 | |
| 622 (defun list-motion-handlers () | |
| 623 "Display a list of available motion handlers. | |
| 624 The listing is in tabular form and contains the following columns: | |
| 625 NAME: the motion handlers name, | |
| 626 BOUNDARY FUNCTION: the name of the funtion used to compute the text | |
| 627 highlighted by the motion handler, | |
| 628 FACE: the face used to highlight the text. | |
| 629 | |
| 630 Additionally, the following flags are used at the beginning of each line: | |
| 631 `*' Marks the motion handler current to the buffer this functions was called | |
| 632 from. | |
| 633 `H' Force highlighting of the selected text. | |
| 634 `F' Make point follow the mouse cursor as it moves." | |
| 635 (interactive) | |
| 636 (let ((current-handler (get-current-motion-handler)) | |
| 637 (buffer (current-buffer)) | |
| 638 (buffer-mode major-mode) | |
| 639 (bmmh (if (symbolp mode-motion-hook) | |
| 640 (car (memq mode-motion-hook basic-motion-handlers)) | |
| 641 (if (and (listp mode-motion-hook) | |
| 642 (equal 1 (length mode-motion-hook))) | |
| 643 (car (memq (car mode-motion-hook) | |
| 644 basic-motion-handlers)))))) | |
| 645 (save-excursion | |
| 646 (with-output-to-temp-buffer "*Mouse Motion Handlers*" | |
| 647 (let ((truncate-lines t)) | |
| 648 (set-buffer "*Mouse Motion Handlers*") | |
| 649 (setq list-motion-handlers-buffer-to-customize buffer) | |
| 650 (setq list-motion-handlers-buffer-mode buffer-mode) | |
| 651 (let ((pos1 5) | |
| 652 (pos2 25) | |
| 653 (pos3 50) | |
| 654 (handlers | |
| 655 (sort | |
| 656 (mapcar 'cdr motion-handler-alist) | |
| 657 '(lambda (x y) | |
| 658 (string< | |
| 659 (symbol-name (motion-handler-boundary-function x)) | |
| 660 (symbol-name (motion-handler-boundary-function y))))))) | |
| 661 (if bmmh | |
| 662 (let ((i 1) | |
| 663 (fw (frame-width))) | |
| 664 (while (< i fw) | |
| 665 (princ "*") | |
| 666 (setq i (1+ i))) | |
| 667 (princ "\nNote: this buffer is not using mode-motion+.\n\n") | |
| 668 (princ "It's using the `") | |
| 669 (princ bmmh) | |
| 670 (princ "' motion handler which claims it's:\n") | |
| 671 (insert (documentation bmmh)) | |
| 672 (princ "\nSetting this motion handler will be irrevocable from this interface\n(but only for duration of this XEmacs session).\n") | |
| 673 (setq i 1) | |
| 674 (while (< i fw) | |
| 675 (princ "*") | |
| 676 (setq i (1+ i))) | |
| 677 (terpri))) | |
| 678 (princ " NAME BOUNDARY FUNCTION FACE\n") | |
| 679 (princ " ---- ----------------- ----\n") | |
| 680 (mapcar | |
| 681 #'(lambda (handler) | |
| 682 (let ((line-start (point))) | |
| 683 (princ (if (and (not bmmh) (eq handler current-handler)) | |
| 684 "*" " ")) | |
| 685 (princ (if (eq handler default-motion-handler) "D" " ")) | |
| 686 (princ (if (motion-handler-highlight handler) "H" " ")) | |
| 687 (princ (if (motion-handler-follow-point handler) "F" " ")) | |
| 688 (indent-to-column pos1 1) | |
| 689 (princ (motion-handler-name handler)) | |
| 690 (indent-to-column pos2 1) | |
| 691 (princ (motion-handler-boundary-function handler)) | |
| 692 (indent-to-column pos3) | |
| 693 (let ((face-start (point))) | |
| 694 (princ (face-name (motion-handler-face handler))) | |
| 695 (let ((line-extent (make-extent line-start face-start)) | |
| 696 (face-extent (make-extent face-start (point)))) | |
| 697 (set-extent-face face-extent | |
| 698 (motion-handler-face handler)) | |
| 699 (set-extent-property | |
| 700 face-extent | |
| 701 'mode-motion-handler (motion-handler-name handler)) | |
| 702 (set-extent-property | |
| 703 line-extent | |
| 704 'mode-motion-handler (motion-handler-name handler)) | |
| 705 (set-extent-property line-extent 'highlight t))) | |
| 706 (terpri))) | |
| 707 handlers) | |
| 708 (princ (format " | |
| 709 Flags: `D' the default motion handler | |
| 710 `H' handler with highlighting | |
| 711 `F' handler with `following' property | |
| 712 `*' the motion handler of buffer \"%s\"" | |
| 713 list-motion-handlers-buffer-to-customize)))) | |
| 714 (local-set-key 'button3 'mode-motion-set-handler) | |
| 715 (setq buffer-read-only t))))) | |
| 716 | |
| 717 (defun mode-motion-set-handler (event) | |
| 718 (interactive "@e") | |
| 719 (let* ((handler (or (extent-property | |
| 720 (extent-at (event-point event) (current-buffer) | |
| 721 'mode-motion-handler) | |
| 722 'mode-motion-handler) | |
| 723 (error "Click on highlighted line to select a handler"))) | |
| 724 (menu (list | |
| 725 (format "Make `%s' the Motion Handler of :" handler) | |
| 726 (vector (format "Buffer %s" | |
| 727 list-motion-handlers-buffer-to-customize) | |
| 728 (` (set-buffer-motion-handler | |
| 729 '(, list-motion-handlers-buffer-to-customize) | |
| 730 '(, handler))) t) | |
| 731 (vector "Another Buffer..." | |
| 732 (` (motion-handler-list-set-buffer-handler | |
| 733 '(, handler))) t) | |
| 734 "---" | |
| 735 (vector (format "Mode %s" | |
| 736 list-motion-handlers-buffer-mode) | |
| 737 (` (progn | |
| 738 (set-mode-motion-handler | |
| 739 '(, list-motion-handlers-buffer-mode) | |
| 740 '(, handler)) | |
| 741 (save-excursion | |
| 742 (mapcar | |
| 743 (function | |
| 744 (lambda (buf) | |
| 745 (set-buffer buf) | |
| 746 (and (eq | |
| 747 '(, list-motion-handlers-buffer-mode) | |
| 748 major-mode) | |
| 749 (mode-motion+-hook-install buf t)))) | |
| 750 (buffer-list))))) t) | |
| 751 (vector "Another Mode..." | |
| 752 (` (motion-handler-list-set-mode-handler | |
| 753 '(, handler))) t) | |
| 754 "---" | |
| 755 (vector "Default Motion Handler" | |
| 756 (` (set-default-motion-handler '(, handler))) t)))) | |
| 757 (popup-menu menu))) | |
| 758 | |
| 759 (defun motion-handler-list-set-buffer-handler (handler) | |
| 760 (let ((buffer (read-buffer-name | |
| 761 (format "Make `%s' the motion handler of buffer: " handler) | |
| 762 (buffer-name list-motion-handlers-buffer-to-customize)))) | |
| 763 (set-buffer-motion-handler buffer handler) | |
| 764 (save-excursion | |
| 765 (set-buffer buffer) | |
| 766 (and (not (cond ((listp mode-motion-hook) | |
| 767 (memq 'mode-motion+-highlight mode-motion-hook)) | |
| 768 ((symbolp mode-motion-hook) | |
| 769 (eq 'mode-motion+-highlight mode-motion-hook)) | |
| 770 (t t))) | |
| 771 (y-or-n-p (format "Augment the default mode motion hook for `%s'? " | |
| 772 (buffer-name nil))) | |
| 773 (mode-motion+-hook-install buffer t))))) | |
| 774 | |
| 775 (defvar mode-motion+-previous-hook nil | |
| 776 "Value of previous `mode-motion-hook' in current buffer.") | |
| 777 (make-variable-buffer-local 'mode-motion+-previous-hook) | |
| 778 | |
| 779 (defun motion-handler-list-set-mode-handler (handler) | |
| 780 (let ((mode (intern (completing-read | |
| 781 (format "Make `%s' the motion handler of mode: " handler) | |
| 782 obarray | |
| 783 'fboundp | |
| 784 t | |
| 785 (symbol-name list-motion-handlers-buffer-mode))))) | |
| 786 (set-mode-motion-handler mode handler) | |
| 787 (save-excursion | |
| 788 (mapcar (function | |
| 789 (lambda (buf) | |
| 790 (set-buffer buf) | |
| 791 (and (eq mode major-mode) | |
| 792 (mode-motion+-hook-install buf t)))) | |
| 793 (buffer-list))))) | |
| 794 | |
| 795 (defun mode-motion+-hook-install (&optional buffer remove-highlight-line-p) | |
| 796 "Add `mode-motion+-highlight' to the BUFFER `mode-motion-hook'. | |
| 797 If the optional second arg REMOVE-HIGHLIGHT-LINE-P is t, remove | |
| 798 `mode-motion-highlight-line' from `mode-motion-hook'. | |
| 799 See `mode-motion+-hook-uninstall' for reverting this operation." | |
| 800 (interactive "bInstall mode-motion+ hook for buffer : | |
| 801 XRemove highlight-line from hook ? :") | |
| 802 ;; Check for the mode-motion-hook value to make sure it's under | |
| 803 ;; the control of mode-motion+. | |
| 804 ;; The reasonning here is that if the user went trough the hassles | |
| 805 ;; of list-motion-handlers (or if he's calling this directly from | |
| 806 ;; his .emacs) , he is prepared to give up on the current | |
| 807 ;; mode-motion-hook. | |
| 808 ;; However, we keep the previous hook value in a buffer-local | |
| 809 ;; variable: it will be then possible to revert to the old motion | |
| 810 ;; handling behavior with `mode-motion+-hook-uninstall'. | |
| 811 ;; --paquette, Mon Feb 27 08:54:30 1995 (Marc Paquette) | |
| 812 (setq buffer (or buffer (current-buffer))) | |
| 813 ;; force the uninstall of mode-motion-highlight since if its second | |
| 814 ;; you'll never see ours. | |
| 815 (setq remove-highlight-line-p t) | |
| 816 (save-excursion | |
| 817 (set-buffer buffer) | |
| 818 (if (boundp 'mode-motion-hook) | |
| 819 (progn | |
| 820 (setq mode-motion+-previous-hook | |
| 821 (cond ((sequencep mode-motion-hook) | |
| 822 (copy-sequence mode-motion-hook)) | |
| 823 (t mode-motion-hook))) | |
| 824 ;; Make sure that the mode-motion+-highlight is not saved in | |
| 825 ;; the variable, otherwise, we could not revert back to the | |
| 826 ;; "factory settings" after having played with different | |
| 827 ;; handlers | |
| 828 ;; --paquette, Mon Feb 27 08:54:21 1995 (Marc Paquette) | |
| 829 (remove-hook 'mode-motion+-previous-hook 'mode-motion+-highlight))) | |
| 830 (add-hook 'mode-motion-hook 'mode-motion+-highlight) | |
| 831 (and remove-highlight-line-p | |
| 832 ;; Remove the standard mode-motion-highlight hook because we | |
| 833 ;; provide an alternative to this. I don't use setq here because | |
| 834 ;; something else could be hooked to mode-motion-hook. | |
| 835 ;; --paquette, Mon Feb 27 08:53:51 1995 (Marc Paquette) | |
| 836 (remove-hook 'mode-motion-hook 'mode-motion-highlight-line)) | |
| 837 (and mode-motion-extent | |
| 838 (delete-extent mode-motion-extent) | |
| 839 (setq mode-motion-extent nil)) | |
| 840 ;; Try to make this installed for any buffer of this mode | |
| 841 (let ((this-mode-hook (intern-soft (concat (symbol-name major-mode) | |
| 842 "-hook")))) | |
| 843 (and (boundp this-mode-hook) | |
| 844 (if remove-highlight-line-p | |
| 845 (add-hook this-mode-hook | |
| 846 #'(lambda () (mode-motion+-hook-install nil t)) | |
| 847 'append) | |
| 848 (add-hook this-mode-hook 'mode-motion+-hook-install 'append))))) | |
| 849 mode-motion-hook) | |
| 850 | |
| 851 (defun mode-motion+-hook-uninstall (buffer) | |
| 852 "Restore the value of `mode-motion-hook' in BUFFER to what it was at the time `mode-motion+-hook-install' was called. | |
| 853 See also `mode-motion+-hook-install'." | |
| 854 (interactive "bRestore `mode-motion-hook' of buffer :") | |
| 855 ;; Check for the mode-motion-hook value to make sure it's under | |
| 856 ;; the control of mode-motion+. | |
| 857 ;; The reasonning here is that if the user went trough the hassles | |
| 858 ;; of list-motion-handlers (or if he's calling this directly from | |
| 859 ;; his .emacs) , he is prepared to give up on the current | |
| 860 ;; mode-motion-hook. | |
| 861 ;; However, we keep the previous hook value in a buffer-local | |
| 862 ;; variable: it will be then possible to revert to the old motion | |
| 863 ;; handling behavior with `mode-motion+-hook-uninstall'. | |
| 864 ;; --paquette, Mon Feb 27 08:54:30 1995 (Marc Paquette) | |
| 865 (save-excursion | |
| 866 (set-buffer buffer) | |
| 867 (and mode-motion-extent | |
| 868 (delete-extent mode-motion-extent) | |
| 869 (setq mode-motion-extent nil)) | |
| 870 (if (boundp 'mode-motion+-previous-hook) | |
| 871 (progn | |
| 872 (setq mode-motion-hook mode-motion+-previous-hook) | |
| 873 (setq mode-motion+-previous-hook nil) | |
| 874 (let ((this-mode-hook (intern-soft (concat (symbol-name major-mode) | |
| 875 "-hook")))) | |
| 876 (and (boundp this-mode-hook) | |
| 877 (remove-hook this-mode-hook 'mode-motion+-hook-install)))) | |
| 878 (error "No previous value for mode-motion-hook"))) | |
| 879 mode-motion-hook) | |
| 880 | |
| 881 (defun mode-motion+-motion-hook-revert (&optional buffer-only-p buffer mode) | |
| 882 "Revert the `mode-motion-hook' to its original value. | |
| 883 With optional arg BUFFER-ONLY-P non-nil, only revert in BUFFER | |
| 884 \(defaults to `\(current-buffer\)'\); otherwise, revert for all existing | |
| 885 buffers of MODE \(defaults to `major-mode' of BUFFER\)." | |
| 886 (interactive | |
| 887 (let* ((buffer-only-p | |
| 888 (y-or-n-p "Revert mode-motion-hook only for current buffer ? ")) | |
| 889 (buffer (if buffer-only-p | |
| 890 (current-buffer) | |
| 891 (get-buffer (read-buffer-name | |
| 892 "Revert mode-motion-hook of buffer : " | |
| 893 (buffer-name (current-buffer)))))) | |
| 894 (mode (if buffer-only-p | |
| 895 (save-excursion | |
| 896 (set-buffer buffer) | |
| 897 major-mode) | |
| 898 (intern-soft (completing-read "Major mode: " | |
| 899 obarray | |
| 900 'fboundp | |
| 901 nil | |
| 902 (symbol-name major-mode)))))) | |
| 903 (list buffer-only-p buffer mode))) | |
| 904 (if buffer-only-p | |
| 905 (mode-motion+-hook-uninstall buffer) | |
| 906 (save-excursion | |
| 907 (mapcar (function | |
| 908 (lambda (buf) | |
| 909 (set-buffer buf) | |
| 910 (and (eq mode major-mode) | |
| 911 (mode-motion+-hook-uninstall buf)))) | |
| 912 (buffer-list))))) | |
| 913 | |
| 914 | |
| 915 ;; Setting buffer, mode and default motion handlers | |
| 916 | |
| 917 (defun set-buffer-motion-handler (buffer handler-name) | |
| 918 "Make the motion handler named HANDLER-NAME (a symbol) the buffer | |
| 919 motion handler of BUFFER. If HANDLER-NAME is nil, the corresponding | |
| 920 buffer motion handler is removed. If HANDLER-NAME isn't the name of a | |
| 921 known motion handler, an error is signaled. When called interactively, | |
| 922 completion is provided for available buffers and motion handlers. | |
| 923 | |
| 924 1.\) buffer motion handler | |
| 925 2.\) mode motion handler | |
| 926 3.\) default motion handler" | |
| 927 (interactive (list (read-buffer-name "Set motion handler of buffer: " | |
| 928 (buffer-name (current-buffer))) | |
| 929 (read-motion-handler-name))) | |
| 930 | |
| 931 ;; kill old mode motion extent, because the new handler | |
| 932 ;; might want to initialize it differently | |
| 933 (if mode-motion-extent | |
| 934 (progn | |
| 935 (detach-extent mode-motion-extent) | |
| 936 (setq mode-motion-extent nil))) | |
| 937 (or buffer (setq buffer (current-buffer))) | |
| 938 (or (get-buffer buffer) | |
| 939 (error "No such buffer: %s" buffer)) | |
| 940 (save-excursion | |
| 941 (set-buffer buffer) | |
| 942 (setq buffer-motion-handler | |
| 943 ;; remove it if `nil' | |
| 944 (and handler-name | |
| 945 ;; set the handler if known | |
| 946 (or (find-motion-handler handler-name) | |
| 947 ;; error otherwise | |
| 948 (error "Not a known motion handler: %s" | |
| 949 handler-name))))) | |
| 950 (if (interactive-p) | |
| 951 (if handler-name | |
| 952 (message "Motion handler for buffer %s is `%s'." | |
| 953 (current-buffer) handler-name) | |
| 954 (message "Motion handler removed for buffer %s." | |
| 955 (current-buffer)))) | |
| 956 handler-name) | |
| 957 | |
| 958 (defun read-buffer-name (prompt &optional initial-input) | |
| 959 (completing-read prompt | |
| 960 (mapcar #'(lambda (buf) (list (buffer-name buf))) | |
| 961 (buffer-list)) | |
| 962 ;; don't take buffers that start with a blank | |
| 963 #'(lambda (list) (not (eq (aref (car list) 0) ? ))) | |
| 964 t | |
| 965 initial-input)) | |
| 966 | |
| 967 (defun set-mode-motion-handler (mode handler-name) | |
| 968 "Make the motion handler named HANDLER-NAME (a symbol) the mode motion | |
| 969 handler for all buffers with major-mode MODE. If HANDLER-NAME is nil, | |
| 970 the corresponding mode motion handler is removed. If HANDLER-NAME | |
| 971 isn't the name of a known motion handler, an error is signaled. When | |
| 972 called interactively, completion is provided for available motion | |
| 973 handlers. | |
| 974 | |
| 975 1.\) buffer motion handler | |
| 976 2.\) mode motion handler | |
| 977 3.\) default motion handler" | |
| 978 (interactive (list (intern (completing-read "Major mode: " | |
| 979 obarray | |
| 980 'fboundp | |
| 981 nil | |
| 982 (symbol-name major-mode))) | |
| 983 (read-motion-handler-name))) | |
| 984 ;; kill old mode motion extent, because the new handler | |
| 985 ;; might want to initialize it differently | |
| 986 (if mode-motion-extent | |
| 987 (progn | |
| 988 (detach-extent mode-motion-extent) | |
| 989 (setq mode-motion-extent nil))) | |
| 990 (put mode 'mode-motion-handler | |
| 991 ;; remove it if `nil' | |
| 992 (and handler-name | |
| 993 ;; set the handler if known | |
| 994 (or (find-motion-handler handler-name) | |
| 995 ;; error otherwise | |
| 996 (error "Not a known mode motion handler: %s" handler-name)))) | |
| 997 (if (interactive-p) | |
| 998 (if handler-name | |
| 999 (message "Motion handler for %s is `%s'." mode handler-name) | |
| 1000 (message "Mode motion handler for %s removed." mode))) | |
| 1001 handler-name) | |
| 1002 | |
| 1003 (defun set-default-motion-handler (handler-name) | |
| 1004 "Make the motion handler named HANDLER-NAME (a symbol) the default. | |
| 1005 | |
| 1006 If HANDLER-NAME is nil, the current default motion handler is removed. If | |
| 1007 HANDLER-NAME isn't the name of a known motion handler, an error is | |
| 1008 signalled. When called interactively, completion is provided for available | |
| 1009 motion handlers. | |
| 1010 | |
| 1011 The motion handler used in a given buffer is determined by the following | |
| 1012 most-specific first list: buffer motion handler, mode motion handler, default | |
| 1013 motion handler." | |
| 1014 (interactive (list (read-motion-handler-name))) | |
| 1015 ;; kill old mode motion extent, because the new handler | |
| 1016 ;; might want to initialize it differently | |
| 1017 (if mode-motion-extent | |
| 1018 (progn | |
| 1019 (detach-extent mode-motion-extent) | |
| 1020 (setq mode-motion-extent nil))) | |
| 1021 (setq default-motion-handler | |
| 1022 ;; remove it if `nil' | |
| 1023 (and handler-name | |
| 1024 ;; set the handler if known | |
| 1025 (or (find-motion-handler handler-name) | |
| 1026 ;; error otherwise | |
| 1027 (error "Not a known motion handler: %s" handler-name)))) | |
| 1028 (if (interactive-p) | |
| 1029 (if handler-name | |
| 1030 (message "Default motion handler is `%s'." handler-name) | |
| 1031 (message "Default motion handler removed."))) | |
| 1032 handler-name) | |
| 1033 | |
| 1034 (defun read-motion-handler-name () | |
| 1035 (intern-soft (completing-read "Motion handler: " | |
| 1036 (mapcar #'(lambda (entry) | |
| 1037 (list (symbol-name (car entry)))) | |
| 1038 motion-handler-alist) | |
| 1039 nil t))) | |
| 1040 | |
| 1041 ;; clear the last active motion extent when leaving a frame. | |
| 1042 (defun mode-motion-clear-extent (&optional extent) | |
| 1043 "Clear EXTENT, i.e. make it have no visible effects on the frame. | |
| 1044 EXTENT defaults to the current buffer's mode-motion-extent." | |
| 1045 (or extent (setq extent mode-motion-extent)) | |
| 1046 (and extent | |
| 1047 (extent-live-p extent) | |
| 1048 (not (extent-detached-p extent)) | |
| 1049 (extent-buffer extent) | |
| 1050 (buffer-name (extent-buffer extent)) | |
| 1051 (progn | |
| 1052 ;; unhighlight it | |
| 1053 (highlight-extent extent nil) | |
| 1054 ;; make it span a region that isn't visible and selectable | |
| 1055 ;; Can this be done more elegantly? | |
| 1056 (detach-extent extent)))) | |
| 1057 | |
| 1058 (defun mode-motion-clear-last-extent (&optional frame) | |
| 1059 "Clear the mode-motion-last-extent." | |
| 1060 (or (popup-menu-up-p) (mode-motion-clear-extent mode-motion-last-extent))) | |
| 1061 | |
| 1062 (defun mode-motion+-highlight (event) | |
| 1063 "Highlight the thing under the mouse using a mode-specfic motion handler. | |
| 1064 See list-motion-handlers for more details." | |
| 1065 (mode-motion-clear-last-extent) | |
| 1066 (and (event-buffer event) | |
| 1067 (cond ((and mouse-grabbed-buffer | |
| 1068 ;; first try to do minibuffer specific highlighting | |
| 1069 (find-motion-handler 'minibuffer) | |
| 1070 (let ((mode-motion-highlight-lines-when-behind nil)) | |
| 1071 (and (event-point event) | |
| 1072 (or (extent-at (event-point event) | |
| 1073 (event-buffer event) 'highlight) | |
| 1074 (mode-motion-highlight-with-handler | |
| 1075 (find-motion-handler 'minibuffer) event)))))) | |
| 1076 (t (mode-motion-highlight-with-handler | |
| 1077 (get-current-motion-handler) event)))) | |
| 1078 ;; Return nil since now this is used as a hook, and we want to let | |
| 1079 ;; any other hook run after us. | |
| 1080 nil) | |
| 1081 | |
| 1082 (defun get-current-motion-handler () | |
| 1083 (or (and (boundp 'buffer-motion-handler) buffer-motion-handler) | |
| 1084 (get major-mode 'mode-motion-handler) | |
| 1085 default-motion-handler)) | |
| 1086 | |
| 1087 (defun mode-motion-highlight-with-handler (handler event) | |
| 1088 ;; Perform motion highlighting using HANDLER. Information about the | |
| 1089 ;; current mouse position is taken form EVENT. | |
| 1090 (and handler | |
| 1091 (let ((point (event-point event)) | |
| 1092 (buffer (event-buffer event)) | |
| 1093 (window (event-window event)) | |
| 1094 (window-config (current-window-configuration)) | |
| 1095 (buffer-save (current-buffer)) | |
| 1096 (point-save (point)) | |
| 1097 region) | |
| 1098 ;; save-window-excursion and restore buffer | |
| 1099 (unwind-protect | |
| 1100 (progn | |
| 1101 (and buffer | |
| 1102 (set-buffer buffer) | |
| 1103 (select-window window)) | |
| 1104 | |
| 1105 ;; kludge: if point = end-of-window, then probably the mouse | |
| 1106 ;; is actually between the last line and the modeline. In | |
| 1107 ;; this case move point to back one | |
| 1108 (and point | |
| 1109 (not (< point (window-end window))) | |
| 1110 (setq point (1- point))) | |
| 1111 ;; Create a new mode-motion-extent if there isn't one | |
| 1112 ;; (or a destroyed one) | |
| 1113 (if (and (extent-live-p mode-motion-extent) | |
| 1114 (extent-buffer mode-motion-extent)) | |
| 1115 () | |
| 1116 (setq mode-motion-extent (make-extent nil nil buffer)) | |
| 1117 (set-extent-priority mode-motion-extent 1)) | |
| 1118 (if (and | |
| 1119 ;; compute the region to be highlighted | |
| 1120 (setq region | |
| 1121 (if point | |
| 1122 ;; compute the mode-motion region using the | |
| 1123 ;; handlers boundary function | |
| 1124 (condition-case nil;; c | |
| 1125 (funcall | |
| 1126 (motion-handler-boundary-function handler) | |
| 1127 point) | |
| 1128 ;; Messages that appear during computing the | |
| 1129 ;; region may be displayed not done | |
| 1130 ;; here because it's rather disturbing | |
| 1131 (error | |
| 1132 ;; (setq message (format "%s" (car (cdr c)))) | |
| 1133 nil)) | |
| 1134 ;; otherwise highlight the whole line mouse is | |
| 1135 ;; behind but only if the line isn't empty | |
| 1136 (if mode-motion-highlight-lines-when-behind | |
| 1137 (unwind-protect | |
| 1138 (progn | |
| 1139 ;; (message "%s" (event-window event)) | |
| 1140 (move-to-window-line | |
| 1141 (if (< emacs-minor-version 12) | |
| 1142 (- (event-y event) | |
| 1143 (nth 1 (window-edges window))) | |
| 1144 (event-y event))) | |
| 1145 (beginning-of-line) | |
| 1146 (if (= (following-char) ?\n) | |
| 1147 ;; empty line | |
| 1148 () | |
| 1149 (thing-region | |
| 1150 (point) | |
| 1151 (progn | |
| 1152 (end-of-line) | |
| 1153 ;; for `follow-point' behavoir | |
| 1154 (setq point (point)) | |
| 1155 ;; fetch also the newline, if any | |
| 1156 ;; -- handy for copying >1 line | |
| 1157 (if (eobp) point (1+ point)))))) | |
| 1158 (goto-char point-save))))) | |
| 1159 ;; (message "region: %s" region) | |
| 1160 ;; the region might be in reverse order. Stop in this case | |
| 1161 (<= (car region) (cdr region))) | |
| 1162 (if (or (not (motion-handler-follow-point handler)) | |
| 1163 (pos-visible-in-window-p point)) | |
| 1164 (progn | |
| 1165 ;; set the extent face | |
| 1166 (set-extent-face | |
| 1167 mode-motion-extent (motion-handler-face handler)) | |
| 1168 ;; set the new boundary | |
| 1169 (set-extent-endpoints | |
| 1170 mode-motion-extent (car region) (cdr region)) | |
| 1171 ;; highlight if required | |
| 1172 (set-extent-property | |
| 1173 mode-motion-extent 'highlight | |
| 1174 (motion-handler-highlight handler)) | |
| 1175 (highlight-extent mode-motion-extent | |
| 1176 (motion-handler-highlight handler)) | |
| 1177 ;; make point follow the mouse or point to | |
| 1178 ;; the beginning of the line do not move the | |
| 1179 ;; cursor if a mark is set. | |
| 1180 (cond ((and (motion-handler-follow-point handler) | |
| 1181 (not (mark))) | |
| 1182 (goto-char point) | |
| 1183 ;; kludge to keep the cursor out the way | |
| 1184 (if (or (eq (motion-handler-boundary-function | |
| 1185 handler) | |
| 1186 'line-boundaries) | |
| 1187 (eq (motion-handler-boundary-function | |
| 1188 handler) | |
| 1189 'visible-line-boundaries)) | |
| 1190 (beginning-of-line)))) | |
| 1191 (if (and mode-motion-focus-on-window | |
| 1192 (or (eq mode-motion-focus-on-window t) | |
| 1193 (motion-handler-follow-point handler))) | |
| 1194 ;; Select the current window FROM OUTSIDE the | |
| 1195 ;; `save-window-excursion' that surrounds the call | |
| 1196 ;; to the current function. This also avoids | |
| 1197 ;; conflicts with running process filters. | |
| 1198 (enqueue-eval-event 'select-window | |
| 1199 (selected-window))) | |
| 1200 ;; snap in effect, but it ain't yet workin' | |
| 1201 ;; (message "X: %sl; Y: %s"(event-x event)(event-y event)) | |
| 1202 ;; (and motion-handler-snap-in | |
| 1203 ;; (set-mouse-position | |
| 1204 ;; (window-frame (event-window event)) | |
| 1205 ;; (event-x event) | |
| 1206 ;; (event-y event))) | |
| 1207 (setq mode-motion-last-extent mode-motion-extent) | |
| 1208 ;; signal success | |
| 1209 t)) | |
| 1210 ;; signal failiure | |
| 1211 nil)) | |
| 1212 (set-window-configuration window-config) | |
| 1213 (set-buffer buffer-save))))) | |
| 1214 | |
| 1215 ;; Motion Event debugging | |
| 1216 ;; | |
| 1217 ;; Useful to see what information is available from motion events | |
| 1218 | |
| 1219 (defun debug-motion-handler (event) | |
| 1220 (let* ((window (event-window event)) | |
| 1221 (frame (or (event-frame event) (selected-frame))) | |
| 1222 (buffer (and window (event-buffer event))) | |
| 1223 (point (and buffer (event-point event)))) | |
| 1224 (with-output-to-temp-buffer "*Debug Motion Handler Output*" | |
| 1225 (princ | |
| 1226 (format "\ | |
| 1227 Window: %s | |
| 1228 Frame: %s | |
| 1229 Buffer: %s | |
| 1230 (event-x, event-y): (%s, %s) | |
| 1231 (event-x-pixel, event-y-pixel): (%s, %s) | |
| 1232 Point: %s | |
| 1233 Timestamp: %s" | |
| 1234 window | |
| 1235 frame | |
| 1236 buffer | |
| 1237 (event-x event) (event-y event) | |
| 1238 (event-x-pixel event) (event-y-pixel event) | |
| 1239 point | |
| 1240 (event-timestamp event)))))) | |
| 1241 | |
| 1242 ;(let ((mouse-motion-handler 'debug-motion-handler) | |
| 1243 ; (temp-buffer-show-function nil)) | |
| 1244 ; (read-char)) | |
| 1245 | |
| 1246 ;; Set of copy/kill/move functions for usage with highlighted regions | |
| 1247 | |
| 1248 (put 'mode-motion-move 'pending-delete t) | |
| 1249 (put 'mode-motion-copy 'pending-delete t) | |
| 1250 | |
| 1251 (defun mode-motion-move () | |
| 1252 "Move the motion active region to point." | |
| 1253 (interactive) | |
| 1254 (mode-motion-insert-text (mode-motion-copy/delete t))) | |
| 1255 | |
| 1256 (defun mode-motion-kill () | |
| 1257 "Kill the motion active region and push it onto the kill ring." | |
| 1258 (interactive) | |
| 1259 (mode-motion-copy/delete t t t)) | |
| 1260 | |
| 1261 (defun mode-motion-copy () | |
| 1262 "Copy the motion active region to point." | |
| 1263 (interactive) | |
| 1264 (mode-motion-insert-text (mode-motion-copy/delete))) | |
| 1265 | |
| 1266 (defun mode-motion-copy-as-kill () | |
| 1267 "Delete the motion active region and push it onto the kill ring. | |
| 1268 Set point to the place where deletion happened." | |
| 1269 (interactive) | |
| 1270 (mode-motion-copy/delete nil t) | |
| 1271 (message "Text copied to the to ring and cut buffer.")) | |
| 1272 | |
| 1273 (defun mode-motion-copy/delete (&optional delete copy-as-kill set-point) | |
| 1274 "Return the string that is designated by the current motion active region. | |
| 1275 Arguments are: | |
| 1276 EVENT - a mouse click event used to identify the buffer and window | |
| 1277 &optional DELETE - delete the motion active text region | |
| 1278 COPY-AS-KILL - copy the string to the kill ring | |
| 1279 SET-POINT - set point to the start of the motion active region." | |
| 1280 (let ((old-buf (current-buffer)) | |
| 1281 (old-window (selected-window))) | |
| 1282 (unwind-protect | |
| 1283 (let ((extent (or primary-selection-extent | |
| 1284 (and (extentp mode-motion-last-extent) | |
| 1285 (not (extent-property mode-motion-last-extent | |
| 1286 'detached)) | |
| 1287 mode-motion-last-extent)))) | |
| 1288 | |
| 1289 (if (and (extentp extent) | |
| 1290 (set-buffer (extent-buffer extent)) | |
| 1291 (not | |
| 1292 ;; zero length extents | |
| 1293 (= (extent-start-position extent) | |
| 1294 (extent-end-position extent)))) | |
| 1295 | |
| 1296 (let* ((start (extent-start-position extent)) | |
| 1297 (end (extent-end-position extent)) | |
| 1298 (text | |
| 1299 (buffer-substring | |
| 1300 (extent-start-position extent) | |
| 1301 (extent-end-position extent)))) | |
| 1302 | |
| 1303 (cond (copy-as-kill | |
| 1304 (copy-region-as-kill start end) | |
| 1305 (if (or (not kill-hooks) | |
| 1306 (eq kill-hooks 'ignore)) | |
| 1307 (progn | |
| 1308 (x-own-selection-internal 'PRIMARY text) | |
| 1309 (x-own-clipboard text))))) | |
| 1310 | |
| 1311 (cond (delete | |
| 1312 (kill-region start end) | |
| 1313 (x-own-selection-internal 'PRIMARY text) | |
| 1314 ;; (select-window window) | |
| 1315 (if set-point | |
| 1316 (goto-char start)))) | |
| 1317 | |
| 1318 (setq this-command 'mode-motion+) | |
| 1319 text) | |
| 1320 (error "No current primary or motion selection.") | |
| 1321 )) | |
| 1322 (set-buffer old-buf) | |
| 1323 (select-window old-window)))) | |
| 1324 | |
| 1325 (defun mode-motion-insert-text (text) | |
| 1326 "Insert TEXT at point. Also insert one space if the | |
| 1327 preceeding character is a word constituent or a closing paren." | |
| 1328 (or text (error "No highlighted text to copy.")) | |
| 1329 (let ((prec-char-syntax (char-syntax (preceding-char)))) | |
| 1330 (if (memq prec-char-syntax '(?w ?\))) (insert " ")) | |
| 1331 (insert text))) | |
| 1332 | |
| 1333 ;; Boundary functions | |
| 1334 ;; | |
| 1335 ;; The following functions are already provided by the thing package: | |
| 1336 ;; thing-boundaries | |
| 1337 ;; thing-symbol | |
| 1338 ;; thing-word | |
| 1339 | |
| 1340 (defun char-boundaries (point) (thing-region point (1+ point))) | |
| 1341 | |
| 1342 (defun visible-line-boundaries (point) | |
| 1343 (save-excursion | |
| 1344 (goto-char point) | |
| 1345 (beginning-of-line) | |
| 1346 (skip-chars-forward " \t") | |
| 1347 (if (and (eq major-mode 'dired-mode) | |
| 1348 (save-excursion (dired-move-to-filename))) | |
| 1349 (let ((start (point))) | |
| 1350 (end-of-line) | |
| 1351 (skip-chars-backward " \t") | |
| 1352 (thing-region start (point)))))) | |
| 1353 | |
| 1354 (defun line-boundaries (point) | |
| 1355 (save-excursion | |
| 1356 (goto-char point) | |
| 1357 (beginning-of-line) | |
| 1358 (if (and (eq major-mode 'dired-mode) | |
| 1359 (save-excursion (dired-move-to-filename))) | |
| 1360 (let ((start (point))) | |
| 1361 (end-of-line) | |
| 1362 (thing-region start (point)))))) | |
| 1363 | |
| 1364 (defun cvs-line-boundaries (point) | |
| 1365 (save-excursion | |
| 1366 (goto-char point) | |
| 1367 (beginning-of-line) | |
| 1368 (if (looking-at "^[* ] ") | |
| 1369 (thing-region (point) (progn (end-of-line) (point)))))) | |
| 1370 | |
| 1371 (defun latex-boundaries (here) | |
| 1372 (setq *last-thing* 'sexp) | |
| 1373 (tex-boundaries | |
| 1374 here ?\\ "a-zA-Z" | |
| 1375 ;; begin-fwd-regexp | |
| 1376 "\\\\begin *{ *\\([a-z]*\\) *}" | |
| 1377 ;; end-fwd-regexp | |
| 1378 "\\(\\\\end *{ *%s *}\\)\\|\\(\\\\begin *{ *%s *}\\)" | |
| 1379 ;; begin-bwd-regexp | |
| 1380 "\\\\end *{ *\\([a-z]*\\) *}" | |
| 1381 ;; begin-bwd-regexp | |
| 1382 "\\(\\\\end *{ *%s *}\\)\\|\\(\\\\begin *{ *%s *}\\)" | |
| 1383 ;; param-cmd-regexp | |
| 1384 "\\\\[a-zA-Z]+[ \n\t]*{")) | |
| 1385 | |
| 1386 (defvar texinfo-paired-commands | |
| 1387 (mapconcat | |
| 1388 'identity | |
| 1389 '( | |
| 1390 "enumerate" | |
| 1391 "example" | |
| 1392 "group" | |
| 1393 "ifinfo" | |
| 1394 "iftex" | |
| 1395 "ignore" | |
| 1396 "itemize" | |
| 1397 "menu" | |
| 1398 "quotation" | |
| 1399 "table" | |
| 1400 "tex" | |
| 1401 "titlepage" | |
| 1402 ) | |
| 1403 "\\|")) | |
| 1404 | |
| 1405 (defvar texinfo-begin-fwd-regexp | |
| 1406 (format "@\\(%s\\)" texinfo-paired-commands)) | |
| 1407 (defvar texinfo-end-bwd-regexp | |
| 1408 (format "@end *\\(%s\\)" texinfo-paired-commands)) | |
| 1409 | |
| 1410 (defun texinfo-boundaries (here) | |
| 1411 (tex-boundaries | |
| 1412 here ?@ "a-z" | |
| 1413 texinfo-begin-fwd-regexp | |
| 1414 ;; end-fwd-regexp | |
| 1415 "\\(@end *%s\\)\\|\\(@%s\\)" | |
| 1416 ;; end-bwd-regexp | |
| 1417 texinfo-end-bwd-regexp | |
| 1418 ;; begin-bwd-regexp | |
| 1419 "\\(@end *%s\\)\\|\\(@%s\\)" | |
| 1420 ;; param-cmd-regexp | |
| 1421 "@\\(TeX\\|[a-zA]+\\)[ \n\t]*{")) | |
| 1422 | |
| 1423 (defun tex-boundaries | |
| 1424 (here cmd-start-character cmd-word-character | |
| 1425 begin-fwd-regexp end-fwd-regexp | |
| 1426 end-bwd-regexp begin-bwd-regexp | |
| 1427 param-cmd-regexp) | |
| 1428 "Generic TeX dialect scanner. | |
| 1429 Parameters: | |
| 1430 cmd-start-character: character that starts a command | |
| 1431 (`\' in (La)TeX, `@' in Texinfo) | |
| 1432 cmd-word-character: regexpression to be used by the function | |
| 1433 `skip-chars-backward' allowing to skip over command | |
| 1434 characters other than `cmd-start-character' | |
| 1435 begin-fwd-regexp: regexpression matching the begin part of a | |
| 1436 text stretch, used in forward search. | |
| 1437 end-fwd-regexp: regexpression matching the end part of a | |
| 1438 text stretch, used in forward search | |
| 1439 end-bwd-regexp: regexpression matching the end part of a | |
| 1440 text stretch, used in backward search. | |
| 1441 begin-bwd-regexp: regexpression matching the begin part of a | |
| 1442 text stretch, used in backward search. | |
| 1443 param-cmd-regexp: regexpression matching a parameterized command | |
| 1444 \(including the open parenthesis\)" | |
| 1445 (save-excursion | |
| 1446 (goto-char here) | |
| 1447 (cond ((= (following-char) cmd-start-character) | |
| 1448 (forward-char 1)) | |
| 1449 ((= (char-syntax (following-char)) ?w) | |
| 1450 (skip-chars-backward cmd-word-character))) | |
| 1451 (if (/= (preceding-char) cmd-start-character) | |
| 1452 (thing-boundaries here) | |
| 1453 (forward-char -1) | |
| 1454 (catch 'return | |
| 1455 (cond ((looking-at begin-fwd-regexp) | |
| 1456 (let* ((start (point)) | |
| 1457 (env (buffer-substring | |
| 1458 (match-beginning 1) (match-end 1))) | |
| 1459 (regexp (format end-fwd-regexp env env)) | |
| 1460 (count 0)) | |
| 1461 (while (re-search-forward regexp nil t) | |
| 1462 (cond ((match-beginning 2) ; \begin | |
| 1463 (setq count (1+ count))) | |
| 1464 ((match-beginning 1) ; \end | |
| 1465 (setq count (1- count)) | |
| 1466 (if (= count 0) | |
| 1467 (throw 'return | |
| 1468 (thing-region start (point))))))))) | |
| 1469 ((looking-at end-bwd-regexp) | |
| 1470 (let* ((end (match-end 0)) | |
| 1471 (env (buffer-substring | |
| 1472 (match-beginning 1) (match-end 1))) | |
| 1473 (regexp | |
| 1474 (format begin-bwd-regexp env env)) | |
| 1475 (count 1)) | |
| 1476 (while (re-search-backward regexp nil t) | |
| 1477 (cond ((match-beginning 1) ; \end | |
| 1478 (setq count (1+ count))) | |
| 1479 ((match-beginning 2) ; \begin | |
| 1480 (setq count (1- count)) | |
| 1481 (if (= count 0) | |
| 1482 (throw 'return (thing-region (point) end)))) | |
| 1483 )))) | |
| 1484 ;; tex macros of the form \cmd {...} | |
| 1485 ((looking-at param-cmd-regexp) | |
| 1486 (thing-region | |
| 1487 (point) | |
| 1488 (progn | |
| 1489 (goto-char (1- (match-end 0))) | |
| 1490 (forward-sexp 1) | |
| 1491 (point)))) | |
| 1492 ;; fetch the current macro (with backslash) | |
| 1493 (t (thing-region (point) (progn (forward-word 1) (point))))))))) | |
| 1494 | |
| 1495 ;; special parse of buffer for valid selectable info | |
| 1496 (defun minibuffer-selection-boundaries (point) | |
| 1497 (let ((old-syntax (syntax-table))) | |
| 1498 (unwind-protect | |
| 1499 (progn | |
| 1500 ;; best syntax table for recognizing symbols | |
| 1501 (set-syntax-table emacs-lisp-mode-syntax-table) | |
| 1502 (let ((file-completion (eq minibuffer-completion-table | |
| 1503 'read-file-name-internal)) | |
| 1504 region | |
| 1505 minibuf-string ;contents of minibuffer | |
| 1506 buffer-string ;string to be highlighted (or not) | |
| 1507 prefix ;prefix calculated from minibuf-string | |
| 1508 string ;string to be verified in the | |
| 1509 ;completion table | |
| 1510 ) | |
| 1511 (and | |
| 1512 | |
| 1513 (setq region (if file-completion | |
| 1514 (thing-filename point) | |
| 1515 (thing-symbol point))) | |
| 1516 | |
| 1517 (setq | |
| 1518 minibuf-string ; contents of minibuffer | |
| 1519 (save-excursion | |
| 1520 (set-buffer mouse-grabbed-buffer) | |
| 1521 (buffer-string)) | |
| 1522 | |
| 1523 buffer-string ; string to be highlighted (or not) | |
| 1524 (buffer-substring (car region) (cdr region)) | |
| 1525 | |
| 1526 prefix | |
| 1527 (if file-completion | |
| 1528 (file-name-nondirectory minibuf-string) | |
| 1529 minibuf-string) | |
| 1530 | |
| 1531 string | |
| 1532 (if file-completion | |
| 1533 (concat (file-name-directory minibuf-string) buffer-string) | |
| 1534 buffer-string)) | |
| 1535 | |
| 1536 (if (or (and (fboundp 'ange-ftp-ftp-path) | |
| 1537 (or (ange-ftp-ftp-path buffer-string) | |
| 1538 (ange-ftp-ftp-path string))) | |
| 1539 (and (fboundp 'efs-ftp-path) | |
| 1540 (or (efs-ftp-path buffer-string) | |
| 1541 (efs-ftp-path string)))) | |
| 1542 ;; #### Like our counterpart in mode-motion: evil evil evil | |
| 1543 t | |
| 1544 (if file-completion | |
| 1545 (try-completion string | |
| 1546 minibuffer-completion-table | |
| 1547 minibuffer-completion-predicate) | |
| 1548 (eq 't (try-completion string | |
| 1549 minibuffer-completion-table | |
| 1550 minibuffer-completion-predicate)))) | |
| 1551 | |
| 1552 ;; the result is the region to be highlighted | |
| 1553 region))) | |
| 1554 (set-syntax-table old-syntax)))) | |
| 1555 | |
| 1556 ;; C source code scanner | |
| 1557 (defvar c-statement-starting-keyword-regexpr | |
| 1558 "\\(if\\|for\\|while\\|do\\|switch\\|break\\|continue\\)\\b") | |
| 1559 | |
| 1560 (defun c-boundaries (here) | |
| 1561 (setq *last-thing* 'sexp) | |
| 1562 (save-excursion | |
| 1563 (goto-char here) | |
| 1564 (let ((following-char (following-char)) | |
| 1565 (preceding-char (preceding-char)) | |
| 1566 aux) | |
| 1567 (if (= (char-syntax following-char) ?w) | |
| 1568 (progn | |
| 1569 (skip-chars-backward "a-zA-Z") | |
| 1570 (setq aux (point)) | |
| 1571 (skip-chars-backward "\n\t ") | |
| 1572 (if (= (preceding-char) ?#) | |
| 1573 (forward-char -1) | |
| 1574 (goto-char aux)))) | |
| 1575 (if (and (= following-char ?*) | |
| 1576 (= preceding-char ?/)) | |
| 1577 (forward-char -1)) | |
| 1578 (if (and (= following-char ?/) | |
| 1579 (= preceding-char ?*)) | |
| 1580 (forward-char -1)) | |
| 1581 (cond | |
| 1582 ((= (following-char) ?#) (c-scan-preproc-macros)) | |
| 1583 ((looking-at "/\\*") ; begin comment | |
| 1584 (let ((start (match-beginning 0))) | |
| 1585 (if (search-forward "*/" nil t) | |
| 1586 (thing-region start (match-end 0))))) | |
| 1587 ((looking-at "\\*/") ; end comment | |
| 1588 (let ((end (match-end 0))) | |
| 1589 (if (search-backward "/*" nil t) | |
| 1590 (thing-region (match-beginning 0) end)))) | |
| 1591 ((looking-at c-statement-starting-keyword-regexpr) ; if for while do etc | |
| 1592 (thing-region (match-beginning 0) | |
| 1593 (c-forward-statement | |
| 1594 (buffer-substring (match-beginning 1) (match-end 1))))) | |
| 1595 ((looking-at "else\\b") | |
| 1596 (thing-region (match-beginning 0) (c-forward-else))) | |
| 1597 (t (if (= (char-syntax (following-char)) ?.) | |
| 1598 (thing-region here (1+ here)) | |
| 1599 (thing-boundaries here))))))) | |
| 1600 | |
| 1601 | |
| 1602 (defun c-scan-preproc-macros () | |
| 1603 (cond | |
| 1604 ((looking-at "^#[ \n\t]*include[ \n\t]*[<\"][^>\"]*[>\"]") ; #include | |
| 1605 (thing-region (match-beginning 0) (match-end 0))) | |
| 1606 ((looking-at "^#[ \n\t]*\\(define\\|undef\\)") ; #define, #undef | |
| 1607 (thing-region | |
| 1608 (match-beginning 0) | |
| 1609 (progn | |
| 1610 (end-of-line) | |
| 1611 (while (= (preceding-char) ?\\) | |
| 1612 (forward-line 1) | |
| 1613 (end-of-line)) | |
| 1614 (point)))) | |
| 1615 ;; #if, #ifdef, #ifndef, #else, #elif | |
| 1616 ((looking-at "^#[ \n\t]*\\(if\\|ifdef\\|ifndef\\|else\\|elif\\)\\b") | |
| 1617 (let ((start (match-beginning 0)) | |
| 1618 (counter 1) | |
| 1619 match) | |
| 1620 (goto-char (match-end 0)) | |
| 1621 (while (and (>= counter 1) | |
| 1622 (re-search-forward | |
| 1623 "^#[ \n\t]*\\(if\\|ifdef\\|ifndef\\|endif\\)\\b" | |
| 1624 nil t)) | |
| 1625 (setq match | |
| 1626 (buffer-substring (match-beginning 1) (match-end 1))) | |
| 1627 (setq counter | |
| 1628 (if (string= match "endif") | |
| 1629 (1- counter) | |
| 1630 (1+ counter)))) | |
| 1631 (if (= counter 0) | |
| 1632 (thing-region start (match-end 0))))) | |
| 1633 ((looking-at "^#[ \n\t]*endif\\b") ; #endif | |
| 1634 (let ((end (match-end 0)) | |
| 1635 (counter 1) | |
| 1636 match) | |
| 1637 (goto-char (match-beginning 0)) | |
| 1638 (while (and (>= counter 1) | |
| 1639 (re-search-backward | |
| 1640 "^#[ \n\t]*\\(if\\|ifdef\\|ifndef\\|endif\\)\\b" | |
| 1641 nil t)) | |
| 1642 (setq match | |
| 1643 (buffer-substring (match-beginning 1) (match-end 1))) | |
| 1644 (setq counter | |
| 1645 (if (string= match "endif") | |
| 1646 (1+ counter) | |
| 1647 (1- counter)))) | |
| 1648 (if (= counter 0) | |
| 1649 (thing-region (match-beginning 0) end)))))) | |
| 1650 | |
| 1651 (defun c-skip-over-comment () | |
| 1652 (let ((aux (point))) | |
| 1653 (skip-chars-forward "\n\t ") | |
| 1654 (or (and (= (following-char) ?/) | |
| 1655 (= (char-after (1+ (point))) ?*) | |
| 1656 (search-forward "*/" nil t) | |
| 1657 (point)) | |
| 1658 (goto-char aux)))) | |
| 1659 | |
| 1660 (defun c-forward-statement (&optional keyword) | |
| 1661 (c-skip-over-comment) | |
| 1662 (skip-chars-forward " \n\t") | |
| 1663 (or keyword (setq keyword | |
| 1664 (if (looking-at c-statement-starting-keyword-regexpr) | |
| 1665 (buffer-substring | |
| 1666 (match-beginning 1) | |
| 1667 (match-end 1))))) | |
| 1668 (if keyword | |
| 1669 (cond ((string= keyword "if") | |
| 1670 (c-forward-if)) | |
| 1671 ((string= keyword "do") | |
| 1672 (c-forward-do-while)) | |
| 1673 ((member keyword '("for" "while" "switch")) | |
| 1674 (c-forward-for/while/switch)) | |
| 1675 ((member keyword '("break" "continue")) | |
| 1676 (c-forward-break/continue))) | |
| 1677 (cond ((= (following-char) ?\{) | |
| 1678 (forward-list 1) | |
| 1679 (point)) | |
| 1680 (t | |
| 1681 ;; Here I use that each C statement other then | |
| 1682 ;; a bloc, if, while, for, do ... ends in a `;' | |
| 1683 (let (char) | |
| 1684 (catch 'exit | |
| 1685 (while t | |
| 1686 (if (eobp) (throw 'exit nil)) | |
| 1687 (setq char (following-char)) | |
| 1688 (cond ((= (char-syntax char) ?.) | |
| 1689 (forward-char 1) | |
| 1690 (if (= char ?\;) (throw 'exit (point)))) | |
| 1691 (t (forward-sexp 1) | |
| 1692 (skip-chars-forward " \n\t")))))))))) | |
| 1693 | |
| 1694 (defun c-forward-if () | |
| 1695 (let (aux) | |
| 1696 (forward-word 1) ; if | |
| 1697 (forward-list 1) | |
| 1698 (c-forward-statement) | |
| 1699 (setq aux (point)) | |
| 1700 (skip-chars-forward "\n\t ") | |
| 1701 (if (looking-at "else\\b") | |
| 1702 (c-forward-else) | |
| 1703 (goto-char aux)))) | |
| 1704 | |
| 1705 (defun c-forward-else () | |
| 1706 (forward-word 1) ; else | |
| 1707 (c-forward-statement)) | |
| 1708 | |
| 1709 (defun c-forward-for/while/switch () | |
| 1710 (forward-word 1) ; for | |
| 1711 (forward-list 1) | |
| 1712 (c-forward-statement)) | |
| 1713 | |
| 1714 (defun c-forward-do-while () | |
| 1715 (forward-word 1) ; do ... while | |
| 1716 (c-forward-statement) | |
| 1717 (c-forward-for/while/switch)) | |
| 1718 | |
| 1719 (defun c-forward-switch () | |
| 1720 (forward-word 1) ; switch | |
| 1721 (forward-list 2) | |
| 1722 (point)) | |
| 1723 | |
| 1724 (defun c-forward-break/continue () | |
| 1725 (forward-word 1) ; keyword | |
| 1726 (c-skip-over-comment) | |
| 1727 (skip-chars-forward "\n\t ") | |
| 1728 (if (= (following-char) ?\;) | |
| 1729 (goto-char (1+ (point))))) | |
| 1730 | |
| 1731 ;; Tcl syntax scanner | |
| 1732 (defvar tcl-builtin-commands nil | |
| 1733 "Alist of information about tcl syntax for the tcl-boundaries function. | |
| 1734 An entry has the form | |
| 1735 \(<command-string> . <syntax description>\) | |
| 1736 where | |
| 1737 <command-string> is the name of a tcl command | |
| 1738 <syntax description> is one of | |
| 1739 list of integers: the number of possible arguments | |
| 1740 t: any number of arguments") | |
| 1741 | |
| 1742 (defconst tcl-commands | |
| 1743 '( | |
| 1744 ("append" . (2 . nil)) | |
| 1745 ("array" . (2 . 3)) | |
| 1746 ("break" . 0) | |
| 1747 ("case" . 3) | |
| 1748 ("catch" . 1) | |
| 1749 ("cd" . 1) | |
| 1750 ("close" . 1) | |
| 1751 ("concat" . t) | |
| 1752 ("continue" . 0) | |
| 1753 ("else" . (1 . nil)) | |
| 1754 ("elseif" . (1 . nil)) | |
| 1755 ("eof" . 1) | |
| 1756 ("error" . t) | |
| 1757 ("eval" . t) | |
| 1758 ("exec" . t) | |
| 1759 ("exit" . (0 . 1)) | |
| 1760 ("expr" . 1) | |
| 1761 ("file" . (2 . nil)) | |
| 1762 ("flush" . 1) | |
| 1763 ("for" . 4) | |
| 1764 ("foreach" . 3) | |
| 1765 ("format" . (1 . nil)) | |
| 1766 ("gets" . (1 . 2)) | |
| 1767 ("glob" . t) | |
| 1768 ("global" . (1 . nil)) | |
| 1769 ("history" . t) | |
| 1770 ("if" . (2 . nil)) | |
| 1771 ("incr" . (1 . 2)) | |
| 1772 ("info" . (1 . 4)) | |
| 1773 ("join" . (1 . 2)) | |
| 1774 ("lappend" . (2 . nil)) | |
| 1775 ("lindex" . 2) | |
| 1776 ("linsert" . (3 . nil)) | |
| 1777 ("list" . t) | |
| 1778 ("llength" . 1) | |
| 1779 ("lrange" . 3) | |
| 1780 ("lreplace" . (3 . nil)) | |
| 1781 ("lsearch" . 2) | |
| 1782 ("lsort" . 1) | |
| 1783 ("open" . (1 . 2)) | |
| 1784 ("proc" . 3) | |
| 1785 ("puts" . (1 . 3)) | |
| 1786 ("pwd" . 0) | |
| 1787 ("read" . (1 . 2)) | |
| 1788 ("regexp" . (2 . nil)) | |
| 1789 ("regsub" . (4 . 6)) | |
| 1790 ("rename" . 2) | |
| 1791 ("return" . (0 .1)) | |
| 1792 ("scan" . (3 . nil)) | |
| 1793 ("seek" . (2 . 3)) | |
| 1794 ("set" . (1 . 2)) | |
| 1795 ("source" . 1) | |
| 1796 ("split" . (1 . 2)) | |
| 1797 ("string" . (2 . 4)) | |
| 1798 ("tell" . 1) | |
| 1799 ("time" . (1 .2)) | |
| 1800 ("trace" . (1 . nil)) | |
| 1801 ("unknown" . (1 . nil)) | |
| 1802 ("unset" . (1 . nil)) | |
| 1803 ("uplevel" . (1 . nil)) | |
| 1804 ("upvar" . (2 . nil)) | |
| 1805 ("while" . 2) | |
| 1806 )) | |
| 1807 | |
| 1808 (defconst tk-commands | |
| 1809 '(("bind" . 3) | |
| 1810 ("button" . t) | |
| 1811 ("canvas" . t) | |
| 1812 ("frame" . t) | |
| 1813 ("label" . t) | |
| 1814 ("listbox" . t) | |
| 1815 ("menu" . t) | |
| 1816 ("menubutton" . t) | |
| 1817 ("pack" . t) | |
| 1818 ("scrollbar" . t) | |
| 1819 ("tree" . t) | |
| 1820 ("wm" . t) | |
| 1821 )) | |
| 1822 | |
| 1823 (defconst tcl-tk-commands | |
| 1824 (nconc tcl-commands tk-commands)) | |
| 1825 | |
| 1826 (defconst tcl-tk-commands-regexp | |
| 1827 (format "\\(%s\\\)\\W" (mapconcat 'car tcl-tk-commands "\\|"))) | |
| 1828 | |
| 1829 (defun tcl-boundaries (here) | |
| 1830 (save-excursion | |
| 1831 (goto-char here) | |
| 1832 (skip-chars-backward "a-z") | |
| 1833 (if (looking-at | |
| 1834 tcl-tk-commands-regexp) | |
| 1835 (let* ((count 0) | |
| 1836 (start (point)) | |
| 1837 (keyword (buffer-substring | |
| 1838 (match-beginning 1) | |
| 1839 (match-end 1))) | |
| 1840 (syntax-description | |
| 1841 (cdr (assoc keyword tcl-tk-commands)))) | |
| 1842 (goto-char (match-end 0)) | |
| 1843 (while (not (looking-at "[ \t]*[]\n;}]")) | |
| 1844 (setq count (1+ count)) | |
| 1845 (tcl-forward-sexp1) | |
| 1846 ;; skipping over the parentheses of array expressions: | |
| 1847 (while (not (or (looking-at "[ \t]*[]\n;}]") | |
| 1848 (= (char-syntax (following-char)) ? ))) | |
| 1849 (tcl-forward-sexp1))) | |
| 1850 | |
| 1851 (if (cond ((eq syntax-description t)) | |
| 1852 ((integerp syntax-description) | |
| 1853 (= syntax-description count)) | |
| 1854 ((consp syntax-description) | |
| 1855 (and (<= (car syntax-description) count) | |
| 1856 (or (null (cdr syntax-description)) | |
| 1857 (<= count (cdr syntax-description)))))) | |
| 1858 (progn | |
| 1859 (message "`%s' matched." keyword) | |
| 1860 (thing-region start (point))) | |
| 1861 (progn | |
| 1862 (message "wrong syntax: `%s'." keyword) | |
| 1863 nil))) | |
| 1864 (message "") | |
| 1865 (thing-boundaries here)))) | |
| 1866 | |
| 1867 (defun tcl-forward-sexp (&optional arg) | |
| 1868 "Move forward across one balanced tcl expression. | |
| 1869 With argument, do it that many times." | |
| 1870 (interactive "p") | |
| 1871 (if (< arg 0) (error "negative argument not allowed")) | |
| 1872 (or arg (setq arg 1)) | |
| 1873 (while (> arg 0) | |
| 1874 (tcl-forward-sexp1) | |
| 1875 (setq arg (1- arg)))) | |
| 1876 | |
| 1877 (defun tcl-forward-sexp1 () | |
| 1878 (interactive "") | |
| 1879 (let ((start (point)) | |
| 1880 next-char syntax (first-scan t)) | |
| 1881 (setq next-char (following-char) | |
| 1882 syntax (char-syntax next-char)) | |
| 1883 | |
| 1884 (while (or (= next-char ?\;) | |
| 1885 (memq syntax '(? ?>))) | |
| 1886 (forward-char 1) | |
| 1887 (setq next-char (following-char) | |
| 1888 syntax (char-syntax next-char))) | |
| 1889 | |
| 1890 (condition-case var | |
| 1891 (catch 'exit | |
| 1892 (while t | |
| 1893 (setq next-char (following-char) | |
| 1894 syntax (char-syntax next-char)) | |
| 1895 (cond ((= next-char ?\;) | |
| 1896 (throw 'exit nil)) | |
| 1897 ((memq syntax (if first-scan '(? ?>) '(? ?> ?\)))) | |
| 1898 (throw 'exit nil)) | |
| 1899 (t | |
| 1900 (goto-char (or (scan-sexps (point) 1) | |
| 1901 (point-max))))) | |
| 1902 (setq first-scan nil))) | |
| 1903 (error (goto-char start) | |
| 1904 (error (car (cdr var))))))) | |
| 1905 | |
| 1906 ;; (define-key tcl-mode-map "\M-\C-f" 'tcl-forward-sexp) | |
| 1907 | |
| 1908 (defun mode-motion-eval-func (eval-func) | |
| 1909 (let ((old-buf (current-buffer)) | |
| 1910 (old-window (selected-window))) | |
| 1911 (unwind-protect | |
| 1912 (let ((extent (or primary-selection-extent | |
| 1913 (and (extentp mode-motion-last-extent) | |
| 1914 (not (extent-property mode-motion-last-extent | |
| 1915 'detached)) | |
| 1916 mode-motion-last-extent)))) | |
| 1917 | |
| 1918 (if (and (extentp extent) | |
| 1919 (set-buffer (extent-buffer extent)) | |
| 1920 (not | |
| 1921 ;; zero length extents | |
| 1922 (= (extent-start-position extent) | |
| 1923 (extent-end-position extent)))) | |
| 1924 | |
| 1925 (let* ((start (extent-start-position extent)) | |
| 1926 (end (extent-end-position extent))) | |
| 1927 | |
| 1928 (funcall eval-func start end)) | |
| 1929 | |
| 1930 (error "No current primary or motion selection.") | |
| 1931 )) | |
| 1932 (set-buffer old-buf) | |
| 1933 (select-window old-window)))) | |
| 1934 | |
| 1935 (defun mode-motion-eval-region () | |
| 1936 (interactive) | |
| 1937 (mode-motion-eval-func 'eval-region)) | |
| 1938 | |
| 1939 | |
| 1940 ;; Motion highlight faces and initialization. | |
| 1941 | |
| 1942 (defun sect-handler (string) | |
| 1943 "Return the symbol corresponding to the foo-STRING handler for this sect." | |
| 1944 (intern-soft (concat (symbol-name mode-motion+-religion) string))) | |
| 1945 | |
| 1946 (defun mode-motion-init-handlers-according-to-religion (&optional forcep) | |
| 1947 (interactive) | |
| 1948 ;; Initialise default motion handlers depending on religious sect! | |
| 1949 (let ((foo-thing (sect-handler "-thing")) | |
| 1950 (foo-c (sect-handler "-c")) | |
| 1951 (foo-LaTeX (sect-handler "-laTeX")) | |
| 1952 (foo-line@ (sect-handler "-line@")) | |
| 1953 (foo-vline@ (sect-handler "-vline@"))) | |
| 1954 (if forcep | |
| 1955 (progn | |
| 1956 (setq default-motion-handler (find-motion-handler foo-thing)) | |
| 1957 (set-mode-motion-handler 'emacs-lisp-mode foo-thing) | |
| 1958 (set-mode-motion-handler 'lisp-interaction-mode foo-thing) | |
| 1959 (set-mode-motion-handler 'c-mode foo-c) | |
| 1960 (set-mode-motion-handler 'c++-mode foo-c) | |
| 1961 (set-mode-motion-handler 'c++-c-mode foo-c) | |
| 1962 (set-mode-motion-handler 'tex-mode foo-LaTeX) | |
| 1963 (set-mode-motion-handler 'latex-mode foo-LaTeX) | |
| 1964 (set-mode-motion-handler 'Buffer-menu-mode foo-vline@) | |
| 1965 (set-mode-motion-handler 'Electric-Buffer-menu-mode foo-vline@) | |
| 1966 (set-mode-motion-handler 'gnus-Group-mode foo-vline@) | |
| 1967 (set-mode-motion-handler 'gnus-Subject-mode foo-vline@) | |
| 1968 (set-mode-motion-handler 'gnus-group-mode foo-vline@) | |
| 1969 (set-mode-motion-handler 'gnus-subject-mode foo-vline@) | |
| 1970 (set-mode-motion-handler 'gnus-summary-mode foo-vline@) | |
| 1971 (set-mode-motion-handler 'dired-mode foo-line@) | |
| 1972 (set-mode-motion-handler 'compilation-mode foo-line@) | |
| 1973 (set-mode-motion-handler 'occur-mode foo-line@) | |
| 1974 (set-mode-motion-handler 'tar-mode foo-vline@) | |
| 1975 (set-mode-motion-handler 'rmail-summary-mode foo-vline@) | |
| 1976 (set-mode-motion-handler 'vm-summary-mode (sect-handler "-line")) | |
| 1977 (set-mode-motion-handler 'tcl-mode (sect-handler "-tcl")) | |
| 1978 (set-mode-motion-handler 'texinfo-mode (sect-handler "-TeXinfo")) | |
| 1979 (set-mode-motion-handler 'cvs-mode (sect-handler "-cvs-line"))) | |
| 1980 (setq default-motion-handler | |
| 1981 (or default-motion-handler (find-motion-handler foo-thing))) | |
| 1982 (or (get 'emacs-lisp-mode 'mode-motion-handler) | |
| 1983 (set-mode-motion-handler 'emacs-lisp-mode foo-thing)) | |
| 1984 (or (get 'lisp-interaction-mode 'mode-motion-handler) | |
| 1985 (set-mode-motion-handler 'lisp-interaction-mode foo-thing)) | |
| 1986 (or (get 'c-mode 'mode-motion-handler) | |
| 1987 (set-mode-motion-handler 'c-mode foo-c)) | |
| 1988 (or (get 'c++-mode 'mode-motion-handler) | |
| 1989 (set-mode-motion-handler 'c++-mode foo-c)) | |
| 1990 (or (get 'c++-c-mode 'mode-motion-handler) | |
| 1991 (set-mode-motion-handler 'c++-c-mode foo-c)) | |
| 1992 (or (get 'tex-mode 'mode-motion-handler) | |
| 1993 (set-mode-motion-handler 'tex-mode foo-LaTeX)) | |
| 1994 (or (get 'latex-mode 'mode-motion-handler) | |
| 1995 (set-mode-motion-handler 'latex-mode foo-LaTeX)) | |
| 1996 (or (get 'Buffer-menu-mode 'mode-motion-handler) | |
| 1997 (set-mode-motion-handler 'Buffer-menu-mode foo-vline@)) | |
| 1998 (or (get 'Electric-Buffer-menu-mode 'mode-motion-handler) | |
| 1999 (set-mode-motion-handler 'Electric-Buffer-menu-mode foo-vline@)) | |
| 2000 (or (get 'gnus-Group-mode 'mode-motion-handler) | |
| 2001 (set-mode-motion-handler 'gnus-Group-mode foo-vline@)) | |
| 2002 (or (get 'gnus-Subject-mode 'mode-motion-handler) | |
| 2003 (set-mode-motion-handler 'gnus-Subject-mode foo-vline@)) | |
| 2004 (or (get 'gnus-group-mode 'mode-motion-handler) | |
| 2005 (set-mode-motion-handler 'gnus-group-mode foo-vline@)) | |
| 2006 (or (get 'gnus-subject-mode 'mode-motion-handler) | |
| 2007 (set-mode-motion-handler 'gnus-subject-mode foo-vline@)) | |
| 2008 (or (get 'gnus-summary-mode 'mode-motion-handler) | |
| 2009 (set-mode-motion-handler 'gnus-summary-mode foo-vline@)) | |
| 2010 (or (get 'dired-mode 'mode-motion-handler) | |
| 2011 (set-mode-motion-handler 'dired-mode foo-line@)) | |
| 2012 (or (get 'compilation-mode 'mode-motion-handler) | |
| 2013 (set-mode-motion-handler 'compilation-mode foo-line@)) | |
| 2014 (or (get 'occur-mode 'mode-motion-handler) | |
| 2015 (set-mode-motion-handler 'occur-mode foo-line@)) | |
| 2016 (or (get 'tar-mode 'mode-motion-handler) | |
| 2017 (set-mode-motion-handler 'tar-mode foo-vline@)) | |
| 2018 (or (get 'rmail-summary-mode 'mode-motion-handler) | |
| 2019 (set-mode-motion-handler 'rmail-summary-mode foo-vline@)) | |
| 2020 (or (get 'vm-summary-mode 'mode-motion-handler) | |
| 2021 (set-mode-motion-handler 'vm-summary-mode (sect-handler "-line"))) | |
| 2022 (or (get 'tcl-mode 'mode-motion-handler) | |
| 2023 (set-mode-motion-handler 'tcl-mode (sect-handler "-tcl"))) | |
| 2024 (or (get 'texinfo-mode 'mode-motion-handler) | |
| 2025 (set-mode-motion-handler 'texinfo-mode (sect-handler "-TeXinfo"))) | |
| 2026 (or (get 'cvs-mode 'mode-motion-handler) | |
| 2027 (set-mode-motion-handler 'cvs-mode (sect-handler "-cvs-line")))))) | |
| 2028 | |
| 2029 ;; Null Handlers (for disabling motion highlighting) | |
| 2030 (defun thing-null (here) nil) | |
| 2031 (make-motion-handler 'no-thing 'thing-null) | |
| 2032 (make-motion-handler 'no-c 'thing-null) | |
| 2033 (make-motion-handler 'no-laTeX 'thing-null) | |
| 2034 (make-motion-handler 'no-line 'thing-null) | |
| 2035 (make-motion-handler 'no-line@ 'thing-null) | |
| 2036 (make-motion-handler 'no-vline 'thing-null) | |
| 2037 (make-motion-handler 'no-vline@ 'thing-null) | |
| 2038 (make-motion-handler 'no-tcl 'thing-null) | |
| 2039 (make-motion-handler 'no-TeXinfo 'thing-null) | |
| 2040 (make-motion-handler 'no-cvs-line 'thing-null) | |
| 2041 | |
| 2042 (defun mode-motion-init () | |
| 2043 "enable mode-motion+ package" | |
| 2044 (interactive) | |
| 2045 | |
| 2046 (setq mode-motion-last-extent nil) | |
| 2047 | |
| 2048 (global-set-key '(meta button2) 'mode-motion-copy) | |
| 2049 (global-set-key '(meta shift button2) 'mode-motion-move) | |
| 2050 (global-set-key '(meta control button2) 'mode-motion-kill) | |
| 2051 (global-set-key '(meta control shift button2) 'mode-motion-copy-as-kill) | |
| 2052 (global-set-key '(meta control symbol button2) 'mode-motion-copy-as-kill) | |
| 2053 | |
| 2054 (if mode-motion-setup-cut-and-paste-bindings | |
| 2055 (progn | |
| 2056 (global-set-key 'f16 'mode-motion-copy-as-kill) ; Copy | |
| 2057 (global-set-key 'f18 'yank) ; Paste | |
| 2058 (global-set-key 'f20 'mode-motion-kill))) ; Cut | |
| 2059 | |
| 2060 ;; I don't want the thing-boundaries function select whitespaces | |
| 2061 (setq thing-report-whitespace nil thing-report-char-p nil) | |
| 2062 | |
| 2063 ;; bold motion face (bold, if this is not the default, unbold otherwise) | |
| 2064 (if (find-face 'motion-bold) | |
| 2065 () | |
| 2066 (make-face 'motion-bold) | |
| 2067 (make-face-bold 'motion-bold) | |
| 2068 (or (face-differs-from-default-p 'motion-bold) | |
| 2069 (make-face-unbold 'motion-bold))) | |
| 2070 | |
| 2071 ;; an underline face | |
| 2072 (if (find-face 'motion-underline) | |
| 2073 () | |
| 2074 (make-face 'motion-underline) | |
| 2075 (set-face-underline-p 'motion-underline t)) | |
| 2076 | |
| 2077 ;; an inverted face | |
| 2078 (if (find-face 'motion-inverted) | |
| 2079 () | |
| 2080 (make-face 'motion-inverted) | |
| 2081 (make-face-bold 'motion-inverted) | |
| 2082 (invert-face 'motion-inverted)) | |
| 2083 | |
| 2084 (if (find-face 'motion-gray) | |
| 2085 () | |
| 2086 (make-face 'motion-gray) | |
| 2087 (set-face-background-pixmap 'motion-gray "gray1.xbm")) | |
| 2088 | |
| 2089 ;; Motion Handlers | |
| 2090 | |
| 2091 ;; Special Minibuffer handler | |
| 2092 | |
| 2093 (make-motion-handler 'minibuffer 'minibuffer-selection-boundaries 'highlight t nil) | |
| 2094 | |
| 2095 ;; Things | |
| 2096 (make-motion-handler 'bold-thing 'thing-boundaries 'motion-bold) | |
| 2097 (make-motion-handler 'gray-thing 'thing-boundaries 'motion-gray) | |
| 2098 (make-motion-handler 'highlight-thing 'thing-boundaries 'highlight) | |
| 2099 (make-motion-handler 'invert-thing 'thing-boundaries 'motion-inverted) | |
| 2100 (make-motion-handler 'underline-thing 'thing-boundaries 'motion-underline) | |
| 2101 | |
| 2102 ;; Lines | |
| 2103 (make-motion-handler 'bold-line 'line-boundaries 'motion-bold) | |
| 2104 (make-motion-handler 'gray-line 'line-boundaries 'motion-gray) | |
| 2105 (make-motion-handler 'highlight-line 'line-boundaries 'highlight) | |
| 2106 (make-motion-handler 'invert-line 'line-boundaries 'motion-inverted) | |
| 2107 (make-motion-handler 'underline-line 'line-boundaries 'motion-underline) | |
| 2108 (make-motion-handler 'bold-line@ 'line-boundaries 'motion-bold t t) | |
| 2109 (make-motion-handler 'gray-line@ 'line-boundaries 'motion-gray nil t) | |
| 2110 (make-motion-handler 'highlight-line@ 'line-boundaries 'highlight nil t) | |
| 2111 (make-motion-handler 'invert-line@ 'line-boundaries 'motion-inverted nil t) | |
| 2112 (make-motion-handler 'underline-line@ 'line-boundaries 'motion-underline nil t) | |
| 2113 | |
| 2114 ;; Visible text of line | |
| 2115 (make-motion-handler 'bold-vline 'visible-line-boundaries 'motion-bold) | |
| 2116 (make-motion-handler 'gray-vline 'visible-line-boundaries 'motion-gray) | |
| 2117 (make-motion-handler 'highlight-vline 'visible-line-boundaries 'highlight) | |
| 2118 (make-motion-handler 'invert-vline 'visible-line-boundaries 'motion-inverted) | |
| 2119 (make-motion-handler 'underline-vline 'visible-line-boundaries 'motion-underline) | |
| 2120 (make-motion-handler 'bold-vline@ 'visible-line-boundaries 'motion-bold t t) | |
| 2121 (make-motion-handler 'gray-vline@ 'visible-line-boundaries 'motion-gray nil t) | |
| 2122 (make-motion-handler 'highlight-vline@ 'visible-line-boundaries 'highlight nil t) | |
| 2123 (make-motion-handler 'invert-vline@ 'visible-line-boundaries 'motion-inverted nil t) | |
| 2124 (make-motion-handler 'underline-vline@ 'visible-line-boundaries 'motion-underline nil t) | |
| 2125 | |
| 2126 ;; CVS lines | |
| 2127 (make-motion-handler 'bold-cvs-line 'cvs-line-boundaries 'motion-bold) | |
| 2128 (make-motion-handler 'gray-cvs-line 'cvs-line-boundaries 'motion-gray) | |
| 2129 (make-motion-handler 'highlight-cvs-line 'cvs-line-boundaries 'highlight) | |
| 2130 (make-motion-handler 'invert-cvs-line 'cvs-line-boundaries 'motion-inverted) | |
| 2131 (make-motion-handler | |
| 2132 'underline-cvs-line 'cvs-line-boundaries 'motion-underline) | |
| 2133 | |
| 2134 ;; (La)TeX | |
| 2135 (make-motion-handler 'bold-LaTeX 'latex-boundaries 'motion-bold) | |
| 2136 (make-motion-handler 'gray-LaTeX 'latex-boundaries 'motion-gray) | |
| 2137 (make-motion-handler 'highlight-LaTeX 'latex-boundaries 'highlight) | |
| 2138 (make-motion-handler 'invert-LaTeX 'latex-boundaries 'motion-inverted) | |
| 2139 (make-motion-handler 'underline-LaTeX 'latex-boundaries 'motion-underline) | |
| 2140 | |
| 2141 ;; TeXinfo | |
| 2142 (make-motion-handler 'bold-TeXinfo 'texinfo-boundaries 'motion-bold) | |
| 2143 (make-motion-handler 'gray-TeXinfo 'texinfo-boundaries 'motion-gray) | |
| 2144 (make-motion-handler 'highlight-TeXinfo 'texinfo-boundaries 'highlight) | |
| 2145 (make-motion-handler 'invert-TeXinfo 'texinfo-boundaries 'motion-inverted) | |
| 2146 (make-motion-handler 'underline-TeXinfo 'texinfo-boundaries 'motion-underline) | |
| 2147 | |
| 2148 ;; C and C++ | |
| 2149 (make-motion-handler 'bold-c 'c-boundaries 'motion-bold) | |
| 2150 (make-motion-handler 'gray-c 'c-boundaries 'motion-gray) | |
| 2151 (make-motion-handler 'highlight-c 'c-boundaries 'highlight) | |
| 2152 (make-motion-handler 'invert-c 'c-boundaries 'motion-inverted) | |
| 2153 (make-motion-handler 'underline-c 'c-boundaries 'motion-underline) | |
| 2154 | |
| 2155 ;; Tcl/Tk | |
| 2156 (make-motion-handler 'bold-tcl 'tcl-boundaries 'motion-bold) | |
| 2157 (make-motion-handler 'gray-tcl 'tcl-boundaries 'motion-gray) | |
| 2158 (make-motion-handler 'highlight-tcl 'tcl-boundaries 'highlight) | |
| 2159 (make-motion-handler 'invert-tcl 'tcl-boundaries 'motion-inverted) | |
| 2160 (make-motion-handler 'underline-tcl 'tcl-boundaries 'motion-underline) | |
| 2161 | |
| 2162 ;; mouse tracker | |
| 2163 (make-motion-handler 'track-mouse@ 'char-boundaries nil nil t) | |
| 2164 (make-motion-handler 'highlight-char 'char-boundaries 'highlight) | |
| 2165 | |
| 2166 ;; augment the basic mouse motion handler (if any) | |
| 2167 (setq-default mode-motion-hook | |
| 2168 (if (listp mode-motion-hook) | |
| 2169 (if (memq #'mode-motion+-highlight mode-motion-hook) | |
| 2170 mode-motion-hook | |
| 2171 (append mode-motion-hook (list #'mode-motion+-highlight))) | |
| 2172 (list mode-motion-hook #'mode-motion+-highlight))) | |
| 2173 | |
| 2174 (or mode-motion+-religion | |
| 2175 (setq mode-motion+-religion (if (x-display-color-p) 'underline 'invert))) | |
| 2176 | |
| 2177 (add-menu '("Options") (car mode-motion+-options-menu) | |
| 2178 (cdr mode-motion+-options-menu) | |
| 2179 "Paren Highlighting") | |
| 2180 | |
| 2181 ;; shut your eyes, this is a kludge. I didn't have time to find/write | |
| 2182 ;; a function to do this. | |
| 2183 (or (member ["Eval Motion Region" mode-motion-eval-region t] | |
| 2184 lisp-interaction-mode-popup-menu) | |
| 2185 (and (setq lisp-interaction-mode-popup-menu | |
| 2186 (copy-sequence lisp-interaction-mode-popup-menu)) | |
| 2187 (setcdr (nthcdr 1 lisp-interaction-mode-popup-menu) | |
| 2188 (cons ["Eval Motion Region" mode-motion-eval-region t] | |
| 2189 (nthcdr 2 lisp-interaction-mode-popup-menu))))) | |
| 2190 | |
| 2191 (or (member ["Eval Motion Region" mode-motion-eval-region t] | |
| 2192 emacs-lisp-mode-popup-menu) | |
| 2193 (and (setq emacs-lisp-mode-popup-menu | |
| 2194 (copy-sequence emacs-lisp-mode-popup-menu)) | |
| 2195 (setcdr (nthcdr 3 emacs-lisp-mode-popup-menu) | |
| 2196 (cons ["Eval Motion Region" mode-motion-eval-region t] | |
| 2197 (nthcdr 4 emacs-lisp-mode-popup-menu))))) | |
| 2198 | |
| 2199 ;; Clear the last active motion extent when leaving a frame. | |
| 2200 (if (boundp 'mouse-leave-frame-hook) | |
| 2201 (add-hook 'mouse-leave-frame-hook 'mode-motion-clear-last-extent) | |
| 2202 (add-hook 'mouse-leave-screen-hook 'mode-motion-clear-last-extent)) | |
| 2203 | |
| 2204 (run-hooks 'mode-motion+-load-hook) | |
| 2205 (mode-motion-init-handlers-according-to-religion) | |
| 2206 | |
| 2207 (if (interactive-p) (message "mode-motion+ enabled"))) | |
| 2208 | |
| 2209 (if (and (not purify-flag) | |
| 2210 (or (not (boundp 'opt-mode-motion+)) opt-mode-motion+)) | |
| 2211 (mode-motion-init)) | |
| 2212 | |
| 2213 (provide 'mode-motion+) | |
| 2214 ;; end mode-motion+ |