;; $Id: tags.el,v 1.14 1992/08/25 17:28:36 kendall Exp $

;; Tags facility for Emacs.
;; Copyright (C) 1985, 1986, 1988 Free Software Foundation, Inc.

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY.  No author or distributor
;; accepts responsibility to anyone for the consequences of using it
;; or for whether it serves any particular purpose or works at all,
;; unless he says so in writing.  Refer to the GNU Emacs General Public
;; License for full details.

;; Everyone is granted permission to copy, modify and redistribute
;; GNU Emacs, but only under the conditions described in the
;; GNU Emacs General Public License.   A copy of this license is
;; supposed to have been given to you along with GNU Emacs so you
;; can know your rights and responsibilities.  It should be in a
;; file named COPYING.  Among other things, the copyright notice
;; and this notice must be preserved on all copies.

;; This version is maintained by Sam Kendall, CenterLine Software Inc.,
;; 10 Fawcett Street, Cambridge, MA 02138 USA.  Email is
;; kendall@CenterLine.COM or uunet!saber!kendall.

;; NOTE:
;; 	"Quick fix" inserted for C users.  The problem is that in the tags line
;;
;;		typedef char *string^?...
;;
;;	`string' won't be an exact match, because the `*' is a word character
;;	in the TAGS buffer (although not in a C source file).  The quick fix is
;;	in tag-exact-match-p; look for "HACK 7/19/89". -kendall@centerline.com

