| 1 | ;;; thingatpt.el --- Get the `thing' at point |
| 2 | |
| 3 | ;; Copyright (C) 1991,1992,1993,1994,1995 Free Software Foundation, Inc. |
| 4 | |
| 5 | ;; Author: Mike Williams <mikew@gopher.dosli.govt.nz> |
| 6 | ;; Keywords: extensions, matching, mouse |
| 7 | ;; Created: Thu Mar 28 13:48:23 1991 |
| 8 | |
| 9 | ;; This file is part of GNU Emacs. |
| 10 | |
| 11 | ;; GNU Emacs is free software; you can redistribute it and/or modify |
| 12 | ;; it under the terms of the GNU General Public License as published by |
| 13 | ;; the Free Software Foundation; either version 2, or (at your option) |
| 14 | ;; any later version. |
| 15 | |
| 16 | ;; GNU Emacs is distributed in the hope that it will be useful, |
| 17 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
| 18 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
| 19 | ;; GNU General Public License for more details. |
| 20 | |
| 21 | ;;; Commentary: |
| 22 | |
| 23 | ;; This file provides routines for getting the `thing' at the location of |
| 24 | ;; point, whatever that `thing' happens to be. The `thing' is defined by |
| 25 | ;; its beginning and end positions in the buffer. |
| 26 | ;; |
| 27 | ;; The function bounds-of-thing-at-point finds the beginning and end |
| 28 | ;; positions by moving first forward to the end of the `thing', and then |
| 29 | ;; backwards to the beginning. By default, it uses the corresponding |
| 30 | ;; forward-`thing' operator (eg. forward-word, forward-line). |
| 31 | ;; |
| 32 | ;; Special cases are allowed for using properties associated with the named |
| 33 | ;; `thing': |
| 34 | ;; |
| 35 | ;; forward-op Function to call to skip forward over a `thing' (or |
| 36 | ;; with a negative argument, backward). |
| 37 | ;; |
| 38 | ;; beginning-op Function to call to skip to the beginning of a `thing'. |
| 39 | ;; end-op Function to call to skip to the end of a `thing'. |
| 40 | ;; |
| 41 | ;; Reliance on existing operators means that many `things' can be accessed |
| 42 | ;; without further code: eg. |
| 43 | ;; (thing-at-point 'line) |
| 44 | ;; (thing-at-point 'page) |
| 45 | |
| 46 | ;;; Code: |
| 47 | |
| 48 | (provide 'thingatpt) |
| 49 | |
| 50 | ;; Basic movement |
| 51 | |
| 52 | ;;;###autoload |
| 53 | (defun forward-thing (THING &optional N) |
| 54 | "Move forward to the end of the next THING." |
| 55 | (let ((forward-op (or (get THING 'forward-op) |
| 56 | (intern-soft (format "forward-%s" THING))))) |
| 57 | (if (fboundp forward-op) |
| 58 | (funcall forward-op (or N 1)) |
| 59 | (error "Can't determine how to move over %ss" THING)))) |
| 60 | |
| 61 | ;; General routines |
| 62 | |
| 63 | ;;;###autoload |
| 64 | (defun bounds-of-thing-at-point (THING) |
| 65 | "Determine the start and end buffer locations for the THING at point, |
| 66 | where THING is an entity for which there is a either a corresponding |
| 67 | forward-THING operation, or corresponding beginning-of-THING and |
| 68 | end-of-THING operations, eg. 'word, 'sentence, 'defun. |
| 69 | Return a cons cell '(start . end) giving the start and end positions." |
| 70 | (let ((orig (point))) |
| 71 | (condition-case nil |
| 72 | (save-excursion |
| 73 | (let ((end (progn |
| 74 | (funcall |
| 75 | (or (get THING 'end-op) |
| 76 | (function (lambda () (forward-thing THING 1))))) |
| 77 | (point))) |
| 78 | (beg (progn |
| 79 | (funcall |
| 80 | (or (get THING 'beginning-op) |
| 81 | (function (lambda () (forward-thing THING -1))))) |
| 82 | (point)))) |
| 83 | (if (and beg end (<= beg orig) (< orig end)) |
| 84 | (cons beg end)))) |
| 85 | (error nil)))) |
| 86 | |
| 87 | ;;;###autoload |
| 88 | (defun thing-at-point (THING) |
| 89 | "Return the THING at point, where THING is an entity defined by |
| 90 | bounds-of-thing-at-point." |
| 91 | (let ((bounds (bounds-of-thing-at-point THING))) |
| 92 | (if bounds |
| 93 | (buffer-substring (car bounds) (cdr bounds))))) |
| 94 | |
| 95 | ;; Go to beginning/end |
| 96 | |
| 97 | (defun beginning-of-thing (THING) |
| 98 | (let ((bounds (bounds-of-thing-at-point THING))) |
| 99 | (or bounds (error "No %s here" THING)) |
| 100 | (goto-char (car bounds)))) |
| 101 | |
| 102 | (defun end-of-thing (THING) |
| 103 | (let ((bounds (bounds-of-thing-at-point THING))) |
| 104 | (or bounds (error "No %s here" THING)) |
| 105 | (goto-char (cdr bounds)))) |
| 106 | |
| 107 | ;; Special cases |
| 108 | |
| 109 | ;; Lines |
| 110 | |
| 111 | ;; bolp will be false when you click on the last line in the buffer |
| 112 | ;; and it has no final newline. |
| 113 | |
| 114 | (put 'line 'beginning-op |
| 115 | (function (lambda () (if (bolp) (forward-line -1) (beginning-of-line))))) |
| 116 | |
| 117 | ;; Sexps |
| 118 | |
| 119 | (defun in-string-p () |
| 120 | (let ((orig (point))) |
| 121 | (save-excursion |
| 122 | (beginning-of-defun) |
| 123 | (nth 3 (parse-partial-sexp (point) orig))))) |
| 124 | |
| 125 | (defun end-of-sexp () |
| 126 | (let ((char-syntax (char-syntax (char-after (point))))) |
| 127 | (if (or (eq char-syntax ?\)) |
| 128 | (and (eq char-syntax ?\") (in-string-p))) |
| 129 | (forward-char 1) |
| 130 | (forward-sexp 1)))) |
| 131 | |
| 132 | (put 'sexp 'end-op 'end-of-sexp) |
| 133 | |
| 134 | ;; Lists |
| 135 | |
| 136 | (put 'list 'end-op (function (lambda () (up-list 1)))) |
| 137 | (put 'list 'beginning-op 'backward-sexp) |
| 138 | |
| 139 | ;; Filenames |
| 140 | |
| 141 | (defvar file-name-chars "~/A-Za-z0-9---_.${}#%," |
| 142 | "Characters allowable in filenames.") |
| 143 | |
| 144 | (put 'filename 'end-op |
| 145 | (function (lambda () (skip-chars-forward file-name-chars)))) |
| 146 | (put 'filename 'beginning-op |
| 147 | (function (lambda () (skip-chars-backward file-name-chars (point-min))))) |
| 148 | |
| 149 | ;; Whitespace |
| 150 | |
| 151 | (defun forward-whitespace (ARG) |
| 152 | (interactive "p") |
| 153 | (if (natnump ARG) |
| 154 | (re-search-forward "[ \t]+\\|\n" nil nil ARG) |
| 155 | (while (< ARG 0) |
| 156 | (if (re-search-backward "[ \t]+\\|\n" nil nil) |
| 157 | (or (eq (char-after (match-beginning 0)) 10) |
| 158 | (skip-chars-backward " \t"))) |
| 159 | (setq ARG (1+ ARG))))) |
| 160 | |
| 161 | ;; Buffer |
| 162 | |
| 163 | (put 'buffer 'end-op 'end-of-buffer) |
| 164 | (put 'buffer 'beginning-op 'beginning-of-buffer) |
| 165 | |
| 166 | ;; Symbols |
| 167 | |
| 168 | (defun forward-symbol (ARG) |
| 169 | (interactive "p") |
| 170 | (if (natnump ARG) |
| 171 | (re-search-forward "\\(\\sw\\|\\s_\\)+" nil nil ARG) |
| 172 | (while (< ARG 0) |
| 173 | (if (re-search-backward "\\(\\sw\\|\\s_\\)+" nil nil) |
| 174 | (skip-syntax-backward "w_")) |
| 175 | (setq ARG (1+ ARG))))) |
| 176 | |
| 177 | ;; Syntax blocks |
| 178 | |
| 179 | (defun forward-same-syntax (&optional arg) |
| 180 | (interactive "p") |
| 181 | (while (< arg 0) |
| 182 | (skip-syntax-backward |
| 183 | (char-to-string (char-syntax (char-after (1- (point)))))) |
| 184 | (setq arg (1+ arg))) |
| 185 | (while (> arg 0) |
| 186 | (skip-syntax-forward (char-to-string (char-syntax (char-after (point))))) |
| 187 | (setq arg (1- arg)))) |
| 188 | |
| 189 | ;; Aliases |
| 190 | |
| 191 | (defun word-at-point () (thing-at-point 'word)) |
| 192 | (defun sentence-at-point () (thing-at-point 'sentence)) |
| 193 | |
| 194 | (defun read-from-whole-string (STR) |
| 195 | "Read a lisp expression from STR, signaling an error if the entire string |
| 196 | was not used." |
| 197 | (let* ((read-data (read-from-string STR)) |
| 198 | (more-left |
| 199 | (condition-case nil |
| 200 | (progn (read-from-string (substring STR (cdr read-data))) |
| 201 | t) |
| 202 | (end-of-file nil)))) |
| 203 | (if more-left |
| 204 | (error "Can't read whole string") |
| 205 | (car read-data)))) |
| 206 | |
| 207 | (defun form-at-point (&optional THING PRED) |
| 208 | (let ((sexp (condition-case nil |
| 209 | (read-from-whole-string (thing-at-point (or THING 'sexp))) |
| 210 | (error nil)))) |
| 211 | (if (or (not PRED) (funcall PRED sexp)) sexp))) |
| 212 | |
| 213 | (defun sexp-at-point () (form-at-point 'sexp)) |
| 214 | (defun symbol-at-point () (form-at-point 'sexp 'symbolp)) |
| 215 | (defun number-at-point () (form-at-point 'sexp 'numberp)) |
| 216 | (defun list-at-point () (form-at-point 'list 'listp)) |
| 217 | |
| 218 | ;; thingatpt.el ends here. |