Mercurial > hg > xemacs-beta
comparison lisp/utils/id-select.el @ 4:b82b59fe008d r19-15b3
Import from CVS: tag r19-15b3
| author | cvs |
|---|---|
| date | Mon, 13 Aug 2007 08:46:56 +0200 |
| parents | |
| children | 441bb1e64a06 |
comparison
equal
deleted
inserted
replaced
| 3:30df88044ec6 | 4:b82b59fe008d |
|---|---|
| 1 ;;!emacs | |
| 2 ;; | |
| 3 ;; LCD-ENTRY: id-select.el|InfoDock Associates|elisp@infodock.com|Syntactical region selecting|12/02/96|1.4.3| | |
| 4 ;; | |
| 5 ;; FILE: id-select.el | |
| 6 ;; SUMMARY: Select larger and larger syntax-driven regions in a buffer. | |
| 7 ;; USAGE: XEmacs and Emacs Lisp Library | |
| 8 ;; KEYWORDS: matching, mouse | |
| 9 ;; | |
| 10 ;; AUTHOR: Bob Weiner | |
| 11 ;; | |
| 12 ;; ORG: InfoDock Associates. We sell corporate support and development | |
| 13 ;; contracts for InfoDock, Emacs and XEmacs. | |
| 14 ;; E-mail: <info@infodock.com> Web: http://www.infodock.com | |
| 15 ;; Tel: +1 408-243-3300 | |
| 16 ;; | |
| 17 ;; ORIG-DATE: 19-Oct-96 at 02:25:27 | |
| 18 ;; LAST-MOD: 2-Dec-96 at 19:45:28 by Bob Weiner | |
| 19 ;; | |
| 20 ;; Copyright (C) 1996 InfoDock Associates | |
| 21 ;; | |
| 22 ;; This file is part of InfoDock. | |
| 23 ;; It is available for use and distribution under the terms of the GNU Public | |
| 24 ;; License. | |
| 25 ;; | |
| 26 ;; DESCRIPTION: | |
| 27 ;; | |
| 28 ;; This is a radically cool, drop in mouse and keyboard-based library for | |
| 29 ;; selecting successively bigger syntactical regions within a buffer. | |
| 30 ;; Simply load this library and you are ready to try it out by | |
| 31 ;; double-clicking on various kinds of characters in different buffer major | |
| 32 ;; modes. You'll quickly get the hang of it. (It also provides a command | |
| 33 ;; to jump between beginning and end tags within HTML and SGML buffers.) | |
| 34 ;; | |
| 35 ;; A great deal of smarts are built-in so that it does the right thing | |
| 36 ;; almost all of the time; many other attempts at similar behavior such as | |
| 37 ;; thing.el fail to deal with many file format complexities. | |
| 38 ;; | |
| 39 ;; Double clicks of the Selection Key (left mouse key) at the same point | |
| 40 ;; will select bigger and bigger regions with each successive use. The | |
| 41 ;; first double click selects a region based upon the character at the | |
| 42 ;; point of the click. For example, with the point over an opening or | |
| 43 ;; closing grouping character, such as { or }, the whole grouping is | |
| 44 ;; selected, e.g. a C function. When on an _ or - within a programming | |
| 45 ;; language variable name, the whole name is selected. The type of | |
| 46 ;; selection is displayed in the minibuffer as feedback. When using a | |
| 47 ;; language based mainly on indenting, like Bourne shell, a double click on | |
| 48 ;; the first alpha character of a line, such as an if statement, selects | |
| 49 ;; the whole statement. | |
| 50 ;; | |
| 51 ;; --------------- | |
| 52 ;; | |
| 53 ;; This whole package is driven by a single function, available in mouse | |
| 54 ;; and keyboard forms, that first marks a region based on the syntax | |
| 55 ;; category of the character following point. Successive invocations mark | |
| 56 ;; larger and larger regions until the whole buffer is marked. See the | |
| 57 ;; documentation for the function, id-select-syntactical-region, for the | |
| 58 ;; kinds of syntax categories handled. | |
| 59 ;; | |
| 60 ;; Loading this package automatically installs its functionalty on | |
| 61 ;; double-clicks (or higher) of the left mouse key. (See the documentation | |
| 62 ;; for the variable, mouse-track-click-hook, for how this is done.) A | |
| 63 ;; single click of the left button will remove the region and reset point. | |
| 64 ;; | |
| 65 ;; The function, id-select-thing, may be bound to a key, {C-c s}, seems to | |
| 66 ;; be a reasonable choice, to provide the same syntax-driven region | |
| 67 ;; selection functionality. Use {C-g} to unmark the region when done. | |
| 68 ;; Use, id-select-thing-with-mouse, if you want to bind this to a mouse key | |
| 69 ;; and thereby use single clicks instead of double clicks. | |
| 70 ;; | |
| 71 ;; Three other commands are also provided: | |
| 72 ;; id-select-and-copy-thing - mark and copy the syntactical unit to the | |
| 73 ;; kill ring | |
| 74 ;; id-select-and-kill-thing - kill the syntactical unit at point | |
| 75 ;; id-select-goto-matching-tag - In HTML and SGML modes (actually any | |
| 76 ;; listed in the variable, `id-select-markup-modes'), moves point to the | |
| 77 ;; start of the tag paired with the closest tag that point is within or | |
| 78 ;; which it precedes, so you can quickly jump back and forth between | |
| 79 ;; open and close tags. | |
| 80 ;; | |
| 81 ;; --------------- | |
| 82 ;; SETUP: | |
| 83 ;; | |
| 84 ;; To autoload this package under XEmacs or InfoDock via mouse usage, add | |
| 85 ;; the following line to one of your initialization files. (Don't do this | |
| 86 ;; for GNU Emacs.) | |
| 87 ;; | |
| 88 ;; (add-hook 'mouse-track-click-hook 'id-select-double-click-hook) | |
| 89 ;; | |
| 90 ;; For any version of Emacs you should add the following autoload entries | |
| 91 ;; at your site: | |
| 92 ;; | |
| 93 ;; (autoload 'id-select-and-kill-thing | |
| 94 ;; "id-select" "Kill syntactical region selection" t) | |
| 95 ;; (autoload 'id-select-and-copy-thing | |
| 96 ;; "id-select" "Select and copy syntactical region" t) | |
| 97 ;; (autoload 'id-select-double-click-hook | |
| 98 ;; "id-select" "Double mouse click syntactical region selection" nil) | |
| 99 ;; (autoload 'id-select-thing | |
| 100 ;; "id-select" "Keyboard-driven syntactical region selection" t) | |
| 101 ;; (autoload 'id-select-thing-with-mouse | |
| 102 ;; "id-select" "Single mouse click syntactical region selection" t) | |
| 103 ;; | |
| 104 ;; If you want to be able to select C++ and Java methods and classes by | |
| 105 ;; double-clicking on the first character of a definition or on its opening | |
| 106 ;; or closing brace, you may need the following setting (all | |
| 107 ;; because Sun programmers can't put their opening braces in the first | |
| 108 ;; column): | |
| 109 ;; | |
| 110 ;; (add-hook 'java-mode-hook | |
| 111 ;; (function | |
| 112 ;; (lambda () | |
| 113 ;; (setq defun-prompt-regexp | |
| 114 ;; "^[ \t]*\\(\\(\\(public\\|protected\\|private\\|const\\|abstract\\|synchronized\\|final\\|static\\|threadsafe\\|transient\\|native\\|volatile\\)\\s-+\\)*\\(\\(\\([[a-zA-Z][][_$.a-zA-Z0-9]*[][_$.a-zA-Z0-9]+\\|[[a-zA-Z]\\)\\s-*\\)\\s-+\\)\\)?\\(\\([[a-zA-Z][][_$.a-zA-Z0-9]*\\s-+\\)\\s-*\\)?\\([_a-zA-Z][^][ \t:;.,{}()=]*\\|\\([_$a-zA-Z][_$.a-zA-Z0-9]*\\)\\)\\s-*\\(([^);{}]*)\\)?\\([] \t]*\\)\\(\\s-*\\<throws\\>\\s-*\\(\\([_$a-zA-Z][_$.a-zA-Z0-9]*\\)[, \t\n\r\f]*\\)+\\)?\\s-*")))) | |
| 115 ;; | |
| 116 ;; (add-hook 'c++-mode-hook | |
| 117 ;; (function | |
| 118 ;; (lambda () | |
| 119 ;; (setq defun-prompt-regexp | |
| 120 ;; "^[ \t]*\\(template[ \t\n\r]*<[^>;.{}]+>[ \t\n\r]*\\)?\\(\\(\\(auto\\|const\\|explicit\\|extern[ \t\n\r]+\"[^\"]+\"\\|extern\\|friend\\|inline\\|mutable\\|overload\\|register\\|static\\|typedef\\|virtual\\)[ \t\n\r]+\\)*\\(\\([[<a-zA-Z][]_a-zA-Z0-9]*\\(::[]_a-zA-Z0-9]+\\)?[ \t\n\r]*<[_<>a-zA-Z0-9 ,]+>[ \t\n\r]*[*&]*\\|[[<a-zA-Z][]_<>a-zA-Z0-9]*\\(::[[<a-zA-Z][]_<>a-zA-Z0-9]+\\)?[ \t\n\r]*[*&]*\\)[*& \t\n\r]+\\)\\)?\\(\\(::\\|[[<a-zA-Z][]_a-zA-Z0-9]*[ \t\n\r]*<[^>;{}]+>[ \t\n\r]*[*&]*::\\|[[<a-zA-Z][]_~<>a-zA-Z0-9]*[ \t\n\r]*[*&]*::\\)[ \t\n\r]*\\)?\\(operator[ \t\n\r]*[^ \t\n\r:;.,?~{}]+\\([ \t\n\r]*\\[\\]\\)?\\|[_~<a-zA-Z][^][ \t:;.,~{}()]*\\|[*&]?\\([_~<a-zA-Z][_a-zA-Z0-9]*[ \t\n\r]*<[^>;{}]+[ \t\n\r>]*>\\|[_~<a-zA-Z][_~<>a-zA-Z0-9]*\\)\\)[ \t\n\r]*\\(([^{;]*)\\(\\([ \t\n\r]+const\\|[ \t\n\r]+mutable\\)?\\([ \t\n\r]*[=:][^;{]+\\)?\\)?\\)\\s-*")))) | |
| 121 ;; | |
| 122 ;; If you want tags, comments, sentences and text blocks to be selectable | |
| 123 ;; in HTML mode, you need to add the following to your personal | |
| 124 ;; initializations (You would do something similar for SGML mode.): | |
| 125 ;; | |
| 126 ;; ;; Make tag begin and end delimiters act like grouping characters, | |
| 127 ;; ;; for easy syntactical selection of tags. | |
| 128 ;; (add-hook 'html-mode-hook | |
| 129 ;; (function | |
| 130 ;; (lambda () | |
| 131 ;; (modify-syntax-entry ?< "(>" html-mode-syntax-table) | |
| 132 ;; (modify-syntax-entry ?> ")<" html-mode-syntax-table) | |
| 133 ;; (modify-syntax-entry ?\" "\"" html-mode-syntax-table) | |
| 134 ;; (modify-syntax-entry ?= "." html-mode-syntax-table) | |
| 135 ;; (make-local-variable 'comment-start) | |
| 136 ;; (make-local-variable 'comment-end) | |
| 137 ;; (setq comment-start "<!--" comment-end "-->") | |
| 138 ;; (make-local-variable 'sentence-end) | |
| 139 ;; (setq sentence-end "\\([^ \t\n\r>]<\\|>\\(<[^>]*>\\)*\\|[.?!][]\"')}]*\\($\\| $\\|\t\\| \\)\\)[ \t\n]*") | |
| 140 ;; | |
| 141 ;; (define-key html-mode-map "\C-c." 'id-select-goto-matching-tag) | |
| 142 ;; ))) | |
| 143 ;; | |
| 144 ;; DESCRIP-END. | |
| 145 | |
| 146 ;;; ************************************************************************ | |
| 147 ;;; Public variables | |
| 148 ;;; ************************************************************************ | |
| 149 | |
| 150 (defvar id-select-brace-modes | |
| 151 '(c++-mode c-mode java-mode objc-mode perl-mode tcl-mode) | |
| 152 "*List of language major modes which define things with brace delimiters.") | |
| 153 | |
| 154 (defvar id-select-markup-modes | |
| 155 '(html-mode sgml-mode) | |
| 156 "*List of markup language modes that use SGML-style <tag> </tag> pairs.") | |
| 157 | |
| 158 (defvar id-select-text-modes | |
| 159 '(fundamental-mode kotl-mode indented-text-mode Info-mode outline-mode text-mode) | |
| 160 "*List of textual modes where paragraphs may be outdented or indented.") | |
| 161 | |
| 162 (defvar id-select-indent-modes | |
| 163 (append '(asm-mode csh-mode eiffel-mode ksh-mode python-mode pascal-mode | |
| 164 sather-mode) | |
| 165 id-select-text-modes) | |
| 166 "*List of language major modes which use mostly indentation to define syntactic structure.") | |
| 167 | |
| 168 (defvar id-select-indent-non-end-regexp-alist | |
| 169 '((csh-mode "\\(\\|then\\|elsif\\|else\\)[ \t]*$") | |
| 170 (eiffel-mode "\\(\\|then\\|else if\\|else\\)[ \t]*$") | |
| 171 (ksh-mode "\\(\\|then\\|elif\\|else\\)[ \t]*$") | |
| 172 (pascal-mode "\\(\\|then\\|else\\)[ \t]*$") | |
| 173 (python-mode "[ \t]*$") | |
| 174 (sather-mode "\\(\\|then\\|else if\\|else\\)[ \t]*$") | |
| 175 ;; | |
| 176 (fundamental-mode "[^ \t\n]") | |
| 177 (kotl-mode "[^ \t\n]") | |
| 178 (indented-text-mode "[^ \t\n]") | |
| 179 (Info-mode "[^ \t\n]") | |
| 180 (outline-mode "[^\\*]") | |
| 181 (text-mode "[^ \t\n]") | |
| 182 ) | |
| 183 "List of (major-mode . non-terminator-line-regexp) elements used to avoid early dropoff when marking indented code.") | |
| 184 | |
| 185 (defvar id-select-indent-end-regexp-alist | |
| 186 '((csh-mode "end\\|while") | |
| 187 (eiffel-mode "end") | |
| 188 (ksh-mode "\\(fi\\|esac\\|until\\|done\\)[ \t\n]") | |
| 189 (pascal-mode "end") | |
| 190 (sather-mode "end") | |
| 191 ;; | |
| 192 (fundamental-mode "[ \t]*$") | |
| 193 (indented-text-mode "[ \t]*$") | |
| 194 (Info-mode "[ \t]*$") | |
| 195 (text-mode "[ \t]*$") | |
| 196 ) | |
| 197 "List of (major-mode . terminator-line-regexp) elements used to include a final line when marking indented code.") | |
| 198 | |
| 199 (defvar id-select-char-p t | |
| 200 "*If t, return single character boundaries when all else fails.") | |
| 201 | |
| 202 (defvar id-select-display-type t | |
| 203 "*If t, display the thing selected with each mouse click.") | |
| 204 | |
| 205 (defvar id-select-whitespace t | |
| 206 "*If t, groups of whitespace are considered as things.") | |
| 207 | |
| 208 (if (string-match "XEmacs" emacs-version) | |
| 209 (add-hook 'mouse-track-click-hook 'id-select-double-click-hook) | |
| 210 (if (string-match "^19\\." emacs-version) | |
| 211 (progn (transient-mark-mode 1) | |
| 212 (global-set-key [mouse-1] 'mouse-set-point) | |
| 213 (global-set-key [double-mouse-1] 'id-select-thing-with-mouse) | |
| 214 (global-set-key [triple-mouse-1] 'id-select-thing-with-mouse)))) | |
| 215 | |
| 216 ;;; ************************************************************************ | |
| 217 ;;; Public functions | |
| 218 ;;; ************************************************************************ | |
| 219 | |
| 220 ;; | |
| 221 ;; Commands | |
| 222 ;; | |
| 223 | |
| 224 ;;;###autoload | |
| 225 (defun id-select-thing () | |
| 226 "Mark the region selected by the syntax of the thing at point. | |
| 227 If invoked repeatedly, selects bigger and bigger things. | |
| 228 If `id-select-display-type' is non-nil, the type of selection is displayed in | |
| 229 the minibuffer." | |
| 230 (interactive | |
| 231 (cond ((and (fboundp 'region-active-p) (region-active-p)) | |
| 232 nil) | |
| 233 ((and (boundp 'transient-mark-mode) transient-mark-mode mark-active) | |
| 234 nil) | |
| 235 (t | |
| 236 ;; Reset selection based on the syntax of character at point. | |
| 237 (id-select-reset) | |
| 238 nil))) | |
| 239 (let ((region (id-select-boundaries (point)))) | |
| 240 (if region | |
| 241 (progn (goto-char (car region)) | |
| 242 (set-mark (cdr region)) | |
| 243 (if (fboundp 'activate-region) (activate-region)) | |
| 244 (if (and (boundp 'transient-mark-mode) | |
| 245 transient-mark-mode) | |
| 246 (setq mark-active t)) | |
| 247 (and (interactive-p) id-select-display-type | |
| 248 (message "%s" id-select-previous)) | |
| 249 (run-hooks 'id-select-thing-hook) | |
| 250 t)))) | |
| 251 | |
| 252 ;;;###autoload | |
| 253 (defun id-select-thing-with-mouse (event) | |
| 254 "Select a region based on the syntax of the character from a mouse click. | |
| 255 If the click occurs at the same point as the last click, select | |
| 256 the next larger syntactic structure. If `id-select-display-type' is non-nil, | |
| 257 the type of selection is displayed in the minibuffer." | |
| 258 (interactive "@e") | |
| 259 (cond ((and (eq id-select-prior-point (point)) | |
| 260 (eq id-select-prior-buffer (current-buffer))) | |
| 261 ;; Prior click was at the same point as before, so enlarge | |
| 262 ;; selection to the next bigger item. | |
| 263 (if (and (id-select-bigger-thing) id-select-display-type) | |
| 264 (progn | |
| 265 ;; Conditionally, save selected region for pasting. | |
| 266 (cond | |
| 267 ;; XEmacs | |
| 268 ((fboundp 'x-store-cutbuffer) | |
| 269 (x-store-cutbuffer (buffer-substring (point) (mark)))) | |
| 270 ;; Emacs 19 | |
| 271 ((and (boundp 'interprogram-cut-function) | |
| 272 interprogram-cut-function) | |
| 273 (x-set-selection 'PRIMARY (buffer-substring (point) (mark))))) | |
| 274 (message "%s" id-select-previous))) | |
| 275 t) | |
| 276 (t (setq this-command 'mouse-start-selection) | |
| 277 (id-select-reset) | |
| 278 (id-select-thing-with-mouse event)))) | |
| 279 | |
| 280 ;;;###autoload | |
| 281 (defun id-select-goto-matching-tag () | |
| 282 "If in a major mode listed in `id-select-markup-modes,' moves point to the start of the tag paired with the closest tag that point is within or precedes. | |
| 283 Returns t if point is moved, else nil. | |
| 284 Signals an error if no tag is found following point or if the closing tag | |
| 285 does not have a `>' terminator character." | |
| 286 (interactive) | |
| 287 (if (not (memq major-mode id-select-markup-modes)) | |
| 288 nil | |
| 289 (let ((result) | |
| 290 ;; Assume case of tag names is irrelevant. | |
| 291 (case-fold-search t) | |
| 292 (opoint (point)) | |
| 293 (tag) | |
| 294 end-point | |
| 295 start-regexp | |
| 296 end-regexp) | |
| 297 | |
| 298 ;; Leave point at the start of the tag that point is within or that | |
| 299 ;; follows point. | |
| 300 (cond | |
| 301 ;; Point is at the start of a tag. | |
| 302 ((looking-at "<[^<> \t\n\r]")) | |
| 303 ;; Point was within a tag. | |
| 304 ((and (re-search-backward "[<>]" nil t) | |
| 305 (looking-at "<[^<> \t\n\r]"))) | |
| 306 ;; Move to following tag. | |
| 307 ((and (re-search-forward "<" nil t) | |
| 308 (progn (backward-char 1) | |
| 309 (looking-at "<[^<> \t\n\r]")))) | |
| 310 ;; No tag follows point. | |
| 311 (t (error "(id-select-goto-matching-tag): No tag found after point."))) | |
| 312 | |
| 313 (if (catch 'done | |
| 314 (cond | |
| 315 ;; Beginning of a tag pair | |
| 316 ((looking-at "<[^/][^<> \t\n\r]*") | |
| 317 (setq tag (buffer-substring (match-beginning 0) (match-end 0)) | |
| 318 start-regexp (regexp-quote tag) | |
| 319 end-regexp (concat "</" (substring start-regexp 1))) | |
| 320 ;; Skip over nested tags. | |
| 321 (let ((count 0) | |
| 322 (regexp (concat start-regexp "\\|" end-regexp)) | |
| 323 match-point) | |
| 324 (while (and (>= count 0) | |
| 325 (re-search-forward regexp nil t)) | |
| 326 (setq match-point (match-beginning 0)) | |
| 327 (if (/= (char-after (1+ (match-beginning 0))) ?/) | |
| 328 ;; Start tag | |
| 329 (setq count (1+ count)) | |
| 330 ;; End tag | |
| 331 (setq end-point (point)) | |
| 332 (if (or (not (re-search-forward "[<>]" nil t)) | |
| 333 (= (preceding-char) ?<)) | |
| 334 ;; No terminator character `>' for end tag | |
| 335 (progn (setq result end-point) | |
| 336 (throw 'done nil))) | |
| 337 (setq count (1- count)) | |
| 338 (if (= count 0) | |
| 339 (progn | |
| 340 (goto-char match-point) | |
| 341 (setq result t) | |
| 342 (throw 'done result))))))) | |
| 343 ;; | |
| 344 ;; End of a tag pair | |
| 345 ((or (looking-at "</[^> \t\n\r]+") | |
| 346 (and (skip-chars-backward "<") | |
| 347 (looking-at "</[^> \t\n\r]+"))) | |
| 348 (goto-char (match-end 0)) | |
| 349 (setq tag (buffer-substring (match-beginning 0) (match-end 0)) | |
| 350 end-regexp (regexp-quote tag) | |
| 351 start-regexp (concat "<" (substring end-regexp 2))) | |
| 352 (setq end-point (point)) | |
| 353 (if (or (not (re-search-forward "[<>]" nil t)) | |
| 354 (= (preceding-char) ?<)) | |
| 355 ;; No terminator character `>' for end tag | |
| 356 (progn (setq result end-point) | |
| 357 (throw 'done nil))) | |
| 358 ;; Skip over nested tags. | |
| 359 (let ((count 0) | |
| 360 (regexp (concat start-regexp "\\|" end-regexp))) | |
| 361 (while (and (>= count 0) | |
| 362 (re-search-backward regexp nil t)) | |
| 363 (if (= (char-after (1+ (point))) ?/) | |
| 364 ;; End tag | |
| 365 (setq count (1+ count)) | |
| 366 ;; Start tag | |
| 367 (setq count (1- count)) | |
| 368 (if (= count 0) | |
| 369 (progn | |
| 370 (setq result t) | |
| 371 (throw 'done t))))))))) | |
| 372 nil | |
| 373 ;; Didn't find matching tag. | |
| 374 (goto-char opoint)) | |
| 375 | |
| 376 (cond ((integerp result) | |
| 377 (goto-char result) | |
| 378 (error "(id-select-goto-matching-tag): Add a terminator character for this end <tag>")) | |
| 379 ((null tag) | |
| 380 (error "(id-select-goto-matching-tag): No <tag> following point")) | |
| 381 ((null result) | |
| 382 (if (interactive-p) | |
| 383 (progn | |
| 384 (beep) | |
| 385 (message "(id-select-goto-matching-tag): No matching tag for %s>" | |
| 386 tag) | |
| 387 result))) | |
| 388 (t result))))) | |
| 389 | |
| 390 ;;;###autoload | |
| 391 (defun id-select-and-copy-thing () | |
| 392 "Copy the region surrounding the syntactical unit at point." | |
| 393 (interactive) | |
| 394 (let ((bounds (id-select-boundaries (point)))) | |
| 395 (if bounds (copy-region-as-kill (car bounds) (cdr bounds))))) | |
| 396 | |
| 397 ;;;###autoload | |
| 398 (defun id-select-and-kill-thing () | |
| 399 "Kill the region surrounding the syntactical unit at point." | |
| 400 (interactive "*") | |
| 401 (let ((bounds (id-select-boundaries (point)))) | |
| 402 (if bounds (kill-region (car bounds) (cdr bounds))))) | |
| 403 | |
| 404 | |
| 405 ;; | |
| 406 ;; Functions | |
| 407 ;; | |
| 408 | |
| 409 (defun id-select-boundaries (pos) | |
| 410 "Return the (start . end) of a syntactically defined region based upon the last region selected or on position POS. | |
| 411 The character at POS is selected if no other thing is matched." | |
| 412 (interactive) | |
| 413 (setq zmacs-region-stays t) | |
| 414 (setcar id-select-old-region (car id-select-region)) | |
| 415 (setcdr id-select-old-region (cdr id-select-region)) | |
| 416 (let ((prior-type id-select-previous)) | |
| 417 (cond | |
| 418 ((eq id-select-previous 'char) | |
| 419 (id-select-syntactical-region pos)) | |
| 420 ((and (car id-select-old-region) | |
| 421 (memq id-select-previous | |
| 422 '(sexp sexp-start sexp-end sexp-up)) | |
| 423 (id-select-sexp-up pos) | |
| 424 (id-select-region-bigger-p id-select-old-region id-select-region)) | |
| 425 id-select-region) | |
| 426 ;; | |
| 427 ;; In the general case, we can't know ahead of time what the next | |
| 428 ;; biggest type of thing to select is, so we test them all and choose | |
| 429 ;; the best fit. This means that dynamically, the order of type | |
| 430 ;; selection will change based on the buffer context. | |
| 431 (t (let ((min-region (1+ (- (point-max) (point-min)))) | |
| 432 (result) | |
| 433 region region-size) | |
| 434 (mapcar | |
| 435 (function | |
| 436 (lambda (sym-func) | |
| 437 (setq region | |
| 438 (if (car (cdr sym-func)) | |
| 439 (funcall (car (cdr sym-func)) pos))) | |
| 440 (if (and region (car region) | |
| 441 (id-select-region-bigger-p | |
| 442 id-select-old-region region) | |
| 443 (setq region-size | |
| 444 (- (cdr region) (car region))) | |
| 445 (< region-size min-region)) | |
| 446 (setq min-region region-size | |
| 447 result | |
| 448 (list;; The actual selection type is | |
| 449 ;; sometimes different than the one we | |
| 450 ;; originally tried, so recompute it here. | |
| 451 (car (assq id-select-previous | |
| 452 id-select-bigger-alist)) | |
| 453 (car region) (cdr region)))))) | |
| 454 id-select-bigger-alist) | |
| 455 (if result | |
| 456 ;; Returns id-select-region | |
| 457 (progn (setq id-select-previous (car result)) | |
| 458 (id-select-set-region (nth 1 result) (nth 2 result))) | |
| 459 ;; | |
| 460 ;; Restore prior selection type since we failed to find a | |
| 461 ;; new one. | |
| 462 (setq id-select-previous prior-type) | |
| 463 (beep) | |
| 464 (message | |
| 465 "(id-select-boundaries): `%s' is the largest selectable region" | |
| 466 id-select-previous) | |
| 467 nil)))))) | |
| 468 | |
| 469 ;;;###autoload | |
| 470 (defun id-select-double-click-hook (event click-count) | |
| 471 "Select a region based on the syntax of the character wherever the mouse is double-clicked. | |
| 472 If the double-click occurs at the same point as the last double-click, select | |
| 473 the next larger syntactic structure. If `id-select-display-type' is non-nil, | |
| 474 the type of selection is displayed in the minibuffer." | |
| 475 (cond ((/= click-count 2) | |
| 476 ;; Return nil so any other hooks are performed. | |
| 477 nil) | |
| 478 (t (id-select-thing-with-mouse event)))) | |
| 479 | |
| 480 (defun id-select-syntactical-region (pos) | |
| 481 "Return the (start . end) of a syntactically defined region based upon the buffer position POS. | |
| 482 Uses `id-select-syntax-alist' and the current buffer's syntax table to | |
| 483 determine syntax groups. | |
| 484 | |
| 485 Typically: | |
| 486 Open or close grouping character syntax marks an s-expression. | |
| 487 Double quotes mark strings. | |
| 488 The end of a line marks the line, including its trailing newline. | |
| 489 Word syntax marks the current word. | |
| 490 Symbol syntax (such as _) marks a symbol. | |
| 491 Whitespace marks a span of whitespace. | |
| 492 Comment start or end syntax marks the comment. | |
| 493 Punctuation syntax marks the words on both sides of the punctuation. | |
| 494 The fallback default is to mark the character at POS. | |
| 495 | |
| 496 If an error occurs during syntax scanning, it returns nil." | |
| 497 (interactive "d") | |
| 498 (setq id-select-previous 'char) | |
| 499 (if (save-excursion (goto-char pos) (eolp)) | |
| 500 (id-select-line pos) | |
| 501 (let* ((syntax (char-syntax (if (eobp) (preceding-char) (char-after pos)))) | |
| 502 (pair (assq syntax id-select-syntax-alist))) | |
| 503 (cond ((and pair | |
| 504 (or id-select-whitespace | |
| 505 (not (eq (car (cdr pair)) 'thing-whitespace)))) | |
| 506 (funcall (car (cdr pair)) pos)) | |
| 507 (id-select-char-p | |
| 508 (setq id-select-previous 'char) | |
| 509 (id-select-set-region pos (1+ pos))) | |
| 510 (t | |
| 511 nil))))) | |
| 512 | |
| 513 ;;; ************************************************************************ | |
| 514 ;;; Private functions | |
| 515 ;;; ************************************************************************ | |
| 516 | |
| 517 (defun id-select-at-blank-line-or-comment () | |
| 518 "Return non-nil if on a blank line or a comment start or end line. | |
| 519 Assumes point is befor any non-whitespace character on the line." | |
| 520 (let ((comment-end-p (and (stringp comment-end) | |
| 521 (not (string-equal comment-end ""))))) | |
| 522 (if (looking-at | |
| 523 (concat "\\s-*$\\|\\s-*\\(//\\|/\\*\\|.*\\*/" | |
| 524 (if comment-start | |
| 525 (concat | |
| 526 "\\|" (regexp-quote comment-start))) | |
| 527 (if comment-end-p | |
| 528 (concat | |
| 529 "\\|.*" (regexp-quote comment-end))) | |
| 530 "\\)")) | |
| 531 (or (not (and comment-start comment-end-p)) | |
| 532 ;; Ignore start and end of comments that | |
| 533 ;; follow non-commented text. | |
| 534 (not (looking-at | |
| 535 (format ".*\\S-.*%s.*%s" | |
| 536 (regexp-quote comment-start) | |
| 537 (regexp-quote comment-end)))))))) | |
| 538 | |
| 539 (defun id-select-region-bigger-p (old-region new-region) | |
| 540 "Return t if OLD-REGION is smaller than NEW-REGION and NEW-REGION partially overlaps OLD-REGION, or if OLD-REGION is uninitialized." | |
| 541 (if (null (car old-region)) | |
| 542 t | |
| 543 (and (> (abs (- (cdr new-region) (car new-region))) | |
| 544 (abs (- (cdr old-region) (car old-region)))) | |
| 545 ;; Ensure the two regions intersect. | |
| 546 (or (and (<= (min (cdr new-region) (car new-region)) | |
| 547 (min (cdr old-region) (car old-region))) | |
| 548 (> (max (cdr new-region) (car new-region)) | |
| 549 (min (cdr old-region) (car old-region)))) | |
| 550 (and (> (min (cdr new-region) (car new-region)) | |
| 551 (min (cdr old-region) (car old-region))) | |
| 552 (<= (min (cdr new-region) (car new-region)) | |
| 553 (max (cdr old-region) (car old-region)))))))) | |
| 554 | |
| 555 (defun id-select-bigger-thing () | |
| 556 "Select a bigger object where point is." | |
| 557 (prog1 | |
| 558 (id-select-thing) | |
| 559 (setq this-command 'select-thing))) | |
| 560 | |
| 561 (defun id-select-reset () | |
| 562 ;; Reset syntactic selection. | |
| 563 (setq id-select-prior-point (point) | |
| 564 id-select-prior-buffer (current-buffer) | |
| 565 id-select-previous 'char) | |
| 566 (id-select-set-region nil nil)) | |
| 567 | |
| 568 (defun id-select-set-region (beginning end) | |
| 569 "Set the cons cell held by the variable `id-select-region' to (BEGINNING . END). | |
| 570 Return the updated cons cell." | |
| 571 (setcar id-select-region beginning) | |
| 572 (setcdr id-select-region end) | |
| 573 (if (and (null beginning) (null end)) | |
| 574 (progn (setcar id-select-old-region nil) | |
| 575 (setcdr id-select-old-region nil))) | |
| 576 (if (and (not (eq id-select-previous 'buffer)) | |
| 577 (integerp beginning) (integerp end) | |
| 578 (= beginning (point-min)) (= end (point-max))) | |
| 579 ;; If we selected the whole buffer, make sure that 'thing' type is 'buffer'. | |
| 580 nil | |
| 581 id-select-region)) | |
| 582 | |
| 583 (defun id-select-string-p (&optional start-delim end-delim) | |
| 584 "Returns (start . end) of string whose first line point is within or immediately before. | |
| 585 Positions include delimiters. String is delimited by double quotes unless | |
| 586 optional START-DELIM and END-DELIM (strings) are given. | |
| 587 Returns nil if not within a string." | |
| 588 (let ((opoint (point)) | |
| 589 (count 0) | |
| 590 bol start delim-regexp start-regexp end-regexp) | |
| 591 (or start-delim (setq start-delim "\"")) | |
| 592 (or end-delim (setq end-delim "\"")) | |
| 593 ;; Special case for the empty string. | |
| 594 (if (looking-at (concat (regexp-quote start-delim) | |
| 595 (regexp-quote end-delim))) | |
| 596 (id-select-set-region (point) (match-end 0)) | |
| 597 (setq start-regexp (concat "\\(^\\|[^\\]\\)\\(" | |
| 598 (regexp-quote start-delim) "\\)") | |
| 599 end-regexp (concat "[^\\]\\(" (regexp-quote end-delim) "\\)") | |
| 600 delim-regexp (concat start-regexp "\\|" end-regexp)) | |
| 601 (save-excursion | |
| 602 (beginning-of-line) | |
| 603 (setq bol (point)) | |
| 604 (while (re-search-forward delim-regexp opoint t) | |
| 605 (setq count (1+ count)) | |
| 606 ;; This is so we don't miss the closing delimiter of an empty | |
| 607 ;; string. | |
| 608 (if (and (= (point) (1+ bol)) | |
| 609 (looking-at (regexp-quote end-delim))) | |
| 610 (setq count (1+ count)) | |
| 611 (if (bobp) nil (backward-char 1)))) | |
| 612 (goto-char opoint) | |
| 613 ;; If found an even # of starting and ending delimiters before | |
| 614 ;; opoint, then opoint is at the start of a string, where we want it. | |
| 615 (if (zerop (mod count 2)) | |
| 616 (if (bobp) nil (backward-char 1)) | |
| 617 (re-search-backward start-regexp nil t)) | |
| 618 ;; Point is now before the start of the string. | |
| 619 (if (re-search-forward start-regexp nil t) | |
| 620 (progn | |
| 621 (setq start (match-beginning 2)) | |
| 622 (if (re-search-forward end-regexp nil t) | |
| 623 (id-select-set-region start (point))))))))) | |
| 624 | |
| 625 ;;; | |
| 626 ;;; Code selections | |
| 627 ;;; | |
| 628 | |
| 629 (defun id-select-brace-def-or-declaration (pos) | |
| 630 "If POS is at the first character, opening brace or closing brace of a brace delimited language definition, return (start . end) region, else nil. | |
| 631 The major mode for each supported brace language must be included in the | |
| 632 list, id-select-brace-modes." | |
| 633 (interactive) | |
| 634 (if (not (and (featurep 'cc-mode) (memq major-mode id-select-brace-modes))) | |
| 635 nil | |
| 636 (save-excursion | |
| 637 (goto-char pos) | |
| 638 (let ((at-def-brace | |
| 639 (or (looking-at "^{") (looking-at "^}") | |
| 640 ;; Handle stupid old C-style and new Java | |
| 641 ;; style of putting braces at the end of | |
| 642 ;; lines. | |
| 643 (and (= (following-char) ?{) | |
| 644 (stringp defun-prompt-regexp) | |
| 645 (save-excursion | |
| 646 (beginning-of-line) | |
| 647 (looking-at defun-prompt-regexp))) | |
| 648 (and (= (following-char) ?}) | |
| 649 (stringp defun-prompt-regexp) | |
| 650 (condition-case () | |
| 651 (progn | |
| 652 ;; Leave point at opening brace. | |
| 653 (goto-char | |
| 654 (scan-sexps (1+ (point)) -1)) | |
| 655 ;; Test if these are defun braces. | |
| 656 (save-excursion | |
| 657 (beginning-of-line) | |
| 658 (looking-at defun-prompt-regexp))) | |
| 659 (error nil))))) | |
| 660 eod) | |
| 661 (if (or at-def-brace | |
| 662 ;; At the start of a definition: | |
| 663 ;; Must be at the first non-whitespace character in the line. | |
| 664 (and (= (point) (save-excursion (back-to-indentation) (point))) | |
| 665 ;; Must be on an alpha or symbol-constituent character. | |
| 666 ;; Also allow ~ for C++ destructors. | |
| 667 (looking-at "[a-zA-z~]\\|\\s_") | |
| 668 ;; Previous line, if any, must be blank or a comment | |
| 669 ;; start or end or `defun-prompt-regexp' must be defined | |
| 670 ;; for this mode. | |
| 671 (or (stringp defun-prompt-regexp) | |
| 672 (save-excursion | |
| 673 (if (/= (forward-line -1) 0) | |
| 674 t | |
| 675 (id-select-at-blank-line-or-comment)))))) | |
| 676 (progn | |
| 677 (setq id-select-previous 'brace-def-or-declaration) | |
| 678 ;; Handle declarations and definitions embedded within classes. | |
| 679 (if (and (= (following-char) ?{) | |
| 680 (/= (point) (save-excursion (back-to-indentation) (point)))) | |
| 681 (setq at-def-brace nil)) | |
| 682 ;; | |
| 683 (if at-def-brace nil (beginning-of-line)) | |
| 684 (if (and (not at-def-brace) | |
| 685 (stringp defun-prompt-regexp) | |
| 686 (looking-at defun-prompt-regexp)) | |
| 687 ;; Mark the declaration or definition | |
| 688 (id-select-set-region | |
| 689 (point) | |
| 690 (progn (goto-char (match-end 0)) | |
| 691 (if (= (following-char) ?{) | |
| 692 (forward-list 1) | |
| 693 (search-forward ";" nil t)) | |
| 694 (skip-chars-forward " \t") | |
| 695 (skip-chars-forward "\n") | |
| 696 (if (looking-at "^\\s-*$") | |
| 697 (forward-line 1)) | |
| 698 (point))) | |
| 699 ;; Mark function definitions only | |
| 700 (setq eod (save-excursion | |
| 701 (condition-case () | |
| 702 (progn | |
| 703 (end-of-defun) | |
| 704 (if (looking-at "^\\s-*$") | |
| 705 (forward-line 1)) | |
| 706 (point)) | |
| 707 (error (point-max))))) | |
| 708 (if (= (following-char) ?}) | |
| 709 ;; Leave point at opening brace. | |
| 710 (goto-char (scan-sexps (1+ (point)) -1))) | |
| 711 (if (= (following-char) ?{) | |
| 712 (progn | |
| 713 (while (and (zerop (forward-line -1)) | |
| 714 (not (id-select-at-blank-line-or-comment)))) | |
| 715 (if (id-select-at-blank-line-or-comment) | |
| 716 (forward-line 1)))) | |
| 717 ;; Mark the whole definition | |
| 718 (setq id-select-previous 'brace-def-or-declaration) | |
| 719 (id-select-set-region (point) eod)))))))) | |
| 720 | |
| 721 (defun id-select-indent-def (pos) | |
| 722 "If POS is at the first alpha character on a line, return (start . end) region, | |
| 723 | |
| 724 The major mode for each supported indented language must be included in the | |
| 725 list, id-select-indent-modes." | |
| 726 (interactive) | |
| 727 (if (not (memq major-mode id-select-indent-modes)) | |
| 728 nil | |
| 729 (save-excursion | |
| 730 (goto-char pos) | |
| 731 (if (and | |
| 732 ;; Use this function only if point is on the first non-blank | |
| 733 ;; character of a block, whatever a block is for the current | |
| 734 ;; mode. | |
| 735 (cond ((eq major-mode 'kotl-mode) | |
| 736 (and (looking-at "[1-9*]") (not (kview:valid-position-p)))) | |
| 737 ((or (eq major-mode 'outline-mode) selective-display) | |
| 738 (save-excursion (beginning-of-line) | |
| 739 (looking-at outline-regexp))) | |
| 740 ;; After indent in any other mode, must be on an alpha | |
| 741 ;; or symbol-constituent character. | |
| 742 (t (looking-at "[a-zA-z]\\|\\s_"))) | |
| 743 ;; Must be at the first non-whitespace character in the line. | |
| 744 (= (point) (save-excursion (back-to-indentation) (point)))) | |
| 745 (let* ((start-col (current-column)) | |
| 746 (opoint (if (eq major-mode 'kotl-mode) | |
| 747 (progn (kotl-mode:to-valid-position) (point)) | |
| 748 (beginning-of-line) (point)))) | |
| 749 (while | |
| 750 (and (zerop (forward-line 1)) | |
| 751 (bolp) | |
| 752 (or (progn (back-to-indentation) | |
| 753 (> (current-column) start-col)) | |
| 754 ;; If in a text mode, allow outdenting, otherwise | |
| 755 ;; only include special lines here indented to the | |
| 756 ;; same point as the original line. | |
| 757 (and (or (memq major-mode id-select-text-modes) | |
| 758 (= (current-column) start-col)) | |
| 759 (looking-at | |
| 760 (or (car (cdr | |
| 761 (assq | |
| 762 major-mode | |
| 763 id-select-indent-non-end-regexp-alist))) | |
| 764 "\\'")))))) | |
| 765 (if (and (looking-at | |
| 766 (or (car (cdr (assq major-mode | |
| 767 id-select-indent-end-regexp-alist))) | |
| 768 "\\'")) | |
| 769 (or (memq major-mode id-select-text-modes) | |
| 770 (= (current-column) start-col))) | |
| 771 (forward-line 1)) | |
| 772 (beginning-of-line) | |
| 773 ;; Mark the whole definition | |
| 774 (setq id-select-previous 'indent-def) | |
| 775 (id-select-set-region opoint (point))))))) | |
| 776 | |
| 777 (defun id-select-symbol (pos) | |
| 778 "Return (start . end) of a symbol at POS." | |
| 779 (or (id-select-markup-pair pos) | |
| 780 ;; Test for indented def here since might be on an '*' representing | |
| 781 ;; an outline entry, in which case we mark entries as indented blocks. | |
| 782 (id-select-indent-def pos) | |
| 783 (save-excursion | |
| 784 (if (memq (char-syntax (if (eobp) (preceding-char) (char-after pos))) | |
| 785 '(?w ?_)) | |
| 786 (progn (setq id-select-previous 'symbol) | |
| 787 (condition-case () | |
| 788 (let ((end (scan-sexps pos 1))) | |
| 789 (id-select-set-region | |
| 790 (min pos (scan-sexps end -1)) end)) | |
| 791 (error nil))))))) | |
| 792 | |
| 793 (defun id-select-sexp-start (pos) | |
| 794 "Return (start . end) of sexp starting at POS." | |
| 795 (or (id-select-markup-pair pos) | |
| 796 (id-select-brace-def-or-declaration pos) | |
| 797 (save-excursion | |
| 798 (setq id-select-previous 'sexp-start) | |
| 799 (condition-case () | |
| 800 (id-select-set-region pos (scan-sexps pos 1)) | |
| 801 (error nil))))) | |
| 802 | |
| 803 (defun id-select-sexp-end (pos) | |
| 804 "Return (start . end) of sexp ending at POS." | |
| 805 (or (id-select-brace-def-or-declaration pos) | |
| 806 (save-excursion | |
| 807 (setq id-select-previous 'sexp-end) | |
| 808 (condition-case () | |
| 809 (id-select-set-region (scan-sexps (1+ pos) -1) (1+ pos)) | |
| 810 (error nil))))) | |
| 811 | |
| 812 (defun id-select-sexp (pos) | |
| 813 "Return (start . end) of the sexp that POS is within." | |
| 814 (setq id-select-previous 'sexp) | |
| 815 (save-excursion | |
| 816 (goto-char pos) | |
| 817 (condition-case () | |
| 818 (id-select-set-region (progn (backward-up-list 1) (point)) | |
| 819 (progn (forward-list 1) (point))) | |
| 820 (error nil)))) | |
| 821 | |
| 822 (defun id-select-sexp-up (pos) | |
| 823 "Return (start . end) of the sexp enclosing the selected area or nil." | |
| 824 (setq id-select-previous 'sexp-up) | |
| 825 ;; Keep going up and backward in sexps. This means that id-select-sexp-up | |
| 826 ;; can only be called after id-select-sexp or after itself. | |
| 827 (setq pos (or (car id-select-region) pos)) | |
| 828 (save-excursion | |
| 829 (goto-char pos) | |
| 830 (condition-case () | |
| 831 (id-select-set-region (progn (backward-up-list 1) (point)) | |
| 832 (progn (forward-list 1) (point))) | |
| 833 (error nil)))) | |
| 834 | |
| 835 (defun id-select-preprocessor-def (pos) | |
| 836 "Return (start . end) of a preprocessor #definition starting at POS, if any. | |
| 837 The major mode for each language that uses # preprocessor notation must be | |
| 838 included in the list, id-select-brace-modes." | |
| 839 ;; Only applies in brace modes (strictly, this should apply in a subset | |
| 840 ;; of brace modes, but doing it this way permits for configurability. In | |
| 841 ;; other modes, one doesn't have to use the function on a # symbol. | |
| 842 (if (not (memq major-mode id-select-brace-modes)) | |
| 843 nil | |
| 844 (setq id-select-previous 'preprocessor-def) | |
| 845 (save-excursion | |
| 846 (goto-char pos) | |
| 847 (if (and (= (following-char) ?#) | |
| 848 ;; Must be at the first non-whitespace character in the line. | |
| 849 (= (point) (save-excursion (back-to-indentation) (point)))) | |
| 850 (progn | |
| 851 ;; Skip past continuation lines that end with a backslash. | |
| 852 (while (and (looking-at ".*\\\\\\s-*$") | |
| 853 (zerop (forward-line 1)))) | |
| 854 (forward-line 1) | |
| 855 ;; Include one trailing blank line, if any. | |
| 856 (if (looking-at "^[ \t\n\r]*$") (forward-line 1)) | |
| 857 (id-select-set-region pos (point))))))) | |
| 858 | |
| 859 ;; Allow punctuation marks not followed by white-space to include | |
| 860 ;; the previous and subsequent sexpression. Useful in contexts such as | |
| 861 ;; 'foo.bar'. | |
| 862 (defun id-select-punctuation (pos) | |
| 863 "Return (start . end) region including sexpressions before and after POS, when at a punctuation character." | |
| 864 (or (id-select-comment pos) | |
| 865 (id-select-preprocessor-def pos) | |
| 866 (id-select-brace-def-or-declaration pos) ;; Might be on a C++ ;; destructor ~. | |
| 867 (save-excursion | |
| 868 (setq id-select-previous 'punctuation) | |
| 869 (goto-char (min (1+ pos) (point-max))) | |
| 870 (if (= (char-syntax (if (eobp) (preceding-char) (char-after (point)))) | |
| 871 ?\ ) | |
| 872 (id-select-set-region pos (1+ pos)) | |
| 873 (goto-char pos) | |
| 874 (id-select-set-region | |
| 875 (save-excursion (backward-sexp) (point)) | |
| 876 (progn (forward-sexp) (point))))))) | |
| 877 | |
| 878 (defun id-select-comment (pos) | |
| 879 "Return rest of line from POS to newline." | |
| 880 (setq id-select-previous 'comment) | |
| 881 (save-excursion | |
| 882 (goto-char pos) | |
| 883 (let ((start-regexp (if (stringp comment-start) | |
| 884 (regexp-quote comment-start))) | |
| 885 (end-regexp (if (stringp comment-end) | |
| 886 (regexp-quote comment-end))) | |
| 887 bolp) | |
| 888 (cond | |
| 889 ;; Beginning of a comment | |
| 890 ((and (stringp comment-start) | |
| 891 (or (looking-at start-regexp) | |
| 892 (and (skip-chars-backward comment-start) | |
| 893 (looking-at start-regexp)))) | |
| 894 (skip-chars-backward " \t") | |
| 895 (setq bolp (bolp) | |
| 896 pos (point)) | |
| 897 (if (equal comment-end "") | |
| 898 (progn (end-of-line) | |
| 899 (id-select-set-region pos (point))) | |
| 900 (if (stringp comment-end) | |
| 901 ;; Skip over nested comments. | |
| 902 (let ((count 0) | |
| 903 (regexp (concat start-regexp "\\|" end-regexp))) | |
| 904 (catch 'done | |
| 905 (while (re-search-forward regexp nil t) | |
| 906 (if (string-equal | |
| 907 (buffer-substring (match-beginning 0) (match-end 0)) | |
| 908 comment-start) | |
| 909 (setq count (1+ count)) | |
| 910 ;; End comment | |
| 911 (setq count (1- count)) | |
| 912 (if (= count 0) | |
| 913 (progn | |
| 914 (if (looking-at "[ \t]*[\n\r]") | |
| 915 ;; Don't include final newline unless the | |
| 916 ;; comment is first thing on its line. | |
| 917 (goto-char (if bolp (match-end 0) | |
| 918 (1- (match-end 0))))) | |
| 919 (throw 'done (id-select-set-region | |
| 920 pos (point)))))))))))) | |
| 921 ;; End of a comment | |
| 922 ((and (stringp comment-end) | |
| 923 (not (string-equal comment-end "")) | |
| 924 (or (looking-at end-regexp) | |
| 925 (and (skip-chars-backward comment-end) | |
| 926 (looking-at end-regexp)))) | |
| 927 (goto-char (match-end 0)) | |
| 928 (if (looking-at "[ \t]*[\n\r]") | |
| 929 (goto-char (match-end 0))) | |
| 930 (setq pos (point)) | |
| 931 (skip-chars-forward " \t") | |
| 932 ;; Skip over nested comments. | |
| 933 (let ((count 0) | |
| 934 (regexp (concat start-regexp "\\|" end-regexp))) | |
| 935 (catch 'done | |
| 936 (while (re-search-backward regexp nil t) | |
| 937 (if (string-equal | |
| 938 (buffer-substring (match-beginning 0) (match-end 0)) | |
| 939 comment-end) | |
| 940 (setq count (1+ count)) | |
| 941 ;; Begin comment | |
| 942 (setq count (1- count)) | |
| 943 (if (= count 0) | |
| 944 (progn | |
| 945 (skip-chars-backward " \t") | |
| 946 ;; Don't include final newline unless the comment is | |
| 947 ;; first thing on its line. | |
| 948 (if (bolp) nil (setq pos (1- pos))) | |
| 949 (throw 'done (id-select-set-region | |
| 950 (point) pos))))))))))))) | |
| 951 | |
| 952 ;;; | |
| 953 ;;; Textual selections | |
| 954 ;;; | |
| 955 | |
| 956 (defun id-select-word (pos) | |
| 957 "Return (start . end) of word at POS." | |
| 958 (or (id-select-brace-def-or-declaration pos) | |
| 959 (id-select-indent-def pos) | |
| 960 (progn (setq id-select-previous 'word) | |
| 961 (save-excursion | |
| 962 (goto-char pos) | |
| 963 (forward-word 1) | |
| 964 (let ((end (point))) | |
| 965 (forward-word -1) | |
| 966 (id-select-set-region (point) end)))))) | |
| 967 | |
| 968 (defun id-select-string (pos) | |
| 969 "Returns (start . end) of string at POS or nil. Pos include delimiters. | |
| 970 Delimiters may be single, double or open and close quotes." | |
| 971 (setq id-select-previous 'string) | |
| 972 (save-excursion | |
| 973 (goto-char pos) | |
| 974 (if (and (memq major-mode id-select-markup-modes) | |
| 975 (/= (following-char) ?\") | |
| 976 (save-excursion | |
| 977 (and (re-search-backward "[<>]" nil t) | |
| 978 (= (following-char) ?>)))) | |
| 979 (progn (setq id-select-previous 'text) | |
| 980 (search-backward ">" nil t) | |
| 981 (id-select-set-region | |
| 982 (1+ (point)) | |
| 983 (progn (if (search-forward "<" nil 'end) | |
| 984 (1- (point)) | |
| 985 (point))))) | |
| 986 (or (id-select-string-p) (id-select-string-p "'" "'") | |
| 987 (id-select-string-p "`" "'"))))) | |
| 988 | |
| 989 (defun id-select-sentence (pos) | |
| 990 "Return (start . end) of the sentence at POS." | |
| 991 (setq id-select-previous 'sentence) | |
| 992 (save-excursion | |
| 993 (goto-char pos) | |
| 994 (condition-case () | |
| 995 (id-select-set-region (progn (backward-sentence) (point)) | |
| 996 (progn (forward-sentence) (point))) | |
| 997 (error nil)))) | |
| 998 | |
| 999 (defun id-select-whitespace (pos) | |
| 1000 "Return (start . end) of all but one char of whitespace POS, unless | |
| 1001 there is only one character of whitespace or this is leading whitespace on | |
| 1002 the line. Then return all of it." | |
| 1003 (setq id-select-previous 'whitespace) | |
| 1004 (save-excursion | |
| 1005 (goto-char pos) | |
| 1006 (if (= (following-char) ?\^L) | |
| 1007 (id-select-page pos) | |
| 1008 (let ((end (progn (skip-chars-forward " \t") (point))) | |
| 1009 (start (progn (skip-chars-backward " \t") (point)))) | |
| 1010 (if (looking-at "[ \t]") | |
| 1011 (if (or (bolp) (= (1+ start) end)) | |
| 1012 (id-select-set-region start end) | |
| 1013 (id-select-set-region (1+ start) end))))))) | |
| 1014 | |
| 1015 (defun id-select-markup-pair (pos) | |
| 1016 "Return (start . end) of region between the opening and closing of an HTML or SGML tag pair, one of which is at POS. | |
| 1017 The major mode for each language that uses such tags must be included in the | |
| 1018 list, id-select-markup-modes." | |
| 1019 (if (not (memq major-mode id-select-markup-modes)) | |
| 1020 nil | |
| 1021 (setq id-select-previous 'markup-pair) | |
| 1022 (let ((pos-with-space) | |
| 1023 ;; Assume case of tag names is irrelevant. | |
| 1024 (case-fold-search t) | |
| 1025 (result) | |
| 1026 start-regexp | |
| 1027 end-regexp | |
| 1028 bolp | |
| 1029 opoint) | |
| 1030 (save-excursion | |
| 1031 (catch 'done | |
| 1032 (goto-char pos) | |
| 1033 (cond | |
| 1034 ;; Beginning of a tag pair | |
| 1035 ((looking-at "<[^/][^<> \t\n\r]*") | |
| 1036 (setq start-regexp (regexp-quote (buffer-substring | |
| 1037 (match-beginning 0) (match-end 0))) | |
| 1038 end-regexp (concat "</" (substring start-regexp 1))) | |
| 1039 (setq pos (point)) | |
| 1040 (skip-chars-backward " \t") | |
| 1041 (setq bolp (bolp) | |
| 1042 pos-with-space (point)) | |
| 1043 ;; Skip over nested tags. | |
| 1044 (let ((count 0) | |
| 1045 (regexp (concat start-regexp "\\|" end-regexp))) | |
| 1046 (while (and (>= count 0) | |
| 1047 (re-search-forward regexp nil t)) | |
| 1048 (if (/= (char-after (1+ (match-beginning 0))) ?/) | |
| 1049 ;; Start tag | |
| 1050 (setq count (1+ count)) | |
| 1051 ;; Move past end tag terminator | |
| 1052 (setq opoint (point)) | |
| 1053 (if (or (not (re-search-forward "[<>]" nil t)) | |
| 1054 (= (preceding-char) ?<)) | |
| 1055 (progn (setq result opoint) | |
| 1056 (throw 'done nil))) | |
| 1057 (setq count (1- count)) | |
| 1058 (if (= count 0) | |
| 1059 (progn | |
| 1060 (if (looking-at "[ \t]*[\n\r]") | |
| 1061 ;; Don't include final newline unless the | |
| 1062 ;; start tag was the first thing on its line. | |
| 1063 (if bolp | |
| 1064 (progn (goto-char (match-end 0)) | |
| 1065 ;; Include leading space since the | |
| 1066 ;; start and end tags begin and end | |
| 1067 ;; lines. | |
| 1068 (setq pos pos-with-space)) | |
| 1069 (goto-char (1- (match-end 0))))) | |
| 1070 (setq result (id-select-set-region pos (point))) | |
| 1071 (throw 'done nil))))))) | |
| 1072 ;; | |
| 1073 ;; End of a tag pair | |
| 1074 ((or (looking-at "</[^> \t\n\r]+") | |
| 1075 (and (skip-chars-backward "<") | |
| 1076 (looking-at "</[^> \t\n\r]+"))) | |
| 1077 (goto-char (match-end 0)) | |
| 1078 (setq end-regexp (regexp-quote (buffer-substring | |
| 1079 (match-beginning 0) (match-end 0))) | |
| 1080 start-regexp (concat "<" (substring end-regexp 2))) | |
| 1081 (setq opoint (point)) | |
| 1082 (if (or (not (re-search-forward "[<>]" nil t)) | |
| 1083 (= (preceding-char) ?<)) | |
| 1084 (progn (setq result opoint) | |
| 1085 (throw 'done nil))) | |
| 1086 (setq pos (point)) | |
| 1087 (if (looking-at "[ \t]*[\n\r]") | |
| 1088 (setq pos-with-space (match-end 0))) | |
| 1089 ;; Skip over nested tags. | |
| 1090 (let ((count 0) | |
| 1091 (regexp (concat start-regexp "\\|" end-regexp))) | |
| 1092 (while (and (>= count 0) | |
| 1093 (re-search-backward regexp nil t)) | |
| 1094 (if (= (char-after (1+ (point))) ?/) | |
| 1095 ;; End tag | |
| 1096 (setq count (1+ count)) | |
| 1097 ;; Start tag | |
| 1098 (setq count (1- count)) | |
| 1099 (if (= count 0) | |
| 1100 (progn | |
| 1101 (if pos-with-space | |
| 1102 ;; Newline found after original end tag. | |
| 1103 (progn | |
| 1104 (skip-chars-backward " \t") | |
| 1105 (if (bolp) | |
| 1106 ;; Don't include final newline unless the | |
| 1107 ;; start tag is the first thing on its line. | |
| 1108 (setq pos pos-with-space) | |
| 1109 (setq pos (1- pos-with-space)) | |
| 1110 ;; Don't include non-leading space. | |
| 1111 (skip-chars-forward " \t")))) | |
| 1112 (setq result (id-select-set-region (point) pos)) | |
| 1113 (throw 'done nil)))))))))) | |
| 1114 (if (integerp result) | |
| 1115 (progn (goto-char result) | |
| 1116 (error "(id-select-markup-pair): Add a terminator character for this end tag")) | |
| 1117 result)))) | |
| 1118 | |
| 1119 ;;; | |
| 1120 ;;; Document selections | |
| 1121 ;;; | |
| 1122 | |
| 1123 (defun id-select-line (pos) | |
| 1124 "Return (start . end) of the whole line POS is in, with newline unless at end of buffer." | |
| 1125 (setq id-select-previous 'line) | |
| 1126 (save-excursion | |
| 1127 (goto-char pos) | |
| 1128 (let* ((start (progn (beginning-of-line 1) (point))) | |
| 1129 (end (progn (forward-line 1) (point)))) | |
| 1130 (id-select-set-region start end)))) | |
| 1131 | |
| 1132 (defun id-select-paragraph (pos) | |
| 1133 "Return (start . end) of the paragraph at POS." | |
| 1134 (setq id-select-previous 'paragraph) | |
| 1135 (save-excursion | |
| 1136 (goto-char pos) | |
| 1137 (id-select-set-region (progn (backward-paragraph) (point)) | |
| 1138 (progn (forward-paragraph) (point))))) | |
| 1139 | |
| 1140 (defun id-select-page (pos) | |
| 1141 "Return (start . end) of the page preceding POS." | |
| 1142 (setq id-select-previous 'page) | |
| 1143 (save-excursion | |
| 1144 (goto-char pos) | |
| 1145 (id-select-set-region (progn (backward-page) (point)) | |
| 1146 (progn (forward-page) (point))))) | |
| 1147 | |
| 1148 (defun id-select-buffer (pos) | |
| 1149 "Return (start . end) of the buffer at POS." | |
| 1150 (setq id-select-previous 'buffer) | |
| 1151 (id-select-set-region (point-min) (point-max))) | |
| 1152 | |
| 1153 ;;; ************************************************************************ | |
| 1154 ;;; Private variables | |
| 1155 ;;; ************************************************************************ | |
| 1156 | |
| 1157 (defvar id-select-bigger-alist | |
| 1158 '((char nil) | |
| 1159 (whitespace id-select-whitespace) | |
| 1160 (word id-select-word) | |
| 1161 (symbol id-select-symbol) | |
| 1162 (punctuation nil) | |
| 1163 (string id-select-string) | |
| 1164 (text nil) | |
| 1165 (comment id-select-comment) | |
| 1166 (markup-pair nil) | |
| 1167 (preprocessor-def nil) | |
| 1168 (sexp id-select-sexp) | |
| 1169 (sexp-start nil) | |
| 1170 (sexp-end nil) | |
| 1171 (sexp-up id-select-sexp-up) | |
| 1172 (line id-select-line) | |
| 1173 (sentence id-select-sentence) | |
| 1174 (brace-def-or-declaration id-select-brace-def-or-declaration) | |
| 1175 (indent-def id-select-indent-def) | |
| 1176 (paragraph id-select-paragraph) | |
| 1177 (page id-select-page) | |
| 1178 (buffer id-select-buffer) | |
| 1179 ) | |
| 1180 "List of (REGION-TYPE-SYMBOL REGION-SELECTION-FUNCTION) pairs. | |
| 1181 Used to go from one thing to a bigger thing. See id-select-bigger-thing. | |
| 1182 Nil value for REGION-SELECTION-FUNCTION means that region type is skipped | |
| 1183 over when trying to grow the region and is only used when a selection is made | |
| 1184 with point on a character that triggers that type of selection. Ordering of | |
| 1185 entries is largely irrelevant to any code that uses this list.") | |
| 1186 | |
| 1187 | |
| 1188 (defvar id-select-prior-buffer nil) | |
| 1189 (defvar id-select-prior-point nil) | |
| 1190 | |
| 1191 (defvar id-select-previous 'char | |
| 1192 "Most recent type of selection. Must be set by all id-select functions.") | |
| 1193 | |
| 1194 (defvar id-select-region (cons 'nil 'nil) | |
| 1195 "Cons cell that contains a region (<beginning> . <end>). | |
| 1196 The function `id-select-set-region' updates and returns it.") | |
| 1197 | |
| 1198 (defvar id-select-old-region (cons 'nil 'nil) | |
| 1199 "Cons cell that contains a region (<beginning> . <end>).") | |
| 1200 | |
| 1201 (defvar id-select-syntax-alist | |
| 1202 '((?w id-select-word) | |
| 1203 (?_ id-select-symbol) | |
| 1204 (?\" id-select-string) | |
| 1205 (?\( id-select-sexp-start) | |
| 1206 (?\$ id-select-sexp-start) | |
| 1207 (?' id-select-sexp-start) | |
| 1208 (?\) id-select-sexp-end) | |
| 1209 (? id-select-whitespace) | |
| 1210 (?< id-select-comment) | |
| 1211 (?. id-select-punctuation)) | |
| 1212 "*List of pairs of the form (SYNTAX-CHAR FUNCTION) used by the function `id-select-syntactical-region'. | |
| 1213 Each FUNCTION takes a single position argument and returns a region | |
| 1214 (start . end) delineating the boundaries of the thing at that position. | |
| 1215 Ordering of entries is largely irrelevant to any code that uses this list.") | |
| 1216 | |
| 1217 | |
| 1218 (provide 'id-select) |