(provide 'tags)

;; Tag table state.

(defun initialize-new-tag-table ()
  "Call when the tag table changes."
  (setq tag-table-files nil
	find-tag-state nil
	tag-order nil
	tag-lines-already-matched nil)
  (make-local-variable 'tags-completion-alist))

(defun save-tags-state ()
  "Returns an object that can later be passed to `restore-tags-state'."
  (vector tag-order
	  tag-lines-already-matched
	  tag-table-files
	  find-tag-state
	  next-file-list))

(defun restore-tags-state (state)
  "Restore from an object created by `save-tags-state'."
  (setq tag-order (aref state 0)
	tag-lines-already-matched (aref state 1)
	tag-table-files (aref state 2)
	find-tag-state (aref state 3)
	next-file-list (aref state 4)))

(defvar tag-order nil
  "List of functions to use in partitioning the set of tag matches.")

(defvar tag-lines-already-matched nil
  "List of lines within the tag table that are already matched.")

(defvar tag-table-files nil
  "List of file names covered by current tags table.
nil means it has not been computed yet; do (tag-table-files) to compute it.")

(defvar tags-completion-alist nil
  "Alist of tag names defined in current tags table.")

(defvar find-tag-state nil
  "Some of the state of the last find-tag, find-tag-other-window, or
find-tag-regexp.  This is a vector whose 0th element is the last tagname
or regexp used.")

(defvar tags-table-file-list nil
  "Alist of tags table file names for \\[select-tags-table].
Each element is a list containing one element, a file name.
Any tags table file you visit is automatically added to this list.
You can also add names yourself.")

(defvar next-file-list nil
  "List of files for \\[next-file] to process.")



(defun visit-tags-table (file)
  "Tell tags commands to use tags table file FILE.
FILE should be the name of a file created with the `etags' program.
A directory name is ok too; it means file TAGS in that directory."
  (interactive (list (read-file-name "Visit tags table: (default TAGS) "
				     default-directory
				     (expand-file-name "TAGS" default-directory)
				     t)))
  (setq file (expand-file-name file default-directory))
  (if (file-directory-p file)
      (setq file (expand-file-name "TAGS" file)))
  ;; Add an element to TAGS-TABLE-FILE-LIST.
  (or (assoc file tags-table-file-list)
      (setq tags-table-file-list
	    (cons (list file) tags-table-file-list)))
  (setq tags-file-name file)
  (save-excursion
    (visit-tags-table-buffer)
    (initialize-new-tag-table)		;; must occur within correct buffer
    (or tags-completion-alist
	(setq tags-completion-alist (tags-completion-alist)))))

(defun visit-tags-table-buffer ()
  "Select the buffer containing the current tags table.
This is a file whose name is in the variable tags-file-name."
  (or tags-file-name
      (call-interactively 'visit-tags-table))
  (set-buffer (or (get-file-buffer tags-file-name)
		  (progn
		    (initialize-new-tag-table)
		    (find-file-noselect tags-file-name))))
  (or (verify-visited-file-modtime (get-file-buffer tags-file-name))
      (cond ((yes-or-no-p "Tags file has changed, read new contents? ")
	     (revert-buffer t t)
	     (initialize-new-tag-table)
	     (setq tags-completion-alist (tags-completion-alist)))))
  (or (eq (char-after 1) ?\^L)
      (error "File %s not a valid tag table" tags-file-name)))

(defun file-of-tag ()
  "Return the file name of the file whose tags point is within.
Assumes the tag table is the current buffer.
File name returned is relative to tag table file's directory."
  (save-excursion
    (search-backward "\f\n")
    (forward-char 2)
    (buffer-substring (point)
		      (progn (skip-chars-forward "^,") (point)))))

(defun tag-table-files ()
  "Return a list of files in the current tag table.
File names returned are absolute."
  (or tag-table-files
      (save-excursion
	(visit-tags-table-buffer)
	(let (files)
	  (goto-char (point-min))
	  (while (search-forward "\f\n" nil t)
	    (setq files (cons (expand-file-name
				(buffer-substring
				  (point)
				  (progn (skip-chars-forward "^,\n") (point)))
				(file-name-directory tags-file-name))
			      files)))
	  (setq tag-table-files (nreverse files))))))

(defun tags-completion-alist ()
  "Return an alist of tags in the current buffer, which is a tag table."
  (let (alist next)
    (message "Making tags completion alist...")
    (save-excursion
      (goto-char (point-min))
	(while (search-forward "\177" nil t)
	  (if (save-excursion
		(skip-chars-forward "^\001\n")
		(setq next (1+ (point)))
		(= (following-char) ?\001))
	      ;;; If there are ^A's, get tags after them.
	      (progn
		(goto-char next)	;; after the first ^A
		(while (= (preceding-char) ?\001)
		  (setq alist
			(cons (cons (buffer-substring
				     (point)
				     (progn (skip-chars-forward "^\001\n")
					    (point)))
				    nil)
			      alist))
		  (forward-char 1)))
	    ;;; If no ^A's, get tags from before the ^?.
	    (skip-chars-backward "^-A-Za-z0-9_$\n")
	    (or (bolp)
		(setq alist
		      (cons (cons (buffer-substring
				   (point)
				   (progn
				     (skip-chars-backward "-A-Za-z0-9_$")
				     ;;; `::' in the middle of a C++ tag.
				     (while (and (= (preceding-char) ?:)
						 (= (char-after (- (point) 2)) ?:))
				       (progn (backward-char 2)
					      (skip-chars-backward
					       "-A-Za-z0-9_$")))
				     (point)))
				  nil)
			    alist)))
	    (goto-char next)		; next line
	    )))
    (message "Making tags completion alist...done")
    alist))

