Commit | Line | Data |
---|---|---|
55535639 | 1 | ;;; thingatpt.el --- get the `thing' at point |
1a2b6c52 | 2 | |
ba318903 | 3 | ;; Copyright (C) 1991-1998, 2000-2014 Free Software Foundation, Inc. |
1a2b6c52 RS |
4 | |
5 | ;; Author: Mike Williams <mikew@gopher.dosli.govt.nz> | |
6254fc9f | 6 | ;; Maintainer: FSF |
b7f66977 | 7 | ;; Keywords: extensions, matching, mouse |
1a2b6c52 | 8 | ;; Created: Thu Mar 28 13:48:23 1991 |
1a2b6c52 RS |
9 | |
10 | ;; This file is part of GNU Emacs. | |
11 | ||
eb3fa2cf | 12 | ;; GNU Emacs is free software: you can redistribute it and/or modify |
1a2b6c52 | 13 | ;; it under the terms of the GNU General Public License as published by |
eb3fa2cf GM |
14 | ;; the Free Software Foundation, either version 3 of the License, or |
15 | ;; (at your option) any later version. | |
1a2b6c52 RS |
16 | |
17 | ;; GNU Emacs is distributed in the hope that it will be useful, | |
18 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
19 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
20 | ;; GNU General Public License for more details. | |
21 | ||
eb3fa2cf GM |
22 | ;; You should have received a copy of the GNU General Public License |
23 | ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. | |
24 | ||
69f9ba7e | 25 | ;;; Commentary: |
b578f267 | 26 | |
c851323f RS |
27 | ;; This file provides routines for getting the "thing" at the location of |
28 | ;; point, whatever that "thing" happens to be. The "thing" is defined by | |
7a8f27db | 29 | ;; its beginning and end positions in the buffer. |
1a2b6c52 RS |
30 | ;; |
31 | ;; The function bounds-of-thing-at-point finds the beginning and end | |
c851323f | 32 | ;; positions by moving first forward to the end of the "thing", and then |
1a2b6c52 | 33 | ;; backwards to the beginning. By default, it uses the corresponding |
c851323f | 34 | ;; forward-"thing" operator (eg. forward-word, forward-line). |
1a2b6c52 RS |
35 | ;; |
36 | ;; Special cases are allowed for using properties associated with the named | |
f1180544 | 37 | ;; "thing": |
1a2b6c52 | 38 | ;; |
c851323f | 39 | ;; forward-op Function to call to skip forward over a "thing" (or |
1a2b6c52 | 40 | ;; with a negative argument, backward). |
f1180544 | 41 | ;; |
c851323f RS |
42 | ;; beginning-op Function to call to skip to the beginning of a "thing". |
43 | ;; end-op Function to call to skip to the end of a "thing". | |
1a2b6c52 RS |
44 | ;; |
45 | ;; Reliance on existing operators means that many `things' can be accessed | |
46 | ;; without further code: eg. | |
47 | ;; (thing-at-point 'line) | |
48 | ;; (thing-at-point 'page) | |
49 | ||
b578f267 | 50 | ;;; Code: |
1a2b6c52 RS |
51 | |
52 | (provide 'thingatpt) | |
53 | ||
b578f267 | 54 | ;; Basic movement |
1a2b6c52 RS |
55 | |
56 | ;;;###autoload | |
c851323f | 57 | (defun forward-thing (thing &optional n) |
f5bd0689 CY |
58 | "Move forward to the end of the Nth next THING. |
59 | THING should be a symbol specifying a type of syntactic entity. | |
60 | Possibilities include `symbol', `list', `sexp', `defun', | |
61 | `filename', `url', `email', `word', `sentence', `whitespace', | |
62 | `line', and `page'." | |
c851323f RS |
63 | (let ((forward-op (or (get thing 'forward-op) |
64 | (intern-soft (format "forward-%s" thing))))) | |
6254fc9f | 65 | (if (functionp forward-op) |
c851323f RS |
66 | (funcall forward-op (or n 1)) |
67 | (error "Can't determine how to move over a %s" thing)))) | |
1a2b6c52 | 68 | |
b578f267 | 69 | ;; General routines |
1a2b6c52 RS |
70 | |
71 | ;;;###autoload | |
c851323f RS |
72 | (defun bounds-of-thing-at-point (thing) |
73 | "Determine the start and end buffer locations for the THING at point. | |
f5bd0689 CY |
74 | THING should be a symbol specifying a type of syntactic entity. |
75 | Possibilities include `symbol', `list', `sexp', `defun', | |
76 | `filename', `url', `email', `word', `sentence', `whitespace', | |
77 | `line', and `page'. | |
c851323f | 78 | |
f5bd0689 CY |
79 | See the file `thingatpt.el' for documentation on how to define a |
80 | valid THING. | |
c851323f | 81 | |
f5bd0689 CY |
82 | Return a cons cell (START . END) giving the start and end |
83 | positions of the thing found." | |
d9cc804b RS |
84 | (if (get thing 'bounds-of-thing-at-point) |
85 | (funcall (get thing 'bounds-of-thing-at-point)) | |
86 | (let ((orig (point))) | |
45fdb482 JB |
87 | (ignore-errors |
88 | (save-excursion | |
89 | ;; Try moving forward, then back. | |
90 | (funcall ;; First move to end. | |
91 | (or (get thing 'end-op) | |
92 | (lambda () (forward-thing thing 1)))) | |
93 | (funcall ;; Then move to beg. | |
94 | (or (get thing 'beginning-op) | |
95 | (lambda () (forward-thing thing -1)))) | |
96 | (let ((beg (point))) | |
97 | (if (<= beg orig) | |
98 | ;; If that brings us all the way back to ORIG, | |
99 | ;; it worked. But END may not be the real end. | |
100 | ;; So find the real end that corresponds to BEG. | |
101 | ;; FIXME: in which cases can `real-end' differ from `end'? | |
102 | (let ((real-end | |
f1180544 JB |
103 | (progn |
104 | (funcall | |
45fdb482 JB |
105 | (or (get thing 'end-op) |
106 | (lambda () (forward-thing thing 1)))) | |
d9cc804b | 107 | (point)))) |
45fdb482 JB |
108 | (when (and (<= orig real-end) (< beg real-end)) |
109 | (cons beg real-end))) | |
110 | (goto-char orig) | |
111 | ;; Try a second time, moving backward first and then forward, | |
112 | ;; so that we can find a thing that ends at ORIG. | |
113 | (funcall ;; First, move to beg. | |
114 | (or (get thing 'beginning-op) | |
115 | (lambda () (forward-thing thing -1)))) | |
116 | (funcall ;; Then move to end. | |
117 | (or (get thing 'end-op) | |
118 | (lambda () (forward-thing thing 1)))) | |
119 | (let ((end (point)) | |
120 | (real-beg | |
121 | (progn | |
122 | (funcall | |
123 | (or (get thing 'beginning-op) | |
124 | (lambda () (forward-thing thing -1)))) | |
125 | (point)))) | |
126 | (if (and (<= real-beg orig) (<= orig end) (< real-beg end)) | |
127 | (cons real-beg end)))))))))) | |
1a2b6c52 RS |
128 | |
129 | ;;;###autoload | |
72d3cfca | 130 | (defun thing-at-point (thing &optional no-properties) |
c851323f | 131 | "Return the THING at point. |
f5bd0689 CY |
132 | THING should be a symbol specifying a type of syntactic entity. |
133 | Possibilities include `symbol', `list', `sexp', `defun', | |
134 | `filename', `url', `email', `word', `sentence', `whitespace', | |
e84cad57 | 135 | `line', `number', and `page'. |
c851323f | 136 | |
72d3cfca SS |
137 | When the optional argument NO-PROPERTIES is non-nil, |
138 | strip text properties from the return value. | |
139 | ||
c851323f RS |
140 | See the file `thingatpt.el' for documentation on how to define |
141 | a symbol as a valid THING." | |
72d3cfca SS |
142 | (let ((text |
143 | (if (get thing 'thing-at-point) | |
144 | (funcall (get thing 'thing-at-point)) | |
145 | (let ((bounds (bounds-of-thing-at-point thing))) | |
146 | (when bounds | |
147 | (buffer-substring (car bounds) (cdr bounds))))))) | |
148 | (when (and text no-properties) | |
149 | (set-text-properties 0 (length text) nil text)) | |
150 | text)) | |
1a2b6c52 | 151 | |
b578f267 | 152 | ;; Go to beginning/end |
1a2b6c52 | 153 | |
c851323f | 154 | (defun beginning-of-thing (thing) |
f5bd0689 CY |
155 | "Move point to the beginning of THING. |
156 | The bounds of THING are determined by `bounds-of-thing-at-point'." | |
c851323f RS |
157 | (let ((bounds (bounds-of-thing-at-point thing))) |
158 | (or bounds (error "No %s here" thing)) | |
1a2b6c52 RS |
159 | (goto-char (car bounds)))) |
160 | ||
c851323f | 161 | (defun end-of-thing (thing) |
f5bd0689 CY |
162 | "Move point to the end of THING. |
163 | The bounds of THING are determined by `bounds-of-thing-at-point'." | |
c851323f RS |
164 | (let ((bounds (bounds-of-thing-at-point thing))) |
165 | (or bounds (error "No %s here" thing)) | |
1a2b6c52 RS |
166 | (goto-char (cdr bounds)))) |
167 | ||
f1180544 | 168 | ;; Special cases |
1a2b6c52 | 169 | |
f1180544 | 170 | ;; Lines |
9f5c7ace RS |
171 | |
172 | ;; bolp will be false when you click on the last line in the buffer | |
173 | ;; and it has no final newline. | |
174 | ||
175 | (put 'line 'beginning-op | |
2a59b30d | 176 | (lambda () (if (bolp) (forward-line -1) (beginning-of-line)))) |
9f5c7ace | 177 | |
f1180544 | 178 | ;; Sexps |
1a2b6c52 RS |
179 | |
180 | (defun in-string-p () | |
f5bd0689 CY |
181 | "Return non-nil if point is in a string. |
182 | \[This is an internal function.]" | |
1a2b6c52 RS |
183 | (let ((orig (point))) |
184 | (save-excursion | |
185 | (beginning-of-defun) | |
186 | (nth 3 (parse-partial-sexp (point) orig))))) | |
187 | ||
188 | (defun end-of-sexp () | |
f5bd0689 CY |
189 | "Move point to the end of the current sexp. |
190 | \[This is an internal function.]" | |
95b43468 | 191 | (let ((char-syntax (syntax-after (point)))) |
1a2b6c52 RS |
192 | (if (or (eq char-syntax ?\)) |
193 | (and (eq char-syntax ?\") (in-string-p))) | |
194 | (forward-char 1) | |
195 | (forward-sexp 1)))) | |
196 | ||
197 | (put 'sexp 'end-op 'end-of-sexp) | |
198 | ||
6f0e09d4 | 199 | (defun beginning-of-sexp () |
f5bd0689 CY |
200 | "Move point to the beginning of the current sexp. |
201 | \[This is an internal function.]" | |
ce8fb8aa | 202 | (let ((char-syntax (char-syntax (char-before)))) |
6f0e09d4 RS |
203 | (if (or (eq char-syntax ?\() |
204 | (and (eq char-syntax ?\") (in-string-p))) | |
205 | (forward-char -1) | |
206 | (forward-sexp -1)))) | |
207 | ||
208 | (put 'sexp 'beginning-op 'beginning-of-sexp) | |
209 | ||
f1180544 | 210 | ;; Lists |
1a2b6c52 | 211 | |
965b9376 CY |
212 | (put 'list 'bounds-of-thing-at-point 'thing-at-point-bounds-of-list-at-point) |
213 | ||
214 | (defun thing-at-point-bounds-of-list-at-point () | |
f5bd0689 CY |
215 | "Return the bounds of the list at point. |
216 | \[Internal function used by `bounds-of-thing-at-point'.]" | |
965b9376 CY |
217 | (save-excursion |
218 | (let ((opoint (point)) | |
45fdb482 JB |
219 | (beg (ignore-errors |
220 | (up-list -1) | |
221 | (point)))) | |
222 | (ignore-errors | |
223 | (if beg | |
224 | (progn (forward-sexp) | |
225 | (cons beg (point))) | |
226 | ;; Are we are at the beginning of a top-level sexp? | |
227 | (forward-sexp) | |
228 | (let ((end (point))) | |
229 | (backward-sexp) | |
230 | (if (>= opoint (point)) | |
231 | (cons opoint end)))))))) | |
1a2b6c52 | 232 | |
e8974c48 DA |
233 | ;; Defuns |
234 | ||
235 | (put 'defun 'beginning-op 'beginning-of-defun) | |
236 | (put 'defun 'end-op 'end-of-defun) | |
237 | (put 'defun 'forward-op 'end-of-defun) | |
238 | ||
6e5c1569 | 239 | ;; Filenames |
1a2b6c52 | 240 | |
839aacc9 | 241 | (defvar thing-at-point-file-name-chars "-~/[:alnum:]_.${}#%,:" |
1a2b6c52 RS |
242 | "Characters allowable in filenames.") |
243 | ||
f1180544 | 244 | (put 'filename 'end-op |
839aacc9 DL |
245 | (lambda () |
246 | (re-search-forward (concat "\\=[" thing-at-point-file-name-chars "]*") | |
247 | nil t))) | |
1a2b6c52 | 248 | (put 'filename 'beginning-op |
839aacc9 DL |
249 | (lambda () |
250 | (if (re-search-backward (concat "[^" thing-at-point-file-name-chars "]") | |
251 | nil t) | |
252 | (forward-char) | |
253 | (goto-char (point-min))))) | |
c851323f | 254 | |
6e5c1569 CY |
255 | ;; URIs |
256 | ||
257 | (defvar thing-at-point-beginning-of-url-regexp nil | |
258 | "Regexp matching the beginning of a well-formed URI. | |
259 | If nil, construct the regexp from `thing-at-point-uri-schemes'.") | |
260 | ||
d9cc804b | 261 | (defvar thing-at-point-url-path-regexp |
42986283 | 262 | "[^]\t\n \"'<>[^`{}]*[^]\t\n \"'<>[^`{}.,;]+" |
6e5c1569 | 263 | "Regexp matching the host and filename or e-mail part of a URL.") |
d9cc804b RS |
264 | |
265 | (defvar thing-at-point-short-url-regexp | |
d61bdd5d | 266 | (concat "[-A-Za-z0-9]+\\.[-A-Za-z0-9.]+" thing-at-point-url-path-regexp) |
6e5c1569 | 267 | "Regexp matching a URI without a scheme component.") |
d9cc804b | 268 | |
1c1766c7 | 269 | (defvar thing-at-point-uri-schemes |
4f5d4668 | 270 | ;; Officials from http://www.iana.org/assignments/uri-schemes.html |
6e5c1569 CY |
271 | '("aaa://" "about:" "acap://" "apt:" "bzr://" "bzr+ssh://" |
272 | "attachment:/" "chrome://" "cid:" "content://" "crid://" "cvs://" | |
273 | "data:" "dav:" "dict://" "doi:" "dns:" "dtn:" "feed:" "file:/" | |
274 | "finger://" "fish://" "ftp://" "geo:" "git://" "go:" "gopher://" | |
275 | "h323:" "http://" "https://" "im:" "imap://" "info:" "ipp:" | |
276 | "irc://" "irc6://" "ircs://" "iris.beep:" "jar:" "ldap://" | |
277 | "ldaps://" "mailto:" "mid:" "mtqp://" "mupdate://" "news:" | |
278 | "nfs://" "nntp://" "opaquelocktoken:" "pop://" "pres:" | |
279 | "resource://" "rmi://" "rsync://" "rtsp://" "rtspu://" "service:" | |
280 | "sftp://" "sip:" "sips:" "smb://" "sms:" "snmp://" "soap.beep://" | |
281 | "soap.beeps://" "ssh://" "svn://" "svn+ssh://" "tag:" "tel:" | |
282 | "telnet://" "tftp://" "tip://" "tn3270://" "udp://" "urn:" | |
283 | "uuid:" "vemmi://" "webcal://" "xri://" "xmlrpc.beep://" | |
284 | "xmlrpc.beeps://" "z39.50r://" "z39.50s://" "xmpp:" | |
285 | ;; Compatibility | |
286 | "fax:" "mms://" "mmsh://" "modem:" "prospero:" "snews:" | |
287 | "wais://") | |
288 | "List of URI schemes recognized by `thing-at-point-url-at-point'. | |
289 | Each string in this list should correspond to the start of a | |
290 | URI's scheme component, up to and including the trailing // if | |
291 | the scheme calls for that to be present.") | |
292 | ||
293 | (defvar thing-at-point-markedup-url-regexp "<URL:\\([^<>\n]+\\)>" | |
294 | "Regexp matching a URL marked up per RFC1738. | |
295 | This kind of markup was formerly recommended as a way to indicate | |
296 | URIs, but as of RFC 3986 it is no longer recommended. | |
297 | Subexpression 1 should contain the delimited URL.") | |
298 | ||
299 | (defvar thing-at-point-newsgroup-regexp | |
300 | "\\`[[:lower:]]+\\.[-+[:lower:]_0-9.]+\\'" | |
301 | "Regexp matching a newsgroup name.") | |
302 | ||
303 | (defvar thing-at-point-newsgroup-heads | |
304 | '("alt" "comp" "gnu" "misc" "news" "sci" "soc" "talk") | |
305 | "Used by `thing-at-point-newsgroup-p' if gnus is not running.") | |
306 | ||
307 | (defvar thing-at-point-default-mail-uri-scheme "mailto" | |
308 | "Default scheme for ill-formed URIs that look like <foo@example.com>. | |
309 | If nil, do not give such URIs a scheme.") | |
d9cc804b RS |
310 | |
311 | (put 'url 'bounds-of-thing-at-point 'thing-at-point-bounds-of-url-at-point) | |
6e5c1569 CY |
312 | |
313 | (defun thing-at-point-bounds-of-url-at-point (&optional lax) | |
314 | "Return a cons cell containing the start and end of the URI at point. | |
315 | Try to find a URI using `thing-at-point-markedup-url-regexp'. | |
316 | If that fails, try with `thing-at-point-beginning-of-url-regexp'. | |
317 | If that also fails, and optional argument LAX is non-nil, return | |
318 | the bounds of a possible ill-formed URI (one lacking a scheme)." | |
319 | ;; Look for the old <URL:foo> markup. If found, use it. | |
320 | (or (thing-at-point--bounds-of-markedup-url) | |
321 | ;; Otherwise, find the bounds within which a URI may exist. The | |
322 | ;; method is similar to `ffap-string-at-point'. Note that URIs | |
323 | ;; may contain parentheses but may not contain spaces (RFC3986). | |
324 | (let* ((allowed-chars "--:=&?$+@-Z_[:alpha:]~#,%;*()!'") | |
325 | (skip-before "^[0-9a-zA-Z]") | |
326 | (skip-after ":;.,!?") | |
327 | (pt (point)) | |
328 | (beg (save-excursion | |
329 | (skip-chars-backward allowed-chars) | |
330 | (skip-chars-forward skip-before pt) | |
331 | (point))) | |
332 | (end (save-excursion | |
333 | (skip-chars-forward allowed-chars) | |
334 | (skip-chars-backward skip-after pt) | |
335 | (point)))) | |
336 | (or (thing-at-point--bounds-of-well-formed-url beg end pt) | |
337 | (if lax (cons beg end)))))) | |
338 | ||
339 | (defun thing-at-point--bounds-of-markedup-url () | |
340 | (when thing-at-point-markedup-url-regexp | |
341 | (let ((case-fold-search t) | |
342 | (pt (point)) | |
343 | (beg (line-beginning-position)) | |
344 | (end (line-end-position)) | |
345 | found) | |
346 | (save-excursion | |
347 | (goto-char beg) | |
348 | (while (and (not found) | |
349 | (<= (point) pt) | |
350 | (< (point) end)) | |
351 | (and (re-search-forward thing-at-point-markedup-url-regexp | |
352 | end 1) | |
353 | (> (point) pt) | |
354 | (setq found t)))) | |
355 | (if found | |
356 | (cons (match-beginning 1) (match-end 1)))))) | |
357 | ||
45fdb482 | 358 | (defun thing-at-point--bounds-of-well-formed-url (beg end _pt) |
6e5c1569 CY |
359 | (save-excursion |
360 | (goto-char beg) | |
361 | (let (url-beg paren-end regexp) | |
362 | (save-restriction | |
363 | (narrow-to-region beg end) | |
364 | ;; The scheme component must either match at BEG, or have no | |
365 | ;; other alphanumerical ASCII characters before it. | |
366 | (setq regexp (concat "\\(?:\\`\\|[^a-zA-Z0-9]\\)\\(" | |
367 | (or thing-at-point-beginning-of-url-regexp | |
368 | (regexp-opt thing-at-point-uri-schemes)) | |
369 | "\\)")) | |
370 | (and (re-search-forward regexp end t) | |
371 | ;; URI must have non-empty contents. | |
372 | (< (point) end) | |
373 | (setq url-beg (match-beginning 1)))) | |
374 | (when url-beg | |
375 | ;; If there is an open paren before the URI, truncate to the | |
376 | ;; matching close paren. | |
377 | (and (> url-beg (point-min)) | |
378 | (eq (car-safe (syntax-after (1- url-beg))) 4) | |
379 | (save-restriction | |
380 | (narrow-to-region (1- url-beg) (min end (point-max))) | |
381 | (setq paren-end (ignore-errors | |
382 | (scan-lists (1- url-beg) 1 0)))) | |
383 | (not (blink-matching-check-mismatch (1- url-beg) paren-end)) | |
384 | (setq end (1- paren-end))) | |
385 | (cons url-beg end))))) | |
d9cc804b RS |
386 | |
387 | (put 'url 'thing-at-point 'thing-at-point-url-at-point) | |
340483df | 388 | |
6e5c1569 CY |
389 | (defun thing-at-point-url-at-point (&optional lax bounds) |
390 | "Return the URL around or before point. | |
391 | If no URL is found, return nil. | |
392 | ||
393 | If optional argument LAX is non-nil, look for URLs that are not | |
394 | well-formed, such as foo@bar or <nobody>. | |
395 | ||
396 | If optional arguments BOUNDS are non-nil, it should be a cons | |
397 | cell of the form (START . END), containing the beginning and end | |
398 | positions of the URI. Otherwise, these positions are detected | |
399 | automatically from the text around point. | |
400 | ||
401 | If the scheme component is absent, either because a URI delimited | |
402 | with <url:...> lacks one, or because an ill-formed URI was found | |
403 | with LAX or BEG and END, try to add a scheme in the returned URI. | |
404 | The scheme is chosen heuristically: \"mailto:\" if the address | |
405 | looks like an email address, \"ftp://\" if it starts with | |
406 | \"ftp\", etc." | |
407 | (unless bounds | |
408 | (setq bounds (thing-at-point-bounds-of-url-at-point lax))) | |
409 | (when (and bounds (< (car bounds) (cdr bounds))) | |
410 | (let ((str (buffer-substring-no-properties (car bounds) (cdr bounds)))) | |
411 | ;; If there is no scheme component, try to add one. | |
412 | (unless (string-match "\\`[a-zA-Z][-a-zA-Z0-9+.]*:" str) | |
413 | (or | |
414 | ;; If the URI has the form <foo@bar>, treat it according to | |
415 | ;; `thing-at-point-default-mail-uri-scheme'. If there are | |
416 | ;; no angle brackets, it must be mailto. | |
417 | (when (string-match "\\`[^:</>@]+@[-.0-9=&?$+A-Z_a-z~#,%;*]" str) | |
418 | (let ((scheme (if (and (eq (char-before (car bounds)) ?<) | |
419 | (eq (char-after (cdr bounds)) ?>)) | |
420 | thing-at-point-default-mail-uri-scheme | |
421 | "mailto"))) | |
422 | (if scheme | |
423 | (setq str (concat scheme ":" str))))) | |
424 | ;; If the string is like <FOO>, where FOO is an existing user | |
425 | ;; name on the system, treat that as an email address. | |
426 | (and (string-match "\\`[[:alnum:]]+\\'" str) | |
427 | (eq (char-before (car bounds)) ?<) | |
428 | (eq (char-after (cdr bounds)) ?>) | |
429 | (not (string-match "~" (expand-file-name (concat "~" str)))) | |
430 | (setq str (concat "mailto:" str))) | |
431 | ;; If it looks like news.example.com, treat it as news. | |
432 | (if (thing-at-point-newsgroup-p str) | |
433 | (setq str (concat "news:" str))) | |
434 | ;; If it looks like ftp.example.com. treat it as ftp. | |
435 | (if (string-match "\\`ftp\\." str) | |
436 | (setq str (concat "ftp://" str))) | |
437 | ;; If it looks like www.example.com. treat it as http. | |
438 | (if (string-match "\\`www\\." str) | |
439 | (setq str (concat "http://" str))) | |
440 | ;; Otherwise, it just isn't a URI. | |
441 | (setq str nil))) | |
442 | str))) | |
443 | ||
444 | (defun thing-at-point-newsgroup-p (string) | |
445 | "Return STRING if it looks like a newsgroup name, else nil." | |
446 | (and | |
447 | (string-match thing-at-point-newsgroup-regexp string) | |
448 | (let ((htbs '(gnus-active-hashtb gnus-newsrc-hashtb gnus-killed-hashtb)) | |
449 | (heads thing-at-point-newsgroup-heads) | |
450 | htb ret) | |
451 | (while htbs | |
452 | (setq htb (car htbs) htbs (cdr htbs)) | |
45fdb482 JB |
453 | (ignore-errors |
454 | ;; errs: htb symbol may be unbound, or not a hash-table. | |
455 | ;; gnus-gethash is just a macro for intern-soft. | |
456 | (and (symbol-value htb) | |
457 | (intern-soft string (symbol-value htb)) | |
458 | (setq ret string htbs nil)) | |
459 | ;; If we made it this far, gnus is running, so ignore "heads": | |
460 | (setq heads nil))) | |
6e5c1569 CY |
461 | (or ret (not heads) |
462 | (let ((head (string-match "\\`\\([[:lower:]]+\\)\\." string))) | |
463 | (and head (setq head (substring string 0 (match-end 1))) | |
464 | (member head heads) | |
465 | (setq ret string)))) | |
466 | ret))) | |
467 | ||
468 | (put 'url 'end-op (lambda () (end-of-thing 'url))) | |
469 | ||
470 | (put 'url 'beginning-op (lambda () (end-of-thing 'url))) | |
d9cc804b RS |
471 | |
472 | ;; The normal thingatpt mechanism doesn't work for complex regexps. | |
473 | ;; This should work for almost any regexp wherever we are in the | |
474 | ;; match. To do a perfect job for any arbitrary regexp would mean | |
475 | ;; testing every position before point. Regexp searches won't find | |
476 | ;; matches that straddle the start position so we search forwards once | |
477 | ;; and then back repeatedly and then back up a char at a time. | |
478 | ||
5d5c701e | 479 | (defun thing-at-point-looking-at (regexp &optional distance) |
d9cc804b RS |
480 | "Return non-nil if point is in or just after a match for REGEXP. |
481 | Set the match data from the earliest such match ending at or after | |
482 | point." | |
483 | (save-excursion | |
5d5c701e LL |
484 | (let ((old-point (point)) |
485 | (forward-bound (and distance (+ (point) distance))) | |
486 | (backward-bound (and distance (- (point) distance))) | |
487 | match) | |
d9cc804b RS |
488 | (and (looking-at regexp) |
489 | (>= (match-end 0) old-point) | |
490 | (setq match (point))) | |
491 | ;; Search back repeatedly from end of next match. | |
492 | ;; This may fail if next match ends before this match does. | |
5d5c701e LL |
493 | (re-search-forward regexp forward-bound 'limit) |
494 | (while (and (re-search-backward regexp backward-bound t) | |
d9cc804b RS |
495 | (or (> (match-beginning 0) old-point) |
496 | (and (looking-at regexp) ; Extend match-end past search start | |
497 | (>= (match-end 0) old-point) | |
498 | (setq match (point)))))) | |
499 | (if (not match) nil | |
500 | (goto-char match) | |
501 | ;; Back up a char at a time in case search skipped | |
502 | ;; intermediate match straddling search start pos. | |
503 | (while (and (not (bobp)) | |
504 | (progn (backward-char 1) (looking-at regexp)) | |
505 | (>= (match-end 0) old-point) | |
506 | (setq match (point)))) | |
507 | (goto-char match) | |
508 | (looking-at regexp))))) | |
509 | ||
baef4cbe KF |
510 | ;; Email addresses |
511 | (defvar thing-at-point-email-regexp | |
86265518 | 512 | "<?[-+_.~a-zA-Z][-+_.~:a-zA-Z0-9]*@[-.a-zA-Z0-9]+>?" |
baef4cbe KF |
513 | "A regular expression probably matching an email address. |
514 | This does not match the real name portion, only the address, optionally | |
515 | with angle brackets.") | |
516 | ||
517 | ;; Haven't set 'forward-op on 'email nor defined 'forward-email' because | |
518 | ;; not sure they're actually needed, and URL seems to skip them too. | |
519 | ;; Note that (end-of-thing 'email) and (beginning-of-thing 'email) | |
520 | ;; work automagically, though. | |
521 | ||
522 | (put 'email 'bounds-of-thing-at-point | |
523 | (lambda () | |
5d5c701e LL |
524 | (let ((thing (thing-at-point-looking-at |
525 | thing-at-point-email-regexp 500))) | |
baef4cbe KF |
526 | (if thing |
527 | (let ((beginning (match-beginning 0)) | |
528 | (end (match-end 0))) | |
529 | (cons beginning end)))))) | |
530 | ||
531 | (put 'email 'thing-at-point | |
532 | (lambda () | |
533 | (let ((boundary-pair (bounds-of-thing-at-point 'email))) | |
534 | (if boundary-pair | |
535 | (buffer-substring-no-properties | |
536 | (car boundary-pair) (cdr boundary-pair)))))) | |
537 | ||
f1180544 | 538 | ;; Buffer |
1a2b6c52 | 539 | |
206eef6c SM |
540 | (put 'buffer 'end-op (lambda () (goto-char (point-max)))) |
541 | (put 'buffer 'beginning-op (lambda () (goto-char (point-min)))) | |
1a2b6c52 | 542 | |
f1180544 | 543 | ;; Aliases |
1a2b6c52 | 544 | |
f5bd0689 CY |
545 | (defun word-at-point () |
546 | "Return the word at point. See `thing-at-point'." | |
547 | (thing-at-point 'word)) | |
548 | ||
549 | (defun sentence-at-point () | |
550 | "Return the sentence at point. See `thing-at-point'." | |
551 | (thing-at-point 'sentence)) | |
1a2b6c52 | 552 | |
c851323f | 553 | (defun read-from-whole-string (str) |
2a59b30d | 554 | "Read a Lisp expression from STR. |
c851323f RS |
555 | Signal an error if the entire string was not used." |
556 | (let* ((read-data (read-from-string str)) | |
f1180544 | 557 | (more-left |
1a2b6c52 | 558 | (condition-case nil |
1b0d40de | 559 | ;; The call to `ignore' suppresses a compiler warning. |
7f1422bc | 560 | (progn (ignore (read-from-string (substring str (cdr read-data)))) |
1a2b6c52 RS |
561 | t) |
562 | (end-of-file nil)))) | |
563 | (if more-left | |
564 | (error "Can't read whole string") | |
565 | (car read-data)))) | |
566 | ||
f1180544 | 567 | (defun form-at-point (&optional thing pred) |
45fdb482 JB |
568 | (let ((sexp (ignore-errors |
569 | (read-from-whole-string (thing-at-point (or thing 'sexp)))))) | |
c851323f | 570 | (if (or (not pred) (funcall pred sexp)) sexp))) |
1a2b6c52 | 571 | |
be64abcf | 572 | ;;;###autoload |
de285f27 CY |
573 | (defun sexp-at-point () |
574 | "Return the sexp at point, or nil if none is found." | |
575 | (form-at-point 'sexp)) | |
be64abcf | 576 | ;;;###autoload |
2a59b30d | 577 | (defun symbol-at-point () |
de285f27 | 578 | "Return the symbol at point, or nil if none is found." |
2a59b30d SM |
579 | (let ((thing (thing-at-point 'symbol))) |
580 | (if thing (intern thing)))) | |
be64abcf | 581 | ;;;###autoload |
de285f27 CY |
582 | (defun number-at-point () |
583 | "Return the number at point, or nil if none is found." | |
584 | (form-at-point 'sexp 'numberp)) | |
748b0d84 | 585 | (put 'number 'thing-at-point 'number-at-point) |
be64abcf | 586 | ;;;###autoload |
de285f27 CY |
587 | (defun list-at-point () |
588 | "Return the Lisp list at point, or nil if none is found." | |
589 | (form-at-point 'list 'listp)) | |
1a2b6c52 | 590 | |
55535639 | 591 | ;;; thingatpt.el ends here |