home *** CD-ROM | disk | FTP | other *** search
/ ftp.madoka.org / 2014.12.ftp.madoka.org.tar / ftp.madoka.org / pub / irchat-pj / 2.5 / irchat-pj-2.5.6p.tar.gz / irchat-pj-2.5.6p.tar / irchat-pj-2.5.6p / contrib / thingatpt.el < prev   
Lisp/Scheme  |  2000-07-31  |  13KB  |  393 lines
  1. ;;; thingatpt.el --- Get the `thing' at point
  2.  
  3. ;; Copyright (C) 1991,92,93,94,95,96,97,1998 Free Software Foundation, Inc.
  4.  
  5. ;; Author: Mike Williams <mikew@gopher.dosli.govt.nz>
  6. ;; Keywords: extensions, matching, mouse
  7. ;; Created: Thu Mar 28 13:48:23 1991
  8.  
  9. ;; This file is part of GNU Emacs.
  10.  
  11. ;; GNU Emacs is free software; you can redistribute it and/or modify
  12. ;; it under the terms of the GNU General Public License as published by
  13. ;; the Free Software Foundation; either version 2, or (at your option)
  14. ;; any later version.
  15.  
  16. ;; GNU Emacs is distributed in the hope that it will be useful,
  17. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19. ;; GNU General Public License for more details.
  20.  
  21. ;;; Commentary:
  22.  
  23. ;; This file provides routines for getting the "thing" at the location of
  24. ;; point, whatever that "thing" happens to be.  The "thing" is defined by
  25. ;; its beginning and end positions in the buffer.
  26. ;;
  27. ;; The function bounds-of-thing-at-point finds the beginning and end
  28. ;; positions by moving first forward to the end of the "thing", and then
  29. ;; backwards to the beginning.  By default, it uses the corresponding
  30. ;; forward-"thing" operator (eg. forward-word, forward-line).
  31. ;;
  32. ;; Special cases are allowed for using properties associated with the named
  33. ;; "thing": 
  34. ;;
  35. ;;   forward-op        Function to call to skip forward over a "thing" (or
  36. ;;                      with a negative argument, backward).
  37. ;;                      
  38. ;;   beginning-op    Function to call to skip to the beginning of a "thing".
  39. ;;   end-op        Function to call to skip to the end of a "thing".
  40. ;;
  41. ;; Reliance on existing operators means that many `things' can be accessed
  42. ;; without further code:  eg.
  43. ;;     (thing-at-point 'line)
  44. ;;     (thing-at-point 'page)
  45.  
  46. ;;; Code:
  47.  
  48. (provide 'thingatpt)
  49.  
  50. ;; Basic movement
  51.  
  52. ;;;###autoload
  53. (defun forward-thing (thing &optional n)
  54.   "Move forward to the end of the next THING."
  55.   (let ((forward-op (or (get thing 'forward-op)
  56.             (intern-soft (format "forward-%s" thing)))))
  57.     (if (fboundp forward-op)
  58.     (funcall forward-op (or n 1))
  59.       (error "Can't determine how to move over a %s" thing))))
  60.  
  61. ;; General routines
  62.  
  63. ;;;###autoload
  64. (defun bounds-of-thing-at-point (thing)
  65.   "Determine the start and end buffer locations for the THING at point.
  66. THING is a symbol which specifies the kind of syntactic entity you want.
  67. Possibilities include `symbol', `list', `sexp', `defun', `filename', `url',
  68. `word', `sentence', `whitespace', `line', `page' and others.
  69.  
  70. See the file `thingatpt.el' for documentation on how to define
  71. a symbol as a valid THING.
  72.  
  73. The value is a cons cell (START . END) giving the start and end positions
  74. of the textual entity that was found."
  75.   (if (get thing 'bounds-of-thing-at-point)
  76.       (funcall (get thing 'bounds-of-thing-at-point))
  77.     (let ((orig (point)))
  78.       (condition-case nil
  79.       (save-excursion
  80.         ;; Try moving forward, then back.
  81.         (let ((end (progn 
  82.              (funcall 
  83.               (or (get thing 'end-op) 
  84.                   (function (lambda () (forward-thing thing 1)))))
  85.              (point)))
  86.           (beg (progn 
  87.              (funcall 
  88.               (or (get thing 'beginning-op) 
  89.                   (function (lambda () (forward-thing thing -1)))))
  90.              (point))))
  91.           (if (not (and beg (> beg orig)))
  92.           ;; If that brings us all the way back to ORIG,
  93.           ;; it worked.  But END may not be the real end.
  94.           ;; So find the real end that corresponds to BEG.
  95.           (let ((real-end
  96.              (progn 
  97.                (funcall 
  98.                 (or (get thing 'end-op) 
  99.                 (function (lambda () (forward-thing thing 1)))))
  100.                (point))))
  101.             (if (and beg real-end (<= beg orig) (<= orig real-end))
  102.             (cons beg real-end)))
  103.         (goto-char orig)
  104.         ;; Try a second time, moving backward first and then forward,
  105.         ;; so that we can find a thing that ends at ORIG.
  106.         (let ((beg (progn 
  107.                  (funcall 
  108.                   (or (get thing 'beginning-op) 
  109.                   (function (lambda () (forward-thing thing -1)))))
  110.                  (point)))
  111.               (end (progn 
  112.                  (funcall 
  113.                   (or (get thing 'end-op) 
  114.                   (function (lambda () (forward-thing thing 1)))))
  115.                  (point)))
  116.               (real-beg
  117.                (progn 
  118.              (funcall 
  119.               (or (get thing 'beginning-op) 
  120.                   (function (lambda () (forward-thing thing -1)))))
  121.              (point))))
  122.           (if (and real-beg end (<= real-beg orig) (<= orig end))
  123.               (cons real-beg end))))))
  124.     (error nil)))))
  125.  
  126. ;;;###autoload
  127. (defun thing-at-point (thing)
  128.   "Return the THING at point.
  129. THING is a symbol which specifies the kind of syntactic entity you want.
  130. Possibilities include `symbol', `list', `sexp', `defun', `filename', `url',
  131. `word', `sentence', `whitespace', `line', `page' and others.
  132.  
  133. See the file `thingatpt.el' for documentation on how to define
  134. a symbol as a valid THING."
  135.   (if (get thing 'thing-at-point)
  136.       (funcall (get thing 'thing-at-point))
  137.     (let ((bounds (bounds-of-thing-at-point thing)))
  138.       (if bounds 
  139.       (buffer-substring (car bounds) (cdr bounds))))))
  140.  
  141. ;; Go to beginning/end
  142.  
  143. (defun beginning-of-thing (thing)
  144.   (let ((bounds (bounds-of-thing-at-point thing)))
  145.     (or bounds (error "No %s here" thing))
  146.     (goto-char (car bounds))))
  147.  
  148. (defun end-of-thing (thing)
  149.   (let ((bounds (bounds-of-thing-at-point thing)))
  150.     (or bounds (error "No %s here" thing))
  151.     (goto-char (cdr bounds))))
  152.  
  153. ;;  Special cases 
  154.  
  155. ;;  Lines 
  156.  
  157. ;; bolp will be false when you click on the last line in the buffer
  158. ;; and it has no final newline.
  159.  
  160. (put 'line 'beginning-op
  161.      (function (lambda () (if (bolp) (forward-line -1) (beginning-of-line)))))
  162.  
  163. ;;  Sexps 
  164.  
  165. (defun in-string-p ()
  166.   (let ((orig (point)))
  167.     (save-excursion
  168.       (beginning-of-defun)
  169.       (nth 3 (parse-partial-sexp (point) orig)))))
  170.  
  171. (defun end-of-sexp ()
  172.   (let ((char-syntax (char-syntax (char-after (point)))))
  173.     (if (or (eq char-syntax ?\))
  174.         (and (eq char-syntax ?\") (in-string-p)))
  175.     (forward-char 1)
  176.       (forward-sexp 1))))
  177.  
  178. (put 'sexp 'end-op 'end-of-sexp)
  179.  
  180. (defun beginning-of-sexp ()
  181.   (let ((char-syntax (char-syntax (char-before (point)))))
  182.     (if (or (eq char-syntax ?\()
  183.         (and (eq char-syntax ?\") (in-string-p)))
  184.     (forward-char -1)
  185.       (forward-sexp -1))))
  186.  
  187. (put 'sexp 'beginning-op 'beginning-of-sexp)
  188.  
  189. ;;  Lists 
  190.  
  191. (put 'list 'end-op (function (lambda () (up-list 1))))
  192. (put 'list 'beginning-op 'backward-sexp)
  193.  
  194. ;;  Filenames and URLs
  195.  
  196. (defvar thing-at-point-file-name-chars "~/A-Za-z0-9---_.${}#%,:"
  197.   "Characters allowable in filenames.")
  198.  
  199. (put 'filename 'end-op    
  200.      '(lambda () (skip-chars-forward thing-at-point-file-name-chars)))
  201. (put 'filename 'beginning-op
  202.      '(lambda () (skip-chars-backward thing-at-point-file-name-chars)))
  203.  
  204. (defvar thing-at-point-url-path-regexp
  205.   "[^]\t\n \"'()<>[^`{}]*[^]\t\n \"'()<>[^`{}.,;]+"
  206.   "A regular expression probably matching the host, path or e-mail part of a URL.")
  207.  
  208. (defvar thing-at-point-short-url-regexp
  209.   (concat "[-A-Za-z0-9.]+" thing-at-point-url-path-regexp)
  210.   "A regular expression probably matching a URL without an access scheme.
  211. Hostname matching is stricter in this case than for
  212. ``thing-at-point-url-regexp''.")
  213.  
  214. (defvar thing-at-point-url-regexp
  215.   (concat
  216.    "\\(https?://\\|ftp://\\|gopher://\\|telnet://\\|wais://\\|file:/\\|s?news:\\|mailto:\\)"
  217.    thing-at-point-url-path-regexp)
  218.   "A regular expression probably matching a complete URL.")
  219.  
  220. (defvar thing-at-point-markedup-url-regexp
  221.   "<URL:[^>]+>"
  222.   "A regular expression matching a URL marked up per RFC1738.
  223. This may contain whitespace (including newlines) .")
  224.  
  225. (put 'url 'bounds-of-thing-at-point 'thing-at-point-bounds-of-url-at-point)
  226. (defun thing-at-point-bounds-of-url-at-point ()
  227.   (let ((url "") short strip)
  228.     (if (or (setq strip (thing-at-point-looking-at
  229.              thing-at-point-markedup-url-regexp))
  230.         (thing-at-point-looking-at thing-at-point-url-regexp)
  231.         ;; Access scheme omitted?
  232.         (setq short (thing-at-point-looking-at
  233.              thing-at-point-short-url-regexp)))
  234.     (let ((beginning (match-beginning 0))
  235.           (end (match-end 0)))
  236.       (cond (strip
  237.          (setq beginning (+ beginning 5))
  238.          (setq end (- end 1))))
  239.       (cons beginning end)))))
  240.  
  241. (put 'url 'thing-at-point 'thing-at-point-url-at-point)
  242. (defun thing-at-point-url-at-point ()
  243.   "Return the URL around or before point.
  244.  
  245. Search backwards for the start of a URL ending at or after point.  If
  246. no URL found, return nil.  The access scheme will be prepended if
  247. absent: \"mailto:\" if the string contains \"@\", \"ftp://\" if it
  248. starts with \"ftp\" and not \"ftp:/\", or \"http://\" by default."
  249.  
  250.   (let ((url "") short strip)
  251.     (if (or (setq strip (thing-at-point-looking-at
  252.              thing-at-point-markedup-url-regexp))
  253.         (thing-at-point-looking-at thing-at-point-url-regexp)
  254.         ;; Access scheme omitted?
  255.         (setq short (thing-at-point-looking-at
  256.              thing-at-point-short-url-regexp)))
  257.     (progn
  258.       (setq url (buffer-substring-no-properties (match-beginning 0)
  259.                             (match-end 0)))
  260.       (and strip (setq url (substring url 5 -1))) ; Drop "<URL:" & ">"
  261.       ;; strip whitespace
  262.       (while (string-match "\\s +\\|\n+" url)
  263.         (setq url (replace-match "" t t url)))
  264.       (and short (setq url (concat (cond ((string-match "@" url)
  265.                                               "mailto:")
  266.                          ;; e.g. ftp.swiss... or ftp-swiss...
  267.                                              ((string-match "^ftp" url)
  268.                                               "ftp://")
  269.                                              (t "http://"))
  270.                                        url)))
  271.       (if (string-equal "" url)
  272.           nil
  273.         url)))))
  274.  
  275. ;; The normal thingatpt mechanism doesn't work for complex regexps.
  276. ;; This should work for almost any regexp wherever we are in the
  277. ;; match.  To do a perfect job for any arbitrary regexp would mean
  278. ;; testing every position before point.  Regexp searches won't find
  279. ;; matches that straddle the start position so we search forwards once
  280. ;; and then back repeatedly and then back up a char at a time.
  281.  
  282. (defun thing-at-point-looking-at (regexp)
  283.   "Return non-nil if point is in or just after a match for REGEXP.
  284. Set the match data from the earliest such match ending at or after
  285. point."
  286.   (save-excursion
  287.     (let ((old-point (point)) match)
  288.       (and (looking-at regexp)
  289.        (>= (match-end 0) old-point)
  290.        (setq match (point)))
  291.       ;; Search back repeatedly from end of next match.
  292.       ;; This may fail if next match ends before this match does.
  293.       (re-search-forward regexp nil 'limit)
  294.       (while (and (re-search-backward regexp nil t)
  295.           (or (> (match-beginning 0) old-point)
  296.               (and (looking-at regexp)    ; Extend match-end past search start
  297.                (>= (match-end 0) old-point)
  298.                (setq match (point))))))
  299.       (if (not match) nil
  300.     (goto-char match)
  301.     ;; Back up a char at a time in case search skipped
  302.     ;; intermediate match straddling search start pos.
  303.     (while (and (not (bobp))
  304.             (progn (backward-char 1) (looking-at regexp))
  305.             (>= (match-end 0) old-point)
  306.             (setq match (point))))
  307.     (goto-char match)
  308.     (looking-at regexp)))))
  309.  
  310. (put 'url 'end-op
  311.      (function (lambda ()
  312.          (let ((bounds (thing-at-point-bounds-of-url-at-point)))
  313.            (if bounds
  314.                (goto-char (cdr bounds))
  315.              (error "No URL here"))))))
  316. (put 'url 'beginning-op
  317.      (function (lambda ()
  318.          (let ((bounds (thing-at-point-bounds-of-url-at-point)))
  319.            (if bounds
  320.                (goto-char (car bounds))
  321.              (error "No URL here"))))))
  322.  
  323. ;;  Whitespace 
  324.  
  325. (defun forward-whitespace (arg)
  326.   (interactive "p")
  327.   (if (natnump arg) 
  328.       (re-search-forward "[ \t]+\\|\n" nil 'move arg)
  329.     (while (< arg 0)
  330.       (if (re-search-backward "[ \t]+\\|\n" nil 'move)
  331.       (or (eq (char-after (match-beginning 0)) 10)
  332.           (skip-chars-backward " \t")))
  333.       (setq arg (1+ arg)))))
  334.  
  335. ;;  Buffer 
  336.  
  337. (put 'buffer 'end-op '(lambda () (goto-char (point-max))))
  338. (put 'buffer 'beginning-op '(lambda () (goto-char (point-min))))
  339.  
  340. ;;  Symbols 
  341.  
  342. (defun forward-symbol (arg)
  343.   (interactive "p")
  344.   (if (natnump arg) 
  345.       (re-search-forward "\\(\\sw\\|\\s_\\)+" nil 'move arg)
  346.     (while (< arg 0)
  347.       (if (re-search-backward "\\(\\sw\\|\\s_\\)+" nil 'move)
  348.       (skip-syntax-backward "w_"))
  349.       (setq arg (1+ arg)))))
  350.  
  351. ;;  Syntax blocks 
  352.  
  353. (defun forward-same-syntax (&optional arg)
  354.   (interactive "p")
  355.   (while (< arg 0)
  356.     (skip-syntax-backward 
  357.      (char-to-string (char-syntax (char-after (1- (point))))))
  358.     (setq arg (1+ arg)))
  359.   (while (> arg 0)
  360.     (skip-syntax-forward (char-to-string (char-syntax (char-after (point)))))
  361.     (setq arg (1- arg))))
  362.  
  363. ;;  Aliases 
  364.  
  365. (defun word-at-point () (thing-at-point 'word))
  366. (defun sentence-at-point () (thing-at-point 'sentence))
  367.  
  368. (defun read-from-whole-string (str)
  369.   "Read a lisp expression from STR.
  370. Signal an error if the entire string was not used."
  371.   (let* ((read-data (read-from-string str))
  372.      (more-left 
  373.       (condition-case nil
  374.           (progn (read-from-string (substring str (cdr read-data)))
  375.              t)
  376.         (end-of-file nil))))
  377.     (if more-left
  378.     (error "Can't read whole string")
  379.       (car read-data))))
  380.  
  381. (defun form-at-point (&optional thing pred) 
  382.   (let ((sexp (condition-case nil 
  383.           (read-from-whole-string (thing-at-point (or thing 'sexp)))
  384.         (error nil))))
  385.     (if (or (not pred) (funcall pred sexp)) sexp)))
  386.  
  387. (defun sexp-at-point ()   (form-at-point 'sexp))
  388. (defun symbol-at-point () (form-at-point 'sexp 'symbolp))
  389. (defun number-at-point () (form-at-point 'sexp 'numberp))
  390. (defun list-at-point ()   (form-at-point 'list 'listp))
  391.  
  392. ;; thingatpt.el ends here.
  393.