(defun prompt-for-tag (prompt)
  "Prompt for a tag to find.  Default is determined by find-tag-default."
  (let* ((default (find-tag-default))
	 (alist (save-excursion (visit-tags-table-buffer)
				tags-completion-alist))
	 (spec (completing-read
		(if default
		    (format "%s(default %s) " prompt default)
		  prompt)
		;;; completing-read craps out if given a nil table
		(or alist '((""))))))
    (if (equal spec "")
	(or default (error "There is no default tag."))
      spec)))

;; Return a default tag to search for, based on the text at point, or nil.
(defun find-tag-default ()
  (save-excursion
    (while (looking-at "\\sw\\|\\s_")
      (forward-char 1))
    (if (re-search-backward "\\sw\\|\\s_" nil t)
	(progn (forward-char 1)
	       (buffer-substring (point)
				 (progn (forward-sexp -1)
					(while (looking-at "\\s'")
					  (forward-char 1))
					(point))))
      nil)))

(defun find-tag (tagname &optional next-p other-window regexp-p)
  "Find tag (in current tag table) whose name contains TAGNAME;
more exact matches are found first.
Select the buffer containing the tag's definition and move point there.
The default for TAGNAME is the expression in the buffer after or around point.

If second arg NEXT-P is non-nil (interactively, with prefix arg), search
for another tag that matches the last tagname or regexp used.

If third arg OTHER-WINDOW is non-nil, select the buffer in another window.

If fourth arg REGEXP-P is non-nil, treat TAGNAME as a regexp.

See documentation of variable `tags-file-name'."
  (interactive (if current-prefix-arg
		   '(nil t)
		   (list (prompt-for-tag "Find tag: "))))
  (cond
   (next-p (find-tag-in-order nil nil nil nil nil other-window))
   (regexp-p (find-tag-in-order tagname
				're-search-forward
				'(tag-re-match-p)
				t
				"matching"
				other-window))
   (t (find-tag-in-order
       tagname
       'search-forward
       '(tag-exact-match-p tag-word-match-p tag-any-match-p)
       nil
       "containing"
       other-window))))

(defun find-tag-other-window (tagname &optional next-p)
  "Find tag (in current tag table) whose name contains TAGNAME;
more exact matches are found first.
Select the buffer containing the tag's definition
in another window, and move point there.
The default for TAGNAME is the expression in the buffer around or before point.

If second arg NEXT-P is non-nil (interactively, with prefix arg), search
for another tag that matches the last tagname used.

See documentation of variable `tags-file-name'."
  (interactive (if current-prefix-arg
		   '(nil t)
		   (list (prompt-for-tag "Find tag other window: "))))
  (find-tag tagname next-p t))

(defun find-tag-regexp (regexp &optional next-p other-window)
  "Find tag (in current tag table) whose name matches REGEXP.
Select the buffer containing the tag's definition and move point there.

If second arg NEXT-P is non-nil (interactively, with prefix arg), search
for another tag that matches the last tagname used.

If third arg OTHER-WINDOW is non-nil, select the buffer in another window.

See documentation of variable `tags-file-name'."
  (interactive (if current-prefix-arg
		   '(nil t)
		 (list (read-string "Find tag regexp: "))))
  (find-tag regexp next-p other-window t))

(defun find-tag-in-order
  (pattern search-forward-func order next-line-after-failure-p matching other-window)
  "Internal tag finding function.  PATTERN is a string to pass to
second arg SEARCH-FORWARD-FUNC, and to any member of the function list
ORDER (third arg).  If ORDER is nil, use saved state to continue a
previous search.

Fourth arg MATCHING is a string, an English '-ing' word, to be used in
an error message.

Fifth arg NEXT-LINE-AFTER-FAILURE-P is non-nil if after a failed match,
point should be moved to the next line.

If sixth arg OTHER-WINDOW is non-nil, select the buffer in another window.

Algorithm is as follows.  For each qualifier-func in ORDER, go to
beginning of tags file, and perform inner loop: for each naive match for
PATTERN found using SEARCH-FORWARD-FUNC, qualify the naive match using
qualifier-func.  If it qualifies, go to the specified line in the
specified source file and return.  Qualified matches are remembered to
avoid repetition.  State is saved so that the loop can be continued."
  (let (file linebeg startpos)
    (save-excursion
      (visit-tags-table-buffer)
      (if order
	  (progn
	    ;; Save state.
	    (setq find-tag-state (vector pattern search-forward-func matching)
		  tag-order order
		  tag-lines-already-matched nil)
	    ;; Start at beginning of tags file.
	    (goto-char (point-min)))
	(progn
	  ;; Restore state.
	  (setq pattern (aref find-tag-state 0)
		search-forward-func (aref find-tag-state 1)
		matching (aref find-tag-state 2))))

      ;; Get a qualified match.
      (catch 'qualified-match-found
	(while (car tag-order)
	  (while (funcall search-forward-func pattern nil t)
	    ;; Naive match found.
	    (if (and
		 ;; Qualify the match.
		 (funcall (car tag-order) pattern)
		 ;; Make sure it is not a previous qualified match.
		 ;; Use of `memq' depends on numbers being eq.
		 (not (memq (save-excursion (beginning-of-line) (point))
			    tag-lines-already-matched)))
		(throw 'qualified-match-found nil))
	    (if next-line-after-failure-p (forward-line 1)))
	  (setq tag-order (cdr tag-order))
	  (goto-char (point-min)))
	(error "No %stags %s %s" (if order "" "more ") matching pattern))

      ;; Found a tag; extract location info.
      (beginning-of-line)
      (setq tag-lines-already-matched (cons (point) tag-lines-already-matched))
      (search-forward "\177")
      (setq file (expand-file-name (file-of-tag)
				   (file-name-directory tags-file-name)))
      (setq linebeg
	    (buffer-substring (1- (point))
			      (save-excursion (beginning-of-line) (point))))
      (search-forward ",")
      (setq startpos (string-to-int (buffer-substring
				      (point)
				      (progn (skip-chars-forward "0-9")
					     (point)))))
      ;; Leave point on next line of tags file.
      (forward-line 1))

    ;; Find the right line in the specified file.
    (if other-window
	(find-file-other-window file)
      (find-file file))
    (widen)
    (push-mark)
    (let ((offset 16)	;; this constant is 1/2 the initial search window
	  found
	  (pat (concat "^" (regexp-quote linebeg))))
      (or startpos (setq startpos (point-min)))
      (while (and (not found)
		  (progn
		   (goto-char (- startpos offset))
		   (not (bobp))))
	(setq found
	      (re-search-forward pat (+ startpos offset) t))
	(setq offset (* 4 offset)))	;; expand search window
      (or found
	  (re-search-forward pat nil t)
	  (error "\"%s\" not found in %s; time to rerun etags" pat file)))
    (beginning-of-line))
  (setq tags-loop-form '(find-tag-in-order nil nil nil nil nil nil))
  ;; Return t in case used as the tags-loop-form.
  t)

