Mercurial > hg > xemacs-beta

comparison lisp/utils/thing.el @ 0:376386a54a3c r19-14

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-14
author cvs
date Mon, 13 Aug 2007 08:45:50 +0200
parents
children bcdc7deadc19
comparison
equal deleted inserted replaced
-1:000000000000 0:376386a54a3c
1 ;;; thing.el --- find language-specific contiguous pieces of text
2
3 ;; Keywords: extensions, languages
4
5 ;;; Authors: David Hughes <djh@cis.prime.com>
6 ;;; adapted from Martin Boyer's thing.el for imouse
7 ;;; Martin Boyer, IREQ <mboyer@ireq-robot.hydro.qc.ca>
8 ;;; adapted from Heinz Schmidt's thing.el for sky-mouse
9 ;;; Heinz Schmidt, ICSI (hws@ICSI.Berkeley.EDU)
10 ;;; adapted from Dan L. Pierson's epoch-thing.el
11 ;;; Dan L. Pierson <pierson@encore.com>, 2/5/90
12 ;;; adapted from Joshua Guttman's Thing.el
13 ;;; Joshua Guttman, MITRE (guttman@mitre.org)
14 ;;; adapted from sun-fns.el by Joshua Guttman, MITRE.
15 ;;;
16 ;;; Copyright (C) International Computer Science Institute, 1991
17 ;;;
18
19 ;; This file is part of XEmacs.
20
21 ;; XEmacs is free software; you can redistribute it and/or modify
22 ;; it under the terms of the GNU General Public License as published by
23 ;; the Free Software Foundation; either version 2, or (at your option)
24 ;; any later version.
25
26 ;; XEmacs is distributed in the hope that it will be useful,
27 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
28 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
29 ;; GNU General Public License for more details.
30
31 ;; You should have received a copy of the GNU General Public License
32 ;; along with XEmacs; see the file COPYING. If not, write to
33 ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
34
35 ;;; Synched up with: Not in FSF.
36 ;;; #### FSF has thingatpt.el, which does the same thing. Should merge
37 ;;; or toss this.
38
39 ;;;*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
40 ;;;* FUNCTION: Things are language objects contiguous pieces of text
41 ;;;* whose boundaries can be defined by syntax or context.
42 ;;;*
43 ;;;* RELATED PACKAGES: various packages built on this.
44 ;;;*
45 ;;;* HISTORY:
46 ;;;* Last edited: David Hughes 21st December 1992
47 ;;;* jul 21 21:00 1993 (tlp00): added a kludgy thing-filename
48 ;;;* Feb 22 21:00 1993 (tlp00): better merge with lucid and imouse
49 ;;;* Dec 21 11:11 1992 (djh): added thing-report-char-p
50 ;;;* Nov 23 18:00 1992 (djh): merged in Guido Bosch's ideas
51 ;;;* Sep 10 15:35 1992 (djh): adapted for Lucid emacs19-mouse.el
52 ;;;* Nov 28 17:40 1991 (mb): Cleaned up, and added thing-bigger-alist.
53 ;;;* May 24 00:33 1991 (hws): overworked and added syntax.
54 ;;;* Created: 2/5/90 Dan L. Pierson
55 ;;;*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
56
57 (provide 'thing)
58
59 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
60 ;;;;;;;;;;;; Customization and Entry Point ;;;;;;;;;;;;;;;;;;;;;;;;;
61 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
62
63 (defvar thing-boundary-alist
64 '((?w thing-word)
65 (?_ thing-symbol)
66 (?\( thing-sexp-start)
67 (?\$ thing-sexp-start)
68 (?' thing-sexp-start)
69 (?\" thing-sexp-start)
70 (?\) thing-sexp-end)
71 (? thing-whitespace)
72 (?< thing-comment)
73 (?. thing-next-sexp))
74 "*List of pairs of the form (SYNTAX-CHAR FUNCTION) used by
75 the function `thing-boundaries'.")
76
77 (defvar thing-report-char-p t
78 "*Non nil means return single char boundaries if all else fails")
79
80 (defvar thing-report-whitespace t
81 "*Non nil means that whitespaces are considered as things, otherwise not.")
82
83 (defvar *last-thing*
84 "The last thing found by thing-boundaries. Used for chaining commands.")
85
86 ;; The variable and function `thing-region' are to avoid the continual
87 ;; construction of cons cells as result af the thing scanner functions.
88 ;; This avoids unnecessary garbage collection. Guido Bosch <bosch@loria.fr>
89
90 (defvar thing-region (cons 'nil 'nil)
91 "Cons cell that contains a region (<beginning> . <end>)
92 The function `thing-region' updates and returns it.")
93
94 (defun thing-region (beginning end)
95 "Make BEGINNING the car and END the cdr of the cons cell in the
96 variable `thing-region'. Return the updated cons cell"
97 (cond ((/= beginning end)
98 (setcar thing-region beginning)
99 (setcdr thing-region end)
100 thing-region)))
101
102 (defvar thing-bigger-alist
103 '((word-symbol thing-symbol)
104 (symbol thing-sexp)
105 (word-sexp thing-sexp)
106 (sexp thing-up-sexp)
107 (sexp-up thing-up-sexp)
108 (line thing-paragraph)
109 (paragraph thing-page)
110 (char thing-word)
111 (word-sentence thing-sentence)
112 (sentence thing-paragraph))
113 "List of pairs to go from one thing to a bigger thing.
114 See mouse-select-bigger-thing and mouse-delete-bigger-thing.")
115
116 (defvar thing-word-next nil
117 "*The next bigger thing after a word. A symbol.
118 Supported values are: word-symbol, word-sexp, and word-sentence.
119 Default value is word-sentence.
120 Automatically becomes local when set in any fashion.")
121 (make-variable-buffer-local 'thing-word-next)
122
123 (defun thing-boundaries (here)
124 "Return start and end of text object at HERE using syntax table and
125 thing-boundary-alist. Thing-boundary-alist is a list of pairs of the
126 form (SYNTAX-CHAR FUNCTION) where FUNCTION takes a single position
127 argument and returns a cons of places (start end) representing
128 boundaries of the thing at that position.
129
130 Typically:
131 Left or right Paren syntax indicates an s-expression.
132 The end of a line marks the line including a trailing newline.
133 Word syntax indicates current word.
134 Symbol syntax indicates symbol.
135 If it doesn't recognize one of these it selects just the character HERE.
136
137 If an error occurs during syntax scanning, the function just prints a
138 message and returns `nil'."
139 (interactive "d")
140 (setq *last-thing* nil)
141 (if (save-excursion (goto-char here) (eolp))
142 (thing-get-line here)
143 (let* ((syntax (char-syntax (char-after here)))
144 (pair (assq syntax thing-boundary-alist)))
145 (cond ((and pair
146 (or thing-report-whitespace
147 (not (eq (car (cdr pair)) 'thing-whitespace))))
148 (funcall (car (cdr pair)) here))
149 (thing-report-char-p
150 (setq *last-thing* 'char)
151 (thing-region here (1+ here)))
152 (t
153 nil)))))
154
155
156
157
158 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
159 ;;;;;;;;;;;;;;;;; Code Delimiters ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
160 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
161
162 (defun thing-symbol (here)
163 "Return start and end of symbol at HERE."
164 (cond ((memq (char-syntax (char-after here)) '(?_ ?w))
165 (setq *last-thing* 'symbol)
166 (let ((end (scan-sexps here 1)))
167 (thing-region (min here (scan-sexps end -1)) end)))))
168
169 (defun thing-filename (here)
170 "Return start and end of filename at HERE."
171 (cond ((memq (char-syntax (char-after here)) '(?w ?_ ?.))
172 (let (start end)
173 (save-excursion
174 (goto-char here)
175 (and (re-search-forward "\\s \\|:\\s\"\\|$" nil t)
176 (goto-char (setq end (match-beginning 0)))
177 (or
178 (and
179 (re-search-backward "[^_a-zA-Z0-9---#$.~/@]+" nil t)
180 (setq start (+ (match-beginning 0)
181 (if (bolp)
182 0
183 1))))
184 (setq start (point-min)))
185 (thing-region (min start here) (max here end))))))))
186 ;~/
187 (defun thing-sexp-start (here)
188 "Return start and end of sexp starting HERE."
189 (setq *last-thing* 'sexp-start)
190 (thing-region here (scan-sexps here 1)))
191
192 (defun thing-sexp-end (here)
193 "Return start and end of sexp ending HERE."
194 (setq *last-thing* 'sexp-end)
195 (thing-region (scan-sexps (1+ here) -1) (1+ here)))
196
197 (defun thing-sexp (here)
198 "Return start and end of the sexp at HERE."
199 (setq *last-thing* 'sexp)
200 (save-excursion
201 (goto-char here)
202 (thing-region (progn (backward-up-list 1) (point))
203 (progn (forward-list 1) (point)))))
204
205 (defun thing-up-sexp (here)
206 "Return start and end of the sexp enclosing the selected area."
207 (setq *last-thing* 'sexp-up)
208 ;; Keep going up and backward in sexps. This means that thing-up-sexp
209 ;; can only be called after thing-sexp or after itself.
210 (save-excursion
211 (goto-char here)
212 (thing-region (progn
213 (condition-case ()
214 (backward-up-list 1) (error nil))
215 (point))
216 (progn
217 (condition-case ()
218 (forward-list 1) (error nil))
219 (point)))))
220
221 ;;; Allow punctuation marks not followed by white-space to include
222 ;;; the subsequent sexp. Useful in foo.bar(x).baz and such.
223 (defun thing-next-sexp (here)
224 "Return from HERE to the end of the sexp at HERE,
225 if the character at HERE is part of a sexp."
226 (setq *last-thing* 'sexp-next)
227 (if (= (char-syntax (char-after (1+ here))) ? )
228 (thing-region here (1+ here))
229 (thing-region here
230 (save-excursion (goto-char here) (forward-sexp) (point)))))
231
232 ;;; Allow click to comment-char to extend to end of line
233 (defun thing-comment (here)
234 "Return rest of line from HERE to newline."
235 (setq *last-thing* 'comment)
236 (save-excursion (goto-char here)
237 (while (= (char-syntax (preceding-char)) ?<)
238 (forward-char -1))
239 (thing-region (point) (progn (end-of-line) (point)))))
240
241
242 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
243 ;;;;;;;;;;;;;;;;; Text Delimiters ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
244 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
245
246 (defun thing-word (here)
247 "Return start and end of word at HERE."
248 (setq *last-thing*
249 (if thing-word-next
250 thing-word-next
251 (setq thing-word-next
252 (cond
253 ((memq major-mode '(emacs-lisp-mode c-mode c++-mode
254 fortran-mode latex-mode lisp-mode
255 perl-mode tex-mode))
256 'word-symbol)
257 (t 'word-sentence)))))
258 (save-excursion
259 (goto-char here)
260 (forward-word 1)
261 (let ((end (point)))
262 (forward-word -1)
263 (thing-region (point) end))))
264
265 (defun thing-sentence (here)
266 "Return start and end of the sentence at HERE."
267 (setq *last-thing* 'sentence)
268 (save-excursion
269 (goto-char here)
270 (thing-region (progn (backward-sentence) (point))
271 (progn (forward-sentence) (point)))))
272
273 (defun thing-whitespace (here)
274 "Return start to end of all of whitespace HERE."
275 (setq *last-thing* 'whitespace)
276 (save-excursion
277 (goto-char here)
278 (let ((start (progn (skip-chars-backward " \t") (1+ (point))))
279 (end (progn (skip-chars-forward " \t") (point))))
280 (if (= start end)
281 (thing-region (1- start) end)
282 (thing-region start end)))))
283
284
285 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
286 ;;;;;;;;;;;;;;; Physical Delimiters ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
287 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
288
289 (defun thing-get-line (here)
290 "Return whole of line HERE is in, with newline unless at eob."
291 (setq *last-thing* 'line)
292 (save-excursion
293 (goto-char here)
294 (let* ((start (progn (beginning-of-line 1) (point))))
295 (thing-region start (point)))))
296
297 (defun thing-paragraph (here)
298 "Return start and end of the paragraph at HERE."
299 (setq *last-thing* 'paragraph)
300 (save-excursion
301 (goto-char here)
302 (thing-region (progn (backward-paragraph) (point))
303 (progn (forward-paragraph) (point)))))
304
305 (defun thing-page (here)
306 "Return start and end of the page at HERE."
307 (setq *last-thing* 'page)
308 (save-excursion
309 (goto-char here)
310 (thing-region (progn (backward-page) (point))
311 (progn (forward-page) (point)))))
312
313
314 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
315 ;;;;;;;;;;;;;;;; Support functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
316 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
317
318 (defun kill-thing-at-point (here)
319 "Kill text object using syntax table.
320 See thing-boundaries for definition of text objects"
321 (interactive "d")
322 (let ((bounds (thing-boundaries here)))
323 (kill-region (car bounds) (cdr bounds))))
324
325 (defun copy-thing-at-point (here)
326 "Copy text object using syntax table.
327 See thing-boundaries for definition of text objects"
328 (interactive "d")
329 (let ((bounds (thing-boundaries here)))
330 (copy-region-as-kill (car bounds) (cdr bounds))))