thingatpt.el 6.6 KB
Newer Older
Richard M. Stallman's avatar
Richard M. Stallman committed
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206
;;; thingatpt.el --- Get the `thing' at point

;; Copyright (C) 1991,1992,1993 Free Software Foundation, Inc.

;; Author: Mike Williams <mikew@gopher.dosli.govt.nz>
;; Keywords: extensions
;; Created: Thu Mar 28 13:48:23 1991
;; Version: $Revision: 1.16 $

;; This file is part of GNU Emacs.

;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;;; Commentary:
;;
;; This file provides routines for getting the `thing' at the location of
;; point, whatever that `thing' happens to be.  The `thing' is defined by
;; it's beginning and end positions in the buffer.
;;
;; The function bounds-of-thing-at-point finds the beginning and end
;; positions by moving first forward to the end of the `thing', and then
;; backwards to the beginning.  By default, it uses the corresponding
;; forward-`thing' operator (eg. forward-word, forward-line).
;;
;; Special cases are allowed for using properties associated with the named
;; `thing': 
;;
;;   forward-op		Function to call to skip forward over a `thing' (or
;;                      with a negative argument, backward).
;;                      
;;   beginning-op	Function to call to skip to the beginning of a `thing'.
;;   end-op		Function to call to skip to the end of a `thing'.
;;
;; Reliance on existing operators means that many `things' can be accessed
;; without further code:  eg.
;;     (thing-at-point 'line)
;;     (thing-at-point 'page)

;;; Code:

(provide 'thingatpt)

;;=== Version =============================================================

(defconst thing@pt-version (substring "$Revision: 1.16 $" 11 -2)
  "The revision number of thing@pt (as string).  The complete RCS id is:

  $Id: thing@pt.el,v 1.16 1993/09/30 23:54:56 mike Exp $")

;;=== Basic movement ======================================================

;;;###autoload
(defun forward-thing (THING &optional N)
  "Move forward to the end of the next THING."
  (let ((forward-op (or (get THING 'forward-op)
			(intern-soft (format "forward-%s" THING)))))
    (if (fboundp forward-op)
	(funcall forward-op (or N 1))
      (error "Can't determine how to move over %ss" THING))))

;;=== General routines ====================================================

;;;###autoload
(defun bounds-of-thing-at-point (THING)
  "Determine the start and end buffer locations for the THING at point,
where THING is an entity for which there is a either a corresponding
forward-THING operation, or corresponding beginning-of-THING and
end-of-THING operations, eg. 'word, 'sentence, 'defun.
  Return a cons cell '(start . end) giving the start and end positions."
  (let ((orig (point)))
    (condition-case nil
	(save-excursion
	  (let ((end (progn 
		       (funcall 
			(or (get THING 'end-op) 
			    (function (lambda () (forward-thing THING 1)))))
		       (point)))
		(beg (progn 
		       (funcall 
			(or (get THING 'beginning-op) 
			    (function (lambda () (forward-thing THING -1)))))
		       (point))))
	    (if (and beg end (<= beg orig) (< orig end))
		(cons beg end))))
      (error nil))))

;;;###autoload
(defun thing-at-point (THING)
  "Return the THING at point, where THING is an entity defined by
bounds-of-thing-at-point."
  (let ((bounds (bounds-of-thing-at-point THING)))
    (if bounds 
	(buffer-substring (car bounds) (cdr bounds)))))

;;=== Go to beginning/end =================================================

(defun beginning-of-thing (THING)
  (let ((bounds (bounds-of-thing-at-point THING)))
    (or bounds (error "No %s here" THING))
    (goto-char (car bounds))))

(defun end-of-thing (THING)
  (let ((bounds (bounds-of-thing-at-point THING)))
    (or bounds (error "No %s here" THING))
    (goto-char (cdr bounds))))

;;=== Special cases =======================================================

;;--- Sexps ---

(defun in-string-p ()
  (let ((orig (point)))
    (save-excursion
      (beginning-of-defun)
      (nth 3 (parse-partial-sexp (point) orig)))))

(defun end-of-sexp ()
  (let ((char-syntax (char-syntax (char-after (point)))))
    (if (or (eq char-syntax ?\))
	    (and (eq char-syntax ?\") (in-string-p)))
	(forward-char 1)
      (forward-sexp 1))))

(put 'sexp 'end-op 'end-of-sexp)

;;--- Lists ---

(put 'list 'end-op (function (lambda () (up-list 1))))
(put 'list 'beginning-op 'backward-sexp)

;;--- Filenames ---

(defvar file-name-chars "~/A-Za-z0-9---_.${}#%,"
  "Characters allowable in filenames.")

(put 'filename 'end-op    
     (function (lambda () (skip-chars-forward file-name-chars))))
(put 'filename 'beginning-op
     (function (lambda () (skip-chars-backward file-name-chars (point-min)))))

;;--- Whitespace ---

(defun forward-whitespace (ARG)
  (interactive "p")
  (if (natnump ARG) 
      (re-search-forward "[ \t]+\\|\n" nil nil ARG)
    (while (< ARG 0)
      (if (re-search-backward "[ \t]+\\|\n" nil nil)
	  (or (eq (char-after (match-beginning 0)) 10)
	      (skip-chars-backward " \t")))
      (setq ARG (1+ ARG)))))

;;--- Buffer ---

(put 'buffer 'end-op 'end-of-buffer)
(put 'buffer 'beginning-op 'beginning-of-buffer)

;;--- Symbols ---

(defun forward-symbol (ARG)
  (interactive "p")
  (if (natnump ARG) 
      (re-search-forward "\\(\\sw\\|\\s_\\)+" nil nil ARG)
    (while (< ARG 0)
      (if (re-search-backward "\\(\\sw\\|\\s_\\)+" nil nil)
	  (skip-syntax-backward "w_"))
      (setq ARG (1+ ARG)))))

;;=== Aliases =============================================================

(defun word-at-point () (thing-at-point 'word))
(defun sentence-at-point () (thing-at-point 'sentence))

(defun read-from-whole-string (STR)
  "Read a lisp expression from STR, signalling an error if the entire string
was not used."
  (let* ((read-data (read-from-string STR))
	 (more-left 
	  (condition-case nil
	      (progn (read-from-string (substring STR (cdr read-data)))
		     t)
	    (end-of-file nil))))
    (if more-left
	(error "Can't read whole string")
      (car read-data))))

(defun form-at-point (&optional THING PRED) 
  (let ((sexp (condition-case nil 
		  (read-from-whole-string (thing-at-point (or THING 'sexp)))
		(error nil))))
    (if (or (not PRED) (funcall PRED sexp)) sexp)))

(defun sexp-at-point ()   (form-at-point 'sexp))
(defun symbol-at-point () (form-at-point 'sexp 'symbolp))
(defun number-at-point () (form-at-point 'sexp 'numberp))
(defun list-at-point ()   (form-at-point 'list 'listp))

;; thingatpt.el ends here.