;;; Match qualifier functions for tagnames.

(defun tag-exact-match-p (tag)
  "Did we find an exact match for TAG?  Assume point is in a tags file,
immediately after an occurence of TAG."
  (let ((tag-length (length tag)))
    (or (and (looking-at "[ \t();,]?\177")
	     (save-excursion (backward-char tag-length)
			     (or (bolp)
				 (let ((c (preceding-char)))
				   (or (= c ? ) (= c ?\t)
				       (= c ?*)	;; HACK 7/19/89
				       )))))
	(and (looking-at "[\001\n]")
	     (save-excursion (backward-char tag-length)
			     (= (preceding-char) ?\001))))))

(defun tag-word-match-p (tag)
  "Did we find a word match for TAG?  Assume point is in a tags file,
immediately after an occurence of TAG."
  (let ((tag-length (length tag)))
    (or (and (looking-at "\\b.*\177")
	     (save-excursion (backward-char tag-length)
			     (looking-at "\\b")))
	(and (looking-at "\\b.*[\001\n]")
	     (save-excursion (backward-char tag-length)
			     (and
			      (looking-at "\\b")
			      (progn
				(skip-chars-backward "^\001\n")
				(= (preceding-char) ?\001))))))))

(defun tag-any-match-p (tag)
  "Did we find any match for TAG?  Assume point is in a tags file,
immediately after an occurence of TAG."
  (or (looking-at ".*\177")
      (save-excursion
	(backward-char (length tag))
	(skip-chars-backward "^\001\n")
	(= (preceding-char) ?\001))))

;;; Match qualifier function for regexps.

