InfoMagic Source Code 1993 July/THE_SOURCE_CODE_CD_ROM.iso/languages/elisp/misc/thing.el

Text File | 1990-03-21 | 5.5 KB | 176 lines

;From: [e-mail] (Joshua D. Guttman)
;Newsgroups: comp.emacs,gnu.emacs
;Subject: thing commands, also work under X
;Message-ID: <[e-mail]>
;Date: 8 Aug 89 00:11:47 GMT
;Distribution: comp
;Organization: Mitre Corporation, Bedford, MA.
;Lines: 166
;
;I'm enclosing some code that simplifies and adapts the "thing commands"
;previously offered under emacstool, based on an idea from zmacs.  The syntax
;tables are used to construct the "thing" at a particular place in a buffer.
;For instance, at a left-paren, the thing is the following sexp, while at a
;right paren it is the preceding sexp.  The association between character syntax
;and "things" is fixed by an alist, so that behavior can be easily tailored.  I
;have also included two functions that connect with X windows.  I bind them to
;mouse events, and find them very useful.  Bindings I use are:
;
;(define-key mouse-map x-button-s-middle 'x-mouse-kill-thing)
;(define-key mouse-map x-button-s-right 'x-mouse-copy-thing)
;
;The other main commands are:
;
;(global-set-key "\C-ck" 'kill-thing-at-point)
;(global-set-key "\C-cw" 'copy-thing-at-point)
;
;No bindings are made by the code below, so you can do as you please.
;
;    Joshua Guttman
;
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
;; Thing.el
;; adapted from sun-fns.el by Joshua Guttman, MITRE.
;; Comments appreciated: [e-mail]


(provide 'thing)

(defun thing-boundaries (here)
  "Return start and end of text object at HERE using syntax table and thing-boundary-alist.
Thing-boundary-alist is a list of pairs of the form (SYNTAX-CHAR FUNCTION)
where FUNCTION takes a single position argument and returns a cons of places
 (start end) representing boundaries of the thing at that position.
Typically:
 Left or right Paren syntax indicates an s-expression.
 The end of a line marks the line including a trailing newline.
 Word syntax indicates current word.
 Symbol syntax indicates symbol.
 If it doesn't recognize one of these it selects just the character HERE."
  (interactive "d")
  (if (save-excursion
    (goto-char here)
    (eolp))
      (thing-get-line here)
    (let* ((syntax
        (char-syntax (char-after here)))
       (pair
        (assq syntax thing-boundary-alist)))

      (if pair
      (funcall (car (cdr pair)) here)
    (cons here (1+ here))))))


(defvar thing-boundary-alist
  '((?w thing-word)
    (?_ thing-symbol)
    (?\( thing-sexp-start)
    (?\$ thing-sexp-start)
    (?' thing-sexp-start)
    (?\" thing-sexp-start)
    (?\) thing-sexp-end)
    (?  thing-whitespace))
  "*List of pairs of the form (SYNTAX-CHAR FUNCTION) used by THING-BOUNDARIES.")

(defun thing-get-line (here)
  "Return whole of line HERE is in, with newline unless at eob."
  (save-excursion
    (goto-char here)
    (let* ((start (progn (beginning-of-line 1)
             (point)))
       (end (progn (forward-line 1)
               (point))))
      (cons start end))))

(defun thing-word (here)
  "Return start and end of word at HERE."
  (save-excursion
    (goto-char here)
    (forward-word 1)
    (let ((end (point)))
      (forward-word -1)
      (cons (point) end))))

(defun thing-symbol (here)
  "Return start and end of symbol at HERE."
  (let ((end (scan-sexps here 1)))
    (cons (min here (scan-sexps end -1))
      end)))

(defun thing-sexp-start (here)
  "Return start and end of sexp starting HERE."
  (cons here (scan-sexps here 1)))

(defun thing-sexp-end (here)
  "Return start and end of sexp ending HERE."
  (cons (scan-sexps (1+ here) -1)
    (1+ here)))

(defun thing-whitespace (here)
  "Return start to end of all but one char of whitespace HERE, unless
there's only one char of whitespace.  Then return start to end of it."
  (save-excursion
    (let ((start (progn
           (skip-chars-backward " \t") (1+ (point))))
      (end (progn
         (skip-chars-forward " \t") (point))))
      (if (= start end)
      (cons (1- start) end)
    (cons start end)))))





(defun mark-thing-at-point (here)
  "Set point at beginning and mark at end of text object using syntax table.
See thing-boundaries for definition of text objects"
  (interactive "d")
  (let ((bounds (thing-boundaries here)))
    (goto-char (cdr bounds))
    (set-mark-command nil)
    (goto-char (car bounds))))

(defun kill-thing-at-point (here)
  "Kill text object using syntax table.
See thing-boundaries for definition of text objects"
  (interactive "d")
  (let ((bounds (thing-boundaries here)))
    (kill-region (car bounds) (cdr bounds))))


(defun copy-thing-at-point (here)
  "Copy text object using syntax table.
See thing-boundaries for definition of text objects"
  (interactive "d")
  (let ((bounds (thing-boundaries here)))
    (copy-region-as-kill (car bounds) (cdr bounds))))

;;; Two X-related fns.

(defun x-mouse-kill-thing (arg)
  "Kill text object at point or mouse position and insert into window system cut buffer.
Save in Emacs kill ring also."
  (interactive "d")
  (setq last-command nil)
  (x-mouse-set-point arg)
  (let* ((bounds (thing-boundaries (point)))
     (start (car bounds))
     (end (cdr bounds)))
    (x-store-cut-buffer (buffer-substring start end))
    (kill-region start end)))

(defun x-mouse-copy-thing (arg)
  "Copy text object at point or mouse position into window system cut buffer.
Save in Emacs kill ring also."
  (save-excursion
    (save-window-excursion
      (setq last-command nil)
      (x-mouse-set-point arg)
      (let* ((bounds (thing-boundaries (point)))
         (start (car bounds))
         (end (cdr bounds)))
    (x-store-cut-buffer (buffer-substring start end))
    (copy-region-as-kill start end)))))