[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
thingatpt-util.el 1.3
From: |
Andreas Roehler |
Subject: |
thingatpt-util.el 1.3 |
Date: |
Tue, 31 Oct 2006 08:01:10 +0100 |
User-agent: |
KNode/0.9.2 |
;;; thingatpt-util.el --- thing-at-point edit functions
;; Version: 1.3
;; Copyright (C) 2006 Andreas Roehler
;; Author: Andreas Roehler <address@hidden>
;; Keywords: convenience, lisp
;; This file 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.
;; This file 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.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;; Commentary:
;; Provides thing-at-point functions with interactive
;; specs.
;; Thing-at-point returns a buffer substring from point
;; according to a given title. This title may be a well
;; known forms as symbol', `list', `sexp', `defun' but
;; also of new defined and abstract things, to view and
;; extract them. Thingatpt-util aims to make that more
;; easy.
;; Changes to previous version:
;; New forms email-atpt, graphs--i.e. visible chars--atpt;
;; bug in defun-atpt fixed.
;; One major changing to thingatpt.el: core
;; function `bounds-of-thing-at-point' is replaced by a
;; new `bounds-of-thatpt' in order to make execution
;; more easy to follow, extent and maintainable.
;; `bounds-of-thatpt' now first searches backward, as
;; it's the more complicated task, thus avoiding
;; trouble later on. However, as a consequence several
;; `beginning-op' and `end-op' constructs had to be
;; rewritten. In case of trouble, please send me a bug
;; report. With `thatpt-test' you may execute and check
;; all available functions at point at once.
;; Any ideas and comments welcome.
;; How it works:
;; Thing-at-point delivers a portion of the
;; buffer. This substring is determined by two
;; alternative ways:
;; - If a pair of move-functions is known, as forward-
;; and backward-word, its used.
;;
;; - A move-function specified for thingatpt, called
;; beginning-op and end-op, may exist.
;;
;; The latter case given, this forms will be used
;; preferential. The point is stored after move.
;; Beginning and end are delivered as pair: as consed
;; bounds-of-thing.
;; It's easy to write your own thing-at-point functions.
;; You need three forms:
;;
;; (defun MY-FORM-atpt (&optional arg ispec)
;; " "
;; (interactive "p\np")
;; (thatpt 'MY-FORM arg ispec))
;;
;; (put 'MY-FORM 'beginning-op (lambda () MY-FORWARD-MOVE-FUNKTION))
;; (put 'MY-FORM 'end-op
;; (lambda () MY-BACKWARD-MOVE-FUNKTION))
;; For example if you want to pick all chars at point
;; which are written between a string "AAA" and a
;; "BBB", which may exist as
;; AAA Luckily detected a lot of things! BBB
;; After evaluation of
;; (put 'MY-FORM 'beginning-op
;; (lambda ()
;; (search-backward "AAA" nil t 1)
;; ;; step chars of search expression back
;; (forward-char 3)))
;;
;; (put 'MY-FORM 'end-op
;; (lambda ()
;; (search-forward "BBB" nil t 1)
;; (forward-char -3)))
;; together with the functions definition above, it's ready.
;; M-x MY-FORM-atpt
;; (while point inside) you should see:
;; " Luckily detected a lot of things! "
;; in the minibuffer.
;;; Code:
(require 'thingatpt)
(defun email-atpt (&optional arg ispec)
" "
(interactive "p\np")
(thatpt 'email arg ispec))
(defun bounds-of-email-atpt (&optional arg ispec)
" "
(interactive "p\np")
(thatpt-bounds 'email arg ispec))
(defun email-atpt-beginning-position (&optional arg ispec)
" "
(interactive "p\np")
(thatpt-beginning 'email arg ispec))
(defun email-atpt-end-position (&optional arg ispec)
" "
(interactive "p\np")
(thatpt-end 'email arg ispec))
(defun copy-email-atpt (&optional arg ispec)
" "
(interactive "p\np")
(thatpt-copy 'email arg ispec))
(defun kill-email-atpt ()
" "
(interactive "*")
(thatpt-kill 'email))
;;;;
(defun graphs-atpt (&optional arg ispec)
" "
(interactive "p\np")
(thatpt 'graphs arg ispec))
(defun bounds-of-graphs-atpt (&optional arg ispec)
" "
(interactive "p\np")
(thatpt-bounds 'graphs arg ispec))
(defun graphs-atpt-beginning-position (&optional arg ispec)
" "
(interactive "p\np")
(thatpt-beginning 'graphs arg ispec))
(defun graphs-atpt-end-position (&optional arg ispec)
" "
(interactive "p\np")
(thatpt-end 'graphs arg ispec))
(defun copy-graphs-atpt (&optional arg ispec)
" "
(interactive "p\np")
(thatpt-copy 'graphs arg ispec))
(defun kill-graphs-atpt ()
" "
(interactive "*")
(thatpt-kill 'graphs))
;;;;
(defun string-atpt (&optional arg ispec)
" "
(interactive "p\np")
(thatpt 'string arg ispec))
(defun bounds-of-string-atpt (&optional arg ispec)
" "
(interactive "p\np")
(thatpt-bounds 'string arg ispec))
(defun string-atpt-beginning-position (&optional arg ispec)
" "
(interactive "p\np")
(thatpt-beginning 'string arg ispec))
(defun string-atpt-end-position (&optional arg ispec)
" "
(interactive "p\np")
(thatpt-end 'string arg ispec))
(defun copy-string-atpt (&optional arg ispec)
" "
(interactive "p\np")
(thatpt-copy 'string arg ispec))
(defun kill-string-atpt ()
" "
(interactive "*")
(thatpt-kill 'string))
;;;;
(defun list-atpt (&optional arg ispec)
" "
(interactive "p\np")
(thatpt 'list arg ispec))
(defun bounds-of-list-atpt (&optional arg ispec)
" "
(interactive "p\np")
(thatpt-bounds 'list arg ispec))
(defun list-atpt-beginning-position (&optional arg ispec)
" "
(interactive "p\np")
(thatpt-beginning 'list arg ispec))
(defun list-atpt-end-position (&optional arg ispec)
" "
(interactive "p\np")
(thatpt-end 'list arg ispec))
(defun copy-list-atpt (&optional arg ispec)
" "
(interactive "p\np")
(thatpt-copy 'list arg ispec))
(defun kill-list-atpt ()
" "
(interactive "*")
(thatpt-kill 'list))
;;;;
(defun symbol-atpt (&optional arg ispec)
" "
(interactive "p\np")
(thatpt 'symbol arg ispec))
(defun bounds-of-symbol-atpt (&optional arg ispec)
" "
(interactive "p\np")
(thatpt-bounds 'symbol arg ispec))
(defun symbol-atpt-beginning-position (&optional arg ispec)
" "
(interactive "p\np")
(thatpt-beginning 'symbol arg ispec))
(defun symbol-atpt-end-position (&optional arg ispec)
" "
(interactive "p\np")
(thatpt-end 'symbol arg ispec))
(defun copy-symbol-atpt (&optional arg ispec)
" "
(interactive "p\np")
(thatpt-copy 'symbol arg ispec))
(defun kill-symbol-atpt ()
" "
(interactive "*")
(thatpt-kill 'symbol))
;;;;
(defun line-atpt (&optional arg ispec)
" "
(interactive "p\np")
(thatpt 'line arg ispec))
(defun bounds-of-line-atpt (&optional arg ispec)
" "
(interactive "p\np")
(thatpt-bounds 'line arg ispec))
(defun line-atpt-beginning-position (&optional arg ispec)
" "
(interactive "p\np")
(thatpt-beginning 'line arg ispec))
(defun line-atpt-end-position (&optional arg ispec)
" "
(interactive "p\np")
(thatpt-end 'line arg ispec))
(defun copy-line-atpt (&optional arg ispec)
" "
(interactive "p\np")
(thatpt-copy 'line arg ispec))
(defun kill-line-atpt ()
" "
(interactive "*")
(thatpt-kill 'line))
;;;;
(defun word-atpt (&optional arg ispec)
" "
(interactive "p\np")
(thatpt 'word arg ispec))
(defun bounds-of-word-atpt (&optional arg ispec)
" "
(interactive "p\np")
(thatpt-bounds 'word arg ispec))
(defun word-atpt-beginning-position (&optional arg ispec)
" "
(interactive "p\np")
(thatpt-beginning 'word arg ispec))
(defun word-atpt-end-position (&optional arg ispec)
" "
(interactive "p\np")
(thatpt-end 'word arg ispec))
(defun copy-word-atpt (&optional arg ispec)
" "
(interactive "p\np")
(thatpt-copy 'word arg ispec))
(defun kill-word-atpt ()
" "
(interactive "*")
(thatpt-kill 'word))
;;;;
(defun sentence-atpt (&optional arg ispec)
" "
(interactive "p\np")
(thatpt 'sentence arg ispec))
(defun bounds-of-sentence-atpt (&optional arg ispec)
" "
(interactive "p\np")
(thatpt-bounds 'sentence arg ispec))
(defun sentence-atpt-beginning-position (&optional arg ispec)
" "
(interactive "p\np")
(thatpt-beginning 'sentence arg ispec))
(defun sentence-atpt-end-position (&optional arg ispec)
" "
(interactive "p\np")
(thatpt-end 'sentence arg ispec))
(defun copy-sentence-atpt (&optional arg ispec)
" "
(interactive "p\np")
(thatpt-copy 'sentence arg ispec))
(defun kill-sentence-atpt ()
" "
(interactive "*")
(thatpt-kill 'sentence))
;;;;
(defun defun-atpt (&optional arg ispec)
" "
(interactive "p\np")
(thatpt 'defun arg ispec))
(defun bounds-of-defun-atpt (&optional arg ispec)
" "
(interactive "p\np")
(thatpt-bounds 'defun arg ispec))
(defun defun-atpt-beginning-position (&optional arg ispec)
" "
(interactive "p\np")
(thatpt-beginning 'defun arg ispec))
(defun defun-atpt-end-position (&optional arg ispec)
" "
(interactive "p\np")
(thatpt-end 'defun arg ispec))
(defun copy-defun-atpt (&optional arg ispec)
" "
(interactive "p\np")
(thatpt-copy 'defun arg ispec))
(defun kill-defun-atpt ()
" "
(interactive "*")
(thatpt-kill 'defun))
;;;;
(defun filename-atpt (&optional arg ispec)
" "
(interactive "p\np")
(thatpt 'filename arg ispec))
(defun bounds-of-filename-atpt (&optional arg ispec)
" "
(interactive "p\np")
(thatpt-bounds 'filename arg ispec))
(defun filename-atpt-beginning-position (&optional arg ispec)
" "
(interactive "p\np")
(thatpt-beginning 'filename arg ispec))
(defun filename-atpt-end-position (&optional arg ispec)
" "
(interactive "p\np")
(thatpt-end 'filename arg ispec))
(defun copy-filename-atpt (&optional arg ispec)
" "
(interactive "p\np")
(thatpt-copy 'filename arg ispec))
(defun kill-filename-atpt ()
" "
(interactive "*")
(thatpt-kill 'filename))
;;;;
(defun whitespace-atpt (&optional arg ispec)
" "
(interactive "p\np")
(thatpt 'whitespace arg ispec))
(defun bounds-of-whitespace-atpt (&optional arg ispec)
" "
(interactive "p\np")
(thatpt-bounds 'whitespace arg ispec))
(defun whitespace-atpt-beginning-position (&optional arg ispec)
" "
(interactive "p\np")
(thatpt-beginning 'whitespace arg ispec))
(defun whitespace-atpt-end-position (&optional arg ispec)
" "
(interactive "p\np")
(thatpt-end 'whitespace arg ispec))
(defun copy-whitespace-atpt (&optional arg ispec)
" "
(interactive "p\np")
(thatpt-copy 'whitespace arg ispec))
(defun kill-whitespace-atpt ()
" "
(interactive "*")
(thatpt-kill 'whitespace))
;;;;
(defun url-atpt (&optional arg ispec)
" "
(interactive "p\np")
(thatpt 'url arg ispec))
(defun bounds-of-url-atpt (&optional arg ispec)
" "
(interactive "p\np")
(thatpt-bounds 'url arg ispec))
(defun url-atpt-beginning-position (&optional arg ispec)
" "
(interactive "p\np")
(thatpt-beginning 'url arg ispec))
(defun url-atpt-end-position (&optional arg ispec)
" "
(interactive "p\np")
(thatpt-end 'url arg ispec))
(defun copy-url-atpt (&optional arg ispec)
" "
(interactive "p\np")
(thatpt-copy 'url arg ispec))
(defun kill-url-atpt ()
" "
(interactive "*")
(thatpt-kill 'url))
;;;;
(defun number-atpt (&optional arg ispec)
" "
(interactive "p\np")
(thatpt 'number arg ispec))
(defun bounds-of-number-atpt (&optional arg ispec)
" "
(interactive "p\np")
(thatpt-bounds 'number arg ispec))
(defun number-atpt-beginning-position (&optional arg ispec)
" "
(interactive "p\np")
(thatpt-beginning 'number arg ispec))
(defun number-atpt-end-position (&optional arg ispec)
" "
(interactive "p\np")
(thatpt-end 'number arg ispec))
(defun copy-number-atpt (&optional arg ispec)
" "
(interactive "p\np")
(thatpt-copy 'number arg ispec))
(defun kill-number-atpt ()
" "
(interactive "*")
(thatpt-kill 'number))
;;;;
(defun page-atpt (&optional arg ispec)
" "
(interactive "p\np")
(thatpt 'page arg ispec))
(defun bounds-of-page-atpt (&optional arg ispec)
" "
(interactive "p\np")
(thatpt-bounds 'page arg ispec))
(defun page-atpt-beginning-position (&optional arg ispec)
" "
(interactive "p\np")
(thatpt-beginning 'page arg ispec))
(defun page-atpt-end-position (&optional arg ispec)
" "
(interactive "p\np")
(thatpt-end 'page arg ispec))
(defun copy-page-atpt (&optional arg ispec)
" "
(interactive "p\np")
(thatpt-copy 'page arg ispec))
(defun kill-page-atpt ()
" "
(interactive "*")
(thatpt-kill 'page))
;;;;
(defun paragraph-atpt (&optional arg ispec)
" "
(interactive "p\np")
(thatpt 'paragraph arg ispec))
(defun bounds-of-paragraph-atpt (&optional arg ispec)
" "
(interactive "p\np")
(thatpt-bounds 'paragraph arg ispec))
(defun paragraph-atpt-beginning-position (&optional arg ispec)
" "
(interactive "p\np")
(thatpt-beginning 'paragraph arg ispec))
(defun paragraph-atpt-end-position (&optional arg ispec)
" "
(interactive "p\np")
(thatpt-end 'paragraph arg ispec))
(defun copy-paragraph-atpt (&optional arg ispec)
" "
(interactive "p\np")
(thatpt-copy 'paragraph arg ispec))
(defun kill-paragraph-atpt ()
" "
(interactive "*")
(thatpt-kill 'paragraph))
;;;;
(defun sexp-atpt (&optional arg ispec)
" "
(interactive "p\np")
(thatpt 'sexp arg ispec))
(defun bounds-of-sexp-atpt (&optional arg ispec)
" "
(interactive "p\np")
(thatpt-bounds 'sexp arg ispec))
(defun sexp-atpt-beginning-position (&optional arg ispec)
" "
(interactive "p\np")
(thatpt-beginning 'sexp arg ispec))
(defun sexp-atpt-end-position (&optional arg ispec)
" "
(interactive "p\np")
(thatpt-end 'sexp arg ispec))
(defun copy-sexp-atpt (&optional arg ispec)
" "
(interactive "p\np")
(thatpt-copy 'sexp arg ispec))
(defun kill-sexp-atpt ()
" "
(interactive "*")
(thatpt-kill 'sexp))
;;;;
;; End of user-functions
;; As original bounds of things function starts with the end,
;; some functions have to be adapted in order to handle
;; beginning first
;; after thing-at-point-short-url-regexp
;; Email
(put 'email 'beginning-op
(lambda ()
(when
(looking-at "[^ \t]")
(re-search-backward "<[[:graph:]]\\|<[[:graph:]]\\|^[[:graph:]]"
(line-beginning-position) t 1))))
(put 'email 'end-op (lambda () (re-search-forward
"[[:graph:address@hidden:graph:]]+\\(>\\|$\\)" nil t 1)))
;; Graphs
(put 'graphs 'beginning-op (lambda () (when (looking-at "[^ \t]")
(skip-chars-backward "[:graph:]"))))
(put 'graphs 'end-op (lambda () (skip-chars-forward "[:graph:]")))
;; Whitespace
(put 'whitespace 'beginning-op (lambda () (when (looking-at "[ \t]")
(skip-chars-backward " \t\n\f"))))
(put 'whitespace 'end-op (lambda () (skip-chars-forward " \t\n\f")))
;; Number
(put 'number 'beginning-op (lambda () (when (numberp (read
(buffer-substring-no-properties (point) (1+ (point)))))
(skip-chars-backward "[0-9]"))))
(put 'number 'end-op (lambda () (skip-chars-forward "[0-9]")))
;; Sexp
(defun beginning-of-sexp ()
(let ((char-syntax (char-syntax (char-after (point)))))
(if (eq char-syntax ?\))
(backward-up-list)
(when (and (eq char-syntax ?\") (in-string-p))
(forward-char -1))
(forward-sexp -1))))
;; Filename
(put 'filename 'beginning-op
(lambda ()
(re-search-backward (concat "[^" thing-at-point-file-name-chars "]") nil
t)
(forward-char)
(point)))
;; Defun
(put 'defun 'beginning-op (lambda (&optional arg) (beginning-of-defun (or arg
1))))
(put 'defun 'end-op (lambda (&optional arg)(end-of-defun (or arg 1))))
;; Lines
(put 'line 'beginning-op (lambda () (beginning-of-line)))
;; Strings
(put 'string 'beginning-op (lambda () (goto-char (nth 8 (syntax-ppss)))
(forward-char 1)))
(put 'string 'end-op
(lambda ()
(re-search-forward (concat (list (nth 3 (syntax-ppss)))) nil t 1)
(forward-char -1)))
;; Lists
(put 'list 'end-op (lambda () (forward-list 1)))
(put 'list 'beginning-op
(lambda ()
(when (nth 8 (syntax-ppss))
(goto-char (nth 8 (syntax-ppss))))
(when (and
(not (bobp))
(not (eq (char-syntax (char-after)) ?()))
(backward-up-list))
(point)))
(defun bounds-of-thatpt (thing &optional arg)
"
Determine the start and end buffer locations for the THING at point.
THING is a symbol which specifies the kind of syntactic entity you want.
Possibilities include `symbol', `list', `sexp', `defun', `filename', `url',
`word', `sentence', `whitespace', `line', `page' and others."
(condition-case nil
(save-excursion
(let ((orig (point))
(beg (progn
(funcall ;; First, move to beg.
(or (get thing 'beginning-op)
(lambda ()
(forward-char 1)
(forward-thing thing -1))))
(point)))
(end
(progn (funcall ;; Then move to end.
(or (get thing 'end-op)
(lambda () (forward-thing thing 1))))
(point))))
;; if orig not between beg and end, failure, nil
(when (and(<= beg orig) (<= orig end) (< beg end))
(cons beg end))))
(error nil)))
(defun thatpt-test ()
" "
(interactive)
(let
((oldbuf (current-buffer))
(thatpt-fnlist '(
email-atpt
bounds-of-email-atpt
email-atpt-beginning-position
email-atpt-end-position
copy-email-atpt
graphs-atpt
bounds-of-graphs-atpt
graphs-atpt-beginning-position
graphs-atpt-end-position
copy-graphs-atpt
string-atpt
bounds-of-string-atpt
string-atpt-beginning-position
string-atpt-end-position
copy-string-atpt
list-atpt
bounds-of-list-atpt
list-atpt-beginning-position
list-atpt-end-position
copy-list-atpt
symbol-atpt
bounds-of-symbol-atpt
symbol-atpt-beginning-position
symbol-atpt-end-position
copy-symbol-atpt
line-atpt
bounds-of-line-atpt
line-atpt-beginning-position
line-atpt-end-position
copy-line-atpt
word-atpt
bounds-of-word-atpt
word-atpt-beginning-position
word-atpt-end-position
copy-word-atpt
sentence-atpt
bounds-of-sentence-atpt
sentence-atpt-beginning-position
sentence-atpt-end-position
copy-sentence-atpt
defun-atpt
bounds-of-defun-atpt
defun-atpt-beginning-position
defun-atpt-end-position
copy-defun-atpt
filename-atpt
bounds-of-filename-atpt
filename-atpt-beginning-position
filename-atpt-end-position
copy-filename-atpt
whitespace-atpt
bounds-of-whitespace-atpt
whitespace-atpt-beginning-position
whitespace-atpt-end-position
copy-whitespace-atpt
url-atpt
bounds-of-url-atpt
url-atpt-beginning-position
url-atpt-end-position
copy-url-atpt
number-atpt
bounds-of-number-atpt
number-atpt-beginning-position
number-atpt-end-position
copy-number-atpt
page-atpt
bounds-of-page-atpt
page-atpt-beginning-position
page-atpt-end-position
copy-page-atpt
paragraph-atpt
bounds-of-paragraph-atpt
paragraph-atpt-beginning-position
paragraph-atpt-end-position
copy-paragraph-atpt
sexp-atpt
bounds-of-sexp-atpt
sexp-atpt-beginning-position
sexp-atpt-end-position
copy-sexp-atpt)))
(save-excursion
(set-buffer (get-buffer-create "thatpt-test"))
(erase-buffer))
(dolist (elt thatpt-fnlist)
(let ((item (funcall elt)))
(save-excursion
(switch-to-buffer "thatpt-test")
(when (listp item)
(setq item (concat (format "%s" (car item))" "(format "%s" (cadr
item)))))
(insert (concat (format "%s: " elt) (format "%s \n" item))))))))
(defun thatpt (thing &optional arg ispec)
" "
(let* ((bounds (bounds-of-thatpt thing arg))
(type (if bounds
(buffer-substring-no-properties (car bounds) (cdr bounds))
nil)))
(if ispec
(message "%s" type)
type)))
(defun thatpt-bounds (thing &optional arg ispec)
"Returns begin and end positions of a buffer substring
according to THING.
THING may be a well known form as `symbol',
`list', `sexp', `defun'.
thatpt-bounds returns a cons (beg . end)
of them near point if any suitable - nil otherwise.
You may also define new and abstract kinds of THING.
See example given in thingatpt-util.el."
(let* ((bounds (bounds-of-thatpt thing arg))
(start (car bounds))
(end (cdr bounds)))
(when ispec
(message "%s %s" start end))
(list start end)))
(defun thatpt-beginning (thing &optional arg ispec)
(let* ((bounds (bounds-of-thatpt thing arg))
(start (car bounds)))
(when ispec
(message "%s " start))
start))
(defun thatpt-end (thing &optional arg ispec)
(let* ((bounds (bounds-of-thatpt thing arg))
(end (cdr bounds)))
(when ispec
(message "%s " end))
end))
(defun thatpt-copy (thing &optional arg ispec)
(let ((newcopy (thatpt thing arg)))
(if newcopy
(progn
(kill-new (thatpt thing arg))
(if ispec
(message "%s" (car kill-ring))
(car kill-ring)))
nil)))
(defun thatpt-kill (thing &optional arg)
" "
(let* ((arg (or arg 1))
(bounds (bounds-of-thatpt thing arg))
(start (car bounds))
(end (cdr bounds)))
(kill-region start end)))
(provide 'thingatpt-util)
;;; thatpt-util.el ends here
[Prev in Thread] |
Current Thread |
[Next in Thread] |
- thingatpt-util.el 1.3,
Andreas Roehler <=