(defun tag-re-match-p (re)
  "Is point (in a tags file) on a line with a match for RE?"
  (save-excursion
    (beginning-of-line)
    (catch 'done
      (let* ((bol (point))
	     (eol (save-excursion (end-of-line) (point)))
	     (del (save-excursion (if (search-forward "\177" eol t)
				      (point)
				    (throw 'done nil)))))
	 (if (search-forward "\001" eol t)
	     ;; There are ^A's: try to match in each tag after a ^A
	     (let ((bot (point))
		   eot)
	       (while (< bot eol)
		 (save-excursion
		   (setq eot (if (search-forward "\001" eol t)
				    (1- (point))
				  eol))
		   (if (re-search-forward re eot t)
		       (throw 'done t))
		   (setq bot (1+ eot))
		   (goto-char bot))))
	   ;; No ^A: try to match the line before the ^?
	   (goto-char bol)
	   (re-search-forward re (1- del) t))))))

(defun next-file (&optional initialize)
  "Select next file among files in current tag table.
Non-nil argument (prefix arg, if interactive)
initializes to the beginning of the list of files in the tag table."
  (interactive "P")
  (if initialize
      (setq next-file-list (tag-table-files)))
  (or next-file-list
      (error "All files processed."))
  (find-file (car next-file-list))
  (setq next-file-list (cdr next-file-list)))

(defvar tags-loop-form nil
  "Form for tags-loop-continue to eval to process one file.
If it returns nil, it is through with one file; move on to next.")

(defun tags-loop-continue (&optional first-time)
  "Continue last \\[find-tag], \\[tags-search], or
\\[tags-query-replace] command.  Used noninteractively with non-nil
argument to begin such a command.  See variable `tags-loop-form'."
  (interactive)
  (if first-time
      (progn (next-file t)
	     (goto-char (point-min))))
  (while (not (eval tags-loop-form))
    (next-file)
    (message "Scanning file %s..." buffer-file-name)
    (goto-char (point-min))))

(defun tags-search (regexp)
  "Search through all files listed in tag table for match for REGEXP.
Stops when a match is found.
To continue searching for next match, use command \\[tags-loop-continue].

See documentation of variable tags-file-name."
  (interactive "sTags search (regexp): ")
  (if (and (equal regexp "")
	   (eq (car tags-loop-form) 're-search-forward))
      (tags-loop-continue nil)
    (setq tags-loop-form
	  (list 're-search-forward regexp nil t))
    (tags-loop-continue t)))

(defun tags-query-replace (from to)
  "Query-replace-regexp FROM with TO through all files listed in tag table.
If you exit (C-G or ESC), you can resume the query-replace
with the command \\[tags-loop-continue].

See documentation of variable tags-file-name."
  (interactive "sTags query replace (regexp): \nsTags query replace %s by: ")
  (setq tags-loop-form
	(list 'and (list 'save-excursion
			 (list 're-search-forward from nil t))
	      (list 'not (list 'perform-replace from to t t nil))))
  (tags-loop-continue t))

(defun list-tags (string)
  "Display list of tags in file FILE.
FILE should not contain a directory spec
unless it has one in the tag table."
  (interactive "sList tags (in file): ")
  (with-output-to-temp-buffer "*Tags List*"
    (princ "Tags in file ")
    (princ string)
    (terpri)
    (save-excursion
     (visit-tags-table-buffer)
     (goto-char 1)
     (search-forward (concat "\f\n" string ","))
     (forward-line 1)
     (while (not (looking-at "\f"))
       (princ (buffer-substring (point)
				(progn (skip-chars-forward "^\177")
				       (point))))
       (terpri)
       (forward-line 1)))))

(defun tags-apropos (string)
  "Display list of all tags in tag table REGEXP matches."
  (interactive "sTag apropos (regexp): ")
  (with-output-to-temp-buffer "*Tags List*"
    (princ "Tags matching regexp ")
    (prin1 string)
    (terpri)
    (save-excursion
     (visit-tags-table-buffer)
     (goto-char 1)
     (while (re-search-forward string nil t)
       (beginning-of-line)
       (princ (buffer-substring (point)
				(progn (skip-chars-forward "^\177")
				       (point))))
       (terpri)
       (forward-line 1)))))

(defun select-tags-table ()
  "Select a tags table file from a menu of those you have already used.
The list of tags tables to select from is stored in `tags-table-file-list';
see the doc of that variable if you want to add names to the list."
  (interactive)
  (switch-to-buffer "*Tags Table List*")
  (erase-buffer)
  (let ((list tags-table-file-list))
    (while list
      (insert (car (car list)) "\n")
      (setq list (cdr list))))
  (goto-char 1)
  (insert "Type `t' to select a tag table:\n\n")
  (set-buffer-modified-p nil)
  (let ((map (make-sparse-keymap)))
    (define-key map "t" 'select-tags-table-select)
    (use-local-map map)))
  
(defun select-tags-table-select ()
  "Select the tag table named on this line."
  (interactive)
  (let ((name (buffer-substring (point)
				(save-excursion (end-of-line) (point)))))
    (visit-tags-table name)
    (message "Tag table now %s" name)))
