[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
thingatpt-utils-base.el 1.0
From: |
Andreas Roehler |
Subject: |
thingatpt-utils-base.el 1.0 |
Date: |
Sat, 20 Jan 2007 12:15:50 +0100 |
User-agent: |
KMail/1.8.2 |
;;; thingatpt-utils-base.el --- thing-at-point edit functions
;; Version: 1.0
;; Copyright (C) 2006, 2007 Andreas Roehler
;; Author: Andreas Roehler <address@hidden>
;; Keywords: convenience
;;; Commentary:
;; A set of functions to return, mover over or manipulate a
;; given THING. THING may be a well known form as
;; symbol', `list', `sexp', `defun' but also a new
;; defined and abstract thing.
;; The idea is to have a set of similar forms, which are quickly
;; found that way. Many of them you probably
;; will never use; however it's easy thus to know which
;; facilities exist, should you need them. For example, to provide a
;; word with double-quotes around it, call
;; doublequote-word-atpt. In a similar way you may double-quote not
;; just a word, but any object instrumented here as THING. You
;; want to have parentheses around it? Call
;; parentize-word-atpt, etc.
;; To see other features, maybe try separate-list-atpt or
;; comment-list-atpt while point is inside a list. Try
;; it again with an abstract char-class as [:alnum:],
;; i.e. try comment-alnum-atpt, brace-alnum-atpt etc.
;; Call `list-of-things-atpt' to see which objects are presently
;; instrumented.
;; All THINGS are provided with a set of functions at, before and
;; after point - i.e. to call with ACTION-THING-atpt,
;; -bfpt, afpt. Most before- and after-point-functions skip whitespaces
;; until first non-whitespace is reached, whereas ACTION-blank-bfpt
;; etc. skip non-whitespaces respectively. Thus functions which
;; call before- or after point forms presently only take effect, if
;; point is over a char, which is not part of THING; otherwise THING
;; at point is returned.
;; This utility comes with test-functions which return the possible
;; results of most functions
;; (exception are the kill-fns). Call thatpt-test,
;; thatpt-mv-test or thatpt-delimtest over text.
;; Thatpt-delimtest changes but restores the buffer.
;; Customize the speed of execution via `thatpt-delimtest-delay'
;; and `thatpt-mv-test-delay.'
;; Diffs to basics of required thingatpt.el:
;; `bounds-of-thing-at-point' is replaced by a new
;; `bounds-of-thatpt', which now first searches backward.
;; As a consequence several `beginning-op' and `end-op' constructs
;; had to be rewritten.
;; Behavior in general is not validating; i.e. if you call
;; url-atpt and there is no url, all chars at point may be picked,
;; which could be part of a url. Sometimes, however, a kind of
;; validation may be introduced.
;; In case of trouble, please send me a bug report. 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 form 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.
;; Todo: Enable operation over a given number of things forward
;; or backward from point. (The form, which will take the numeric
;; argument is given already, but has no effect at the moment.)
;;; Code:
(require 'thingatpt)
(defvar thatpt-orig 0
"Correct orig according to delimiter-length")
;; Ascii
(put 'ascii 'beginning-op
(lambda ()
(when
(looking-at "[[:ascii:]]")
(skip-chars-backward "[:ascii:]"))))
(put 'ascii 'end-op
(lambda ()
(skip-chars-forward "[:ascii:]")))
;; Alnum
(put 'alnum 'beginning-op
(lambda ()
(when
(looking-at "[[:alnum:]]")
(skip-chars-backward "[:alnum:]"))))
(put 'alnum 'end-op
(lambda ()
(skip-chars-forward "[:alnum:]")))
;; Alpha
(put 'alpha 'beginning-op
(lambda ()
(when
(looking-at "[[:alpha:]]")
(skip-chars-backward "[:alpha:]"))))
(put 'alpha 'end-op
(lambda ()
(skip-chars-forward "[:alpha:]")))
;; Blank
(put 'blank 'beginning-op
(lambda ()
(when
(looking-at "[[:blank:]]")
(skip-chars-backward "[:blank:]"))))
(put 'blank 'end-op
(lambda ()
(skip-chars-forward "[:blank:]")))
;; Cntrl
(put 'cntrl 'beginning-op
(lambda ()
(when
(looking-at "[[:cntrl:]]")
(skip-chars-backward "[:cntrl:]"))))
(put 'cntrl 'end-op
(lambda ()
(skip-chars-forward "[:cntrl:]")))
;; Digit
(put 'digit 'beginning-op
(lambda ()
(when
(looking-at "[[:digit:]]")
(skip-chars-backward "[:digit:]"))))
(put 'digit 'end-op
(lambda ()
(skip-chars-forward "[:digit:]")))
;; Graph
(put 'graph 'beginning-op
(lambda ()
(when
(looking-at "[[:graph:]]")
(skip-chars-backward "[:graph:]"))))
(put 'graph 'end-op
(lambda ()
(skip-chars-forward "[:graph:]")))
;; Lower
(put 'lower 'beginning-op
(lambda ()
(when
(looking-at "[[:lower:]]")
(skip-chars-backward "[:lower:]"))))
(put 'lower 'end-op
(lambda ()
(skip-chars-forward "[:lower:]")))
;; Multibyte
(put 'multibyte 'beginning-op
(lambda ()
(when
(looking-at "[[:multibyte:]]")
(skip-chars-backward "[:multibyte:]"))))
(put 'multibyte 'end-op
(lambda ()
(skip-chars-forward "[:multibyte:]")))
;; Nonascii
(put 'nonascii 'beginning-op
(lambda ()
(when
(looking-at "[[:nonascii:]]")
(skip-chars-backward "[:nonascii:]"))))
(put 'nonascii 'end-op
(lambda ()
(skip-chars-forward "[:nonascii:]")))
;; Print
(put 'print 'beginning-op
(lambda ()
(when
(looking-at "[[:print:]]")
(skip-chars-backward "[:print:]"))))
(put 'print 'end-op
(lambda ()
(skip-chars-forward "[:print:]")))
;; Punct
(put 'punct 'beginning-op
(lambda ()
(when
(looking-at "[[:punct:]]")
(skip-chars-backward "[:punct:]"))))
(put 'punct 'end-op
(lambda ()
(skip-chars-forward "[:punct:]")))
;; Space
(put 'space 'beginning-op
(lambda ()
(when
(looking-at "[[:space:]]")
(skip-chars-backward "[:space:]"))))
(put 'space 'end-op
(lambda ()
(skip-chars-forward "[:space:]")))
;; Unibyte
(put 'unibyte 'beginning-op
(lambda ()
(when
(looking-at "[[:unibyte:]]")
(skip-chars-backward "[:unibyte:]"))))
(put 'unibyte 'end-op
(lambda ()
(skip-chars-forward "[:unibyte:]")))
;; Upper
(put 'upper 'beginning-op
(lambda ()
(when
(looking-at "[[:upper:]]")
(skip-chars-backward "[:upper:]"))))
(put 'upper 'end-op
(lambda ()
(skip-chars-forward "[:upper:]")))
;; Word
(put 'word 'beginning-op
(lambda ()
(when
(looking-at "[[:word:]]")
(skip-chars-backward "[:word:]"))))
(put 'word 'end-op
(lambda ()
(skip-chars-forward "[:word:]")))
;; Xdigit
(put 'xdigit 'beginning-op
(lambda ()
(when
(looking-at "[[:xdigit:]]")
(skip-chars-backward "[:xdigit:]"))))
(put 'xdigit 'end-op
(lambda ()
(skip-chars-forward "[:xdigit:]")))
;;; CSV
;; Value of var `csv-separators' will be taken according to
;;; csv-mode.el --- major mode for editing comma-separated value files
;; Author: Francis J. Wright <F.J.Wright at qmul.ac.uk>
;; URL: http://centaur.maths.qmul.ac.uk/Emacs/
(defcustom atpt-separator ";"
"Char to distinguish datasets in a `comma`-separated row"
:type 'string
:group 'convenience)
(if (boundp 'csv-separators)
(setq separator-atpt csv-separators)
(setq separator-atpt atpt-separator))
(put 'csv 'beginning-op
(lambda ()
(skip-chars-backward (concat "^" (car csv-separators))
(line-beginning-position))))
(put 'csv 'end-op
(lambda ()
(skip-chars-forward (concat "^" (car
csv-separators))(line-end-position))))
;;; Symbol
(put 'symbol 'beginning-op
(lambda ()
(skip-syntax-backward "W_")))
(put 'symbol 'end-op
(lambda ()
(skip-syntax-forward "W_")))
;; Url
(put 'url 'beginning-op
(lambda ()
;; provide for the case, we are over a
;; string-delimiter as `"'
(when
(and (not (eq 32 (char-after)))
(or (bobp)
(eq 32 (char-before))))
(forward-char 1)
;; as the bounds-function checks position, correct it
(setq thatpt-orig 1))
(skip-chars-backward ":/address@hidden&'()*+,;=[:alnum:]-._~")
))
(put 'url 'end-op
(lambda ()
(skip-chars-forward ":/address@hidden&'()*+,;=[:alnum:]-._~")
(skip-chars-backward ":")))
;; Phone
(put 'phone 'beginning-op
(lambda ()
(when
(and (looking-at "[0-9 \t.()-]")
(not (eq (char-before) ?+)))
(re-search-backward "[^0-9 \t.()-][0-9 ()\t-]+"
(line-beginning-position) t 1) (forward-char 1))))
(put 'phone 'end-op
(lambda ()
(when
(looking-at "[0-9;, \t()-]")
(re-search-forward "[0-9 \t.()-]+[^0-9 \t-]" (1+ (line-end-position))
t 1) (forward-char -1))))
;; Text
;; Useful to extract texts between ml-tags
(put 'ml-text 'beginning-op
(lambda ()
(when
(looking-at "[^>]")
(re-search-backward ">" nil t 1)
(forward-char 1))))
(put 'ml-text 'end-op (lambda () (re-search-forward "</" nil t 1) (forward-char
-2)))
;; Email
(put 'email 'beginning-op
(lambda ()
(when
(looking-at "[^ \t]")
(re-search-backward
"[,;][[:graph:]]\\|<[[:graph:]]\\|^[[:graph:]]\\|[^[:graph:]][[:graph:]]"
(line-beginning-position) t 1)(when (looking-at "[[:space:];,]") (forward-char
1)))))
;; (put 'email 'end-op (lambda () (re-search-forward
"[[:graph:]]+>\\|[[:graph:address@hidden:graph:]]+[> \t\n]*"
(line-end-position) t 1)))
(put 'email 'end-op (lambda () (when (looking-at "[
<]\\{0,1\\}\\([[:graph:address@hidden:graph:]]+\\)[;,> \t\n]*")
(goto-char (match-end 1))
(skip-chars-backward "[[:punct:]]"))))
;; ;; Graphs
;; obsolet by canonical regexp-classes forms above
;;
;; (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 "[:blank:]"))))
(put 'whitespace 'end-op (lambda () (skip-chars-forward "[:blank:]")))
;; 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]")))
;; Floats
(put 'float 'beginning-op (lambda () (when (numberp (read
(buffer-substring-no-properties (point) (1+ (point)))))
(skip-chars-backward "[0-9].,"))))
(put 'float '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 1)))
(put 'filename 'end-op
(lambda ()
(re-search-forward (concat "\\=[" thing-at-point-file-name-chars "]*")
nil t)
(skip-chars-backward ": ")))
;; 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 (with-syntax-table
(standard-syntax-table) (nth 8 (syntax-ppss))))
;; (forward-char 1)
))
(put 'string 'end-op
(lambda ()
(let ((pos (progn (save-excursion (beginning-of-defun) (point)))))
(forward-char 1)
(while (not (eq (char-after) (nth 3 (with-syntax-table
(standard-syntax-table) (parse-partial-sexp pos (point))))))
(forward-char 1)))
(forward-char 1)))
;; Lists
(put 'list 'end-op (lambda () (forward-list 1)
))
(put 'list 'beginning-op
(lambda ()
(or (looking-at "\\s(")
(when (nth 9 (syntax-ppss))
(goto-char (car (last (nth 9 (syntax-ppss)))))))))
(defun list-of-things-atpt ()
"Displays a list of objects which might be called as THING herewith
Every THING is provided with a set of functions at, before and after point
- i.e. to call with ACTION-THING-atpt, -bfpt, afpt."
(interactive)
(message "%s" thatpt-forms-list))
(defun thatpt (thing &optional arg ispec)
"Returns a buffer substring according to THING.
THING may be a well known form as `symbol',
`list', `sexp', `defun'.
You may also define new and abstract kinds of THING.
See example given in thingatpt-util.el.
Called interactively, it always copies thing-at-point
as it's the most common use and faster than copy-thing.
Further functions with `thatpt' provide moves, transpositions.
Call `list-of-things-atpt' to see what's implemented.
"
(let* ((bounds (bounds-of-thatpt thing arg))
(type (if bounds
(buffer-substring-no-properties (car bounds) (cdr bounds))
nil)))
(if ispec
(if type
(progn
;; (if (eq thing 'whitespace)
(kill-new type)
;; (kill-new (string-strip type)))
(message "%s" (car kill-ring)))
(message "%s" "nil"))
type)))
(defun bounds-of-thatpt (thing &optional arg move-flag)
"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.
Call THING by his name, i.e. word-atpt etc., see `list-of-things-atpt' to see
what's implemented"
(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)))
;; jump back to see if pos is identic to beg
(jumped-back
(progn
(forward-char -1)
(funcall
(or (get thing 'beginning-op)
(lambda ()
(forward-thing thing -1))))
(point))))
;; if orig not between beg and end, failure, nil
(when (or move-flag
(and (= beg jumped-back) (<= beg (+ thatpt-orig orig)) (<=
orig end) (< beg end)))
(cons beg end))))
(error nil)))
(defun thatpt-bounds (thing &optional arg ispec)
"thatpt-bounds returns a cons (beg . end)
of THING if any suitable - nil otherwise.
Thatpt-beginning and thatpt-end return point."
(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-separate (thing &optional arg ispec)
" "
(interactive "*p\np")
(save-excursion
(let* ((bounds (bounds-of-thatpt thing arg))
(beg (car bounds))
(end (cdr bounds))
(oldbufsize (buffer-size)))
(if (and beg end)
(progn
(when
(<= (line-beginning-position) beg)
(beginning-of-line)
(untabify (point) beg)
(unless (re-search-forward (concat "^[ ]\\{"(format "%s" (- beg
(line-beginning-position)))"\\}") beg t 1)
(goto-char beg)
(if (bobp)
(newline-and-indent)
(split-line))))
(when
(< oldbufsize (buffer-size))
(setq end (+ end (- (buffer-size) oldbufsize)))
(setq beg (+ beg (- (buffer-size) oldbufsize)))
(setq oldbufsize (buffer-size)))
(goto-char end)
(cond ((eobp)
(newline-and-indent))
((looking-at "[\t\r\n\f ]*$")
nil)
(t (split-line)))
(when
(< oldbufsize (buffer-size))
(setq end (+ end (- (buffer-size) oldbufsize)))
;; (setq beg (+ beg (- (buffer-size) oldbufsize)))
(setq oldbufsize (buffer-size))))
nil)
(list beg end))))
(defun thatpt-comment (thing &optional arg ispec)
" "
(interactive "*p\np")
(let* ((bounds (thatpt-separate thing arg ispec))
(beg (car bounds))
(end (cadr bounds)))
(if (and beg end)
(progn
(goto-char beg)
(comment-or-uncomment-region beg (1+ end)))
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)))
(defun thatpt-forward (thing &optional arg ispec)
" "
(interactive "p\np")
(or arg (setq arg 1))
(while (< 0 arg)
(let ((ep (cdr (bounds-of-thatpt thing arg t))))
(when ep
(goto-char ep)
(when ispec
(message " %s" (point))))
(setq arg (1- arg)))))
(defun thatpt-backward (thing &optional arg ispec)
" "
(interactive "p\np")
(or arg (setq arg 1))
(while (< 0 arg)
(let ((bp (car (bounds-of-thatpt thing arg t))))
(when bp
(goto-char bp)
(when ispec
(message " %s" (point))))
(setq arg (1- arg)))))
(defun thatpt-delim (thing action &optional arg ispec)
"Process begin and end of region according to value of
`delim-action\'
If no region is active, process borders of THING-at-point
according to value of delim-action-beginning- resp. -end-position
Default is symbol-atpt.
With \C-u or arg `escaped\' to `t\': insert escaped doublequotes"
(interactive "*p\np")
(or arg (setq arg 1))
(save-excursion
(let ((delim-insert (cond ((string= action "singlequote")
(cons ?\' ?\'))
((string= action "doublequote")
(cons ?\" ?\"))
((string= action "parentize")
(cons ?\( ?\)))
((string= action "brace")
(cons ?\{ ?\}))
((string= action "bracket")
(cons ?\[ ?\]))))
(oldbufsize (buffer-size))
(start (cond ((and mark-active transient-mark-mode)
(region-beginning))
;; (t (funcall (intern-soft (concat
(format "%s" thing)"-atpt-beginning-position"))))))
(t (funcall (intern-soft (concat (format "%s"
thing)"-atpt-beginning-position"))))))
(end (cond ((and mark-active transient-mark-mode)
(region-end))
(t (funcall (intern-soft (concat (format "%s"
thing)"-atpt-end-position")))))))
(if start
(progn (goto-char start)
(insert (car delim-insert))
(if (< oldbufsize (buffer-size))
(setq end (+ end (- (buffer-size) oldbufsize)))
(setq end (- end (- oldbufsize (buffer-size)))))
(goto-char end)
(insert (cdr delim-insert)))))))
(provide 'thingatpt-utils-base)
;;; thingatpt-utils-base.el ends here
- thingatpt-utils-base.el 1.0,
Andreas Roehler <=