cgit.sxemacs.org Git - packages/blob - xemacs-packages/xemacs-base/thing.el

   1 ;;; thing.el --- find language-specific contiguous pieces of text
   2
   3 ;; Copyright (C) 1997 Free Software Foundation, Inc.
   4 ;; Copyright (C) International Computer Science Institute, 1991
   5
   6 ;; Author: David Hughes <d.hughes@videonetworks.com>
   7 ;; Maintainer: XEmacs Development Team
   8 ;; Keywords: extensions, languages
   9
  10 ;; This file is part of XEmacs.
  11
  12 ;; XEmacs is free software; you can redistribute it and/or modify it
  13 ;; under the terms of the GNU General Public License as published by
  14 ;; the Free Software Foundation; either version 2, or (at your option)
  15 ;; any later version.
  16
  17 ;; XEmacs is distributed in the hope that it will be useful, but
  18 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  20 ;; General Public License for more details.
  21
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with XEmacs; see the file COPYING.  If not, write to the Free
  24 ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
  25 ;; 02111-1307, USA.
  26
  27 ;;; Synched up with: Not in FSF.
  28
  29 ;;; Commentary:
  30
  31 ;; #### FSF has thingatpt.el, which does the same thing.  Should merge
  32 ;; or toss this.
  33
  34 ;; I wish.  The howls of pain every time I try are too overwhelming. -slb
  35
  36 ;; Authors: David Hughes <djh@cis.prime.com>
  37 ;;              adapted from Martin Boyer's thing.el for imouse
  38 ;;          Martin Boyer, IREQ <mboyer@ireq-robot.hydro.qc.ca>
  39 ;;              adapted from Heinz Schmidt's thing.el for sky-mouse
  40 ;;          Heinz Schmidt, ICSI (hws@ICSI.Berkeley.EDU)
  41 ;;              adapted from Dan L. Pierson's epoch-thing.el
  42 ;;          Dan L. Pierson <pierson@encore.com>, 2/5/90
  43 ;;              adapted from Joshua Guttman's Thing.el
  44 ;;          Joshua Guttman, MITRE (guttman@mitre.org)
  45 ;;              adapted from sun-fns.el by Joshua Guttman, MITRE.
  46 ;;
  47 ;;
  48
  49 ;;*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  50 ;;* FUNCTION: Things are language objects contiguous pieces of text
  51 ;;*           whose boundaries can be defined by syntax or context.
  52 ;;*
  53 ;;* RELATED PACKAGES: various packages built on this.
  54 ;;*
  55 ;;* HISTORY:
  56 ;;* Last edited: David Hughes 21st December 1992
  57 ;;*  jul 21 21:00 1993 (tlp00): added a kludgy thing-filename
  58 ;;*  Feb 22 21:00 1993 (tlp00): better merge with lucid and imouse
  59 ;;*  Dec 21 11:11 1992 (djh): added thing-report-char-p
  60 ;;*  Nov 23 18:00 1992 (djh): merged in Guido Bosch's ideas
  61 ;;*  Sep 10 15:35 1992 (djh): adapted for Lucid emacs19-mouse.el
  62 ;;*  Nov 28 17:40 1991 (mb): Cleaned up, and added thing-bigger-alist.
  63 ;;*  May 24 00:33 1991 (hws): overworked and added syntax.
  64 ;;* Created: 2/5/90 Dan L. Pierson
  65 ;;*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  66
  67 ;;; Code:
  68
  69 (provide 'thing)
  70
  71 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  72 ;;;;;;;;;;;;  Customization and Entry Point  ;;;;;;;;;;;;;;;;;;;;;;;;;
  73 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  74
  75 (defvar thing-boundary-alist
  76   '((?w thing-word)
  77     (?_ thing-symbol)
  78     (?\( thing-sexp-start)
  79     (?\$ thing-sexp-start)
  80     (?' thing-sexp-start)
  81     (?\" thing-sexp-start)
  82     (?\) thing-sexp-end)
  83     (?  thing-whitespace)
  84     (?< thing-comment)
  85     (?. thing-next-sexp))
  86   "*List of pairs of the form (SYNTAX-CHAR FUNCTION) used by
  87 the function `thing-boundaries'.")
  88
  89 (defvar thing-report-char-p t
  90   "*Non nil means return single char boundaries if all else fails")
  91
  92 (defvar thing-report-whitespace t
  93   "*Non nil means that whitespaces are considered as things, otherwise not.")
  94
  95 (defvar *last-thing*
  96   "The last thing found by thing-boundaries.  Used for chaining commands.")
  97
  98 ;; The variable and function `thing-region' are to avoid the continual
  99 ;; construction of cons cells as result af the thing scanner functions.
 100 ;; This avoids unnecessary garbage collection. Guido Bosch <bosch@loria.fr>
 101
 102 (defvar thing-region (cons 'nil 'nil)
 103   "Cons cell that contains a region (<beginning> . <end>)
 104 The function `thing-region' updates and returns it.")
 105
 106 (defun thing-region (beginning end)
 107   "Make BEGINNING the car and END the cdr of the cons cell in the
 108 variable `thing-region'. Return the updated cons cell"
 109   (cond ((/= beginning end)
 110          (setcar thing-region beginning)
 111          (setcdr thing-region end)
 112          thing-region)))
 113
 114 (defvar thing-bigger-alist
 115   '((word-symbol thing-symbol)
 116     (symbol thing-sexp)
 117     (word-sexp thing-sexp)
 118     (sexp thing-up-sexp)
 119     (sexp-up thing-up-sexp)
 120     (line thing-paragraph)
 121     (paragraph thing-page)
 122     (char thing-word)
 123     (word-sentence thing-sentence)
 124     (sentence thing-paragraph))
 125   "List of pairs to go from one thing to a bigger thing.
 126 See mouse-select-bigger-thing and mouse-delete-bigger-thing.")
 127
 128 (defvar thing-word-next nil
 129   "*The next bigger thing after a word.  A symbol.
 130 Supported values are: word-symbol, word-sexp, and word-sentence.
 131 Default value is word-sentence.
 132 Automatically becomes local when set in any fashion.")
 133 (make-variable-buffer-local 'thing-word-next)
 134
 135 (defun thing-boundaries (here)
 136   "Return start and end of text object at HERE using syntax table and
 137 thing-boundary-alist.  Thing-boundary-alist is a list of pairs of the
 138 form (SYNTAX-CHAR FUNCTION) where FUNCTION takes a single position
 139 argument and returns a cons of places (start end) representing
 140 boundaries of the thing at that position.
 141
 142 Typically:
 143  Left or right Paren syntax indicates an s-expression.
 144  The end of a line marks the line including a trailing newline.
 145  Word syntax indicates current word.
 146  Symbol syntax indicates symbol.
 147  If it doesn't recognize one of these it selects just the character HERE.
 148
 149 If an error occurs  during syntax scanning, the function just prints a
 150 message and returns `nil'."
 151   (interactive "d")
 152   (setq *last-thing* nil)
 153   (if (save-excursion (goto-char here) (eolp))
 154       (thing-get-line here)
 155     (let* ((syntax (char-syntax (char-after here)))
 156            (pair (assq syntax thing-boundary-alist)))
 157       (cond ((and pair
 158                   (or thing-report-whitespace
 159                       (not (eq (car (cdr pair)) 'thing-whitespace))))
 160              (funcall (car (cdr pair)) here))
 161             (thing-report-char-p
 162              (setq *last-thing* 'char)
 163              (thing-region here (1+ here)))
 164             (t
 165              nil)))))
 166
 167
 168
 169 \f
 170 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 171 ;;;;;;;;;;;;;;;;;  Code Delimiters  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 172 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 173
 174 (defun thing-symbol (here)
 175   "Return start and end of symbol at HERE."
 176   (cond ((or (memq (char-syntax (char-after here)) '(?_ ?w))
 177              (and
 178               (memq (char-syntax (char-before here)) '(?_ ?w))
 179               ;; point is at the end of a symbol; look from inside the symbol
 180               (setq here (1- here))))
 181          (setq *last-thing* 'symbol)
 182          (let ((end (scan-sexps here 1)))
 183            (if end
 184                (thing-region (min here (scan-sexps end -1)) end))))))
 185
 186 (defun thing-filename (here)
 187   "Return start and end of filename at HERE."
 188   (cond ((and (memq (char-syntax (char-after here)) '(?w ?_ ?.))
 189               (< here (point-max)))
 190          (let (start end)
 191            (save-excursion
 192              (goto-char here)
 193              (and (re-search-forward "\\s \\|:\\s\"\\|$" nil t)
 194                   (goto-char (setq end (match-beginning 0)))
 195                   (or
 196                    (and
 197                     (re-search-backward "[^_a-zA-Z0-9---#$.~/@]+" nil t)
 198                     (setq start (+ (match-beginning 0)
 199                                    (if (bolp)
 200                                        0
 201                                      1))))
 202                    (setq start (point-min)))
 203                   (thing-region (min start here) (max here end))))))))
 204 ;~/
 205 (defun thing-sexp-start (here)
 206   "Return start and end of sexp starting HERE."
 207   (setq *last-thing* 'sexp-start)
 208   (thing-region here (scan-sexps here 1)))
 209
 210 (defun thing-sexp-end (here)
 211   "Return start and end of sexp ending HERE."
 212   (setq *last-thing* 'sexp-end)
 213   (thing-region (scan-sexps (1+ here) -1) (1+ here)))
 214
 215 (defun thing-sexp (here)
 216   "Return start and end of the sexp at HERE."
 217   (setq *last-thing* 'sexp)
 218   (save-excursion
 219     (goto-char here)
 220     (thing-region (progn (backward-up-list 1) (point))
 221                   (progn (forward-list 1) (point)))))
 222
 223 (defun thing-up-sexp (here)
 224   "Return start and end of the sexp enclosing the selected area."
 225   (setq *last-thing* 'sexp-up)
 226   ;; Keep going up and backward in sexps.  This means that thing-up-sexp
 227   ;; can only be called after thing-sexp or after itself.
 228   (save-excursion
 229     (goto-char here)
 230     (thing-region (progn
 231                     (condition-case ()
 232                         (backward-up-list 1) (error nil))
 233                     (point))
 234                   (progn
 235                     (condition-case ()
 236                         (forward-list 1) (error nil))
 237                     (point)))))
 238
 239 ;;; Allow punctuation marks not followed by white-space to include
 240 ;;; the subsequent sexp. Useful in foo.bar(x).baz and such.
 241 (defun thing-next-sexp (here)
 242   "Return from HERE to the end of the sexp at HERE,
 243 if the character at HERE is part of a sexp."
 244   (setq *last-thing* 'sexp-next)
 245   (if (= (char-syntax (char-after (1+ here))) ? )
 246       (thing-region here (1+ here))
 247     (thing-region here
 248                   (save-excursion (goto-char here) (forward-sexp) (point)))))
 249
 250 ;;; Allow click to comment-char to extend to end of line
 251 (defun thing-comment (here)
 252   "Return rest of line from HERE to newline."
 253   (setq *last-thing* 'comment)
 254   (save-excursion (goto-char here)
 255                   (while (= (char-syntax (preceding-char)) ?<)
 256                     (forward-char -1))
 257                   (thing-region (point) (progn (end-of-line) (point)))))
 258
 259 \f
 260 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 261 ;;;;;;;;;;;;;;;;;  Text Delimiters  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 262 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 263
 264 (defun thing-word (here)
 265   "Return start and end of word at HERE."
 266   (setq *last-thing*
 267         (if thing-word-next
 268             thing-word-next
 269           (setq thing-word-next
 270                 (cond
 271                  ((memq major-mode '(emacs-lisp-mode c-mode c++-mode
 272                                      fortran-mode latex-mode lisp-mode
 273                                      perl-mode tex-mode))
 274                   'word-symbol)
 275                  (t 'word-sentence)))))
 276   (save-excursion
 277     (goto-char here)
 278     (forward-word 1)
 279     (let ((end (point)))
 280       (forward-word -1)
 281       (thing-region (point) end))))
 282
 283 (defun thing-sentence (here)
 284   "Return start and end of the sentence at HERE."
 285   (setq *last-thing* 'sentence)
 286   (save-excursion
 287     (goto-char here)
 288     (thing-region (progn (backward-sentence) (point))
 289                   (progn (forward-sentence) (point)))))
 290
 291 (defun thing-whitespace (here)
 292   "Return start to end of all of whitespace HERE."
 293   (setq *last-thing* 'whitespace)
 294   (save-excursion
 295     (goto-char here)
 296     (let ((start (progn (skip-chars-backward " \t") (1+ (point))))
 297           (end (progn (skip-chars-forward " \t") (point))))
 298       (if (= start end)
 299           (thing-region (1- start) end)
 300         (thing-region start end)))))
 301
 302 \f
 303 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 304 ;;;;;;;;;;;;;;;  Physical Delimiters  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 305 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 306
 307 (defun thing-get-line (here)
 308   "Return whole of line HERE is in, with newline unless at eob."
 309   (setq *last-thing* 'line)
 310   (save-excursion
 311     (goto-char here)
 312     (let* ((start (progn (beginning-of-line 1) (point))))
 313       (thing-region start (point)))))
 314
 315 (defun thing-paragraph (here)
 316   "Return start and end of the paragraph at HERE."
 317   (setq *last-thing* 'paragraph)
 318   (save-excursion
 319     (goto-char here)
 320     (thing-region (progn (backward-paragraph) (point))
 321                   (progn (forward-paragraph) (point)))))
 322
 323 (defun thing-page (here)
 324   "Return start and end of the page at HERE."
 325   (setq *last-thing* 'page)
 326   (save-excursion
 327     (goto-char here)
 328     (thing-region (progn (backward-page) (point))
 329                   (progn (forward-page) (point)))))
 330
 331 \f
 332 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 333 ;;;;;;;;;;;;;;;;  Support functions  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 334 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 335
 336 (defun kill-thing-at-point (here)
 337   "Kill text object using syntax table.
 338 See thing-boundaries for definition of text objects"
 339   (interactive "d")
 340   (let ((bounds (thing-boundaries here)))
 341     (kill-region (car bounds) (cdr bounds))))
 342
 343 (defun copy-thing-at-point (here)
 344   "Copy text object using syntax table.
 345 See thing-boundaries for definition of text objects"
 346   (interactive "d")
 347   (let ((bounds (thing-boundaries here)))
 348     (copy-region-as-kill (car bounds) (cdr bounds))))
 349
 350 ;;; thing.el ends here