;; Special enhanced Tags facility for C++ in Emacs. ;; Copyright (C) 1985, 1986 Free Software Foundation, Inc. ;; This file is part of GNU Emacs. ;; 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 is "c++-browse.el", original file name was "browse.el" ;; by yacko@hpsdeb.sde.hp.com, adapted to Emacs 18.57 tags.el by ;; G. Teege (teege@informatik.tu-muenchen.de). ;; ;; Loading this file redefines the commands ;; visit-tags-file ;; find-tag ;; find-tag-other-window ;; tags-search ;; tags-query-replace ;; list-tags ;; tags-apropos ;; and adds the commands ;; find-tag-at-caller ;; find-last-tag-at-caller ;; find-tag-callerlist ;; find-tag-next-caller ;; find-class-hierarchy ;; find-class ;; find-class-other-window ;; find-class-subclasslist ;; find-class-next-subclass ;; find-instance ;; find-instance-other-window ;; find-class-instlist ;; find-class-next-instance ;; ;; Note that c++-browse.el uses its own format of TAGS files. This ;; format is generated by using the -b option in the call to etags. ;; Example: etags -b *.[Ch] ;; If your etags doesn't understand the -b option, replace it by that ;; version of etags distributed with this file. ;; c++-browse can not be used with normal emacs TAGS files. So you ;; should not load this file when you want to use the tags commands ;; for other languages than C++. To switch back to normal tags format ;; after using c++-browse simply do ;; M-x load-library RET tags RET ;; ; ; who when what ; ---------- -------- ----------------------------------------------- ; mnastvog 01.03.1996 Added browsing functionality for subroutines ; Changed expected location of TAGS file from "." to ".." (defvar tag-table-files nil "List of file names covered by current tag table. nil means it has not been computed yet; do (tag-table-files) to compute it.") (defvar last-tag nil "Tag found by the last command.") (defvar last-caller nil "Tag found by the last caller-related command.") (defvar last-class nil "Tag found by the last class-related command.") (defvar last-subclass nil "Tag found by the last subclassr-related command.") (defvar last-instance nil "Tag found by the last instance-related command.") (defun visit-tags-table (file) "Tell tags commands to use tag table file FILE. You are using the special version of the tags commands defined by c++-browse. FILE should be the name of a file created with the `etags -b' program. A directory name is ok too; it means file TAGS in that directory." (interactive (list (read-file-name "Visit tags table: (default TAGS) " (concat default-directory "../") (concat default-directory "../TAGS") t))) (setq file (expand-file-name file)) (if (file-directory-p file) (setq file (concat file "TAGS"))) (setq tag-table-files nil tags-file-name file)) (defun visit-tags-table-buffer () "Select the buffer containing the current tag 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 (setq tag-table-files nil) (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) (setq tag-table-files nil)))) (or (eq (char-after 1) ?\^L) (setq tags-file-name nil) ;; when not a valid tags table (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." (let ((opoint (point)) prev size) (save-excursion (goto-char (point-min)) (while (< (point) opoint) (forward-line 1) (end-of-line) (skip-chars-backward "^,\n") (setq prev (point)) (setq size (read (current-buffer))) (goto-char prev) (forward-line 1) (forward-char size)) (goto-char (1- prev)) (buffer-substring (point) (progn (beginning-of-line) (point)))))) (defun tag-table-files () "Return a list of files in the current tag table. File names returned are absolute." (save-excursion (visit-tags-table-buffer) (or tag-table-files (let (files) (goto-char (point-min)) (while (not (eobp)) (forward-line 1) (end-of-line) (skip-chars-backward "^,\n") (setq prev (point)) (setq size (read (current-buffer))) (goto-char prev) (setq files (cons (expand-file-name (buffer-substring (1- (point)) (save-excursion (beginning-of-line) (point))) (file-name-directory tags-file-name)) files)) (forward-line 1) (forward-char size)) (setq tag-table-files (nreverse files)))))) ;; Return a default tag to search for, based on the text at point. (defun find-tag-default () (save-excursion (modify-syntax-entry ?: "_") ; because ::x is a tag in c++ (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-tag (string) (let* ((default (find-tag-default)) (spec (read-string (if default (format "%s(default %s) " string default) string)))) (list (if (equal spec "") default spec)))) (defun find-tag (tagname &optional next other-window stype) "Find tag (in current tag table) whose name contains TAGNAME. Selects the buffer that the tag is contained in and puts point at its definition. If TAGNAME is a null string, the expression in the buffer around or before point is used as the tag name. If second arg NEXT is non-nil (interactively, with prefix arg), searches for the next tag in the tag table that matches the tagname used in the previous find-tag. See documentation of variable tags-file-name." (interactive (if current-prefix-arg '(nil t) (find-tag-tag "Find tag: "))) (vlt-push-bookmark) (let (buffer file linebeg startpos testchar) (save-excursion (visit-tags-table-buffer) (if stype (setq testchar stype) (setq testchar ",")) (if (not next) (goto-char (point-min)) (setq tagname last-tag)) (setq last-tag tagname) (while (progn (re-search-forward (concat "^" tagname "\177")) (not (if stype (save-excursion (end-of-line) (search-backward ",") (goto-char (1- (point))) (looking-at testchar)) (save-excursion (end-of-line) (goto-char (1- (point))) (looking-at testchar)))))) (beginning-of-line))) (open-tag-callerline nil) (setq tags-loop-form (list 'find-tag nil t other-window stype)) ;; Return t in case used as the tags-loop-form. t) (defun find-tag-other-window (tagname &optional next) "Find tag (in current tag table) whose name contains TAGNAME. Selects the buffer that the tag is contained in in another window and puts point at its definition. If TAGNAME is a null string, the expression in the buffer around or before point is used as the tag name. If second arg NEXT is non-nil (interactively, with prefix arg), searches for the next tag in the tag table that matches the tagname used in the previous find-tag. See documentation of variable tags-file-name." (interactive (if current-prefix-arg '(nil t) (find-tag-tag "Find tag other window: "))) (find-tag tagname next t nil)) ; t is for other window parm (deleted) (defvar next-file-list nil "List of files for next-file to process.") (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 \\[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 &optional delimited) "Query-replace-regexp FROM with TO through all files listed in tag table. Third arg DELIMITED (prefix arg) means replace only word-delimited matches. 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: \nP") (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 (not (null delimited)))))) (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 (or (eobp) (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) (if (save-excursion (end-of-line) (goto-char (1- (point))) (looking-at ",")) (progn (princ (buffer-substring (point) (progn (skip-chars-forward "^\177") (point)))) (terpri))) (forward-line 1))))) (defun match-tag-and-caller (tagname callername) (let (tempstring (found-tag t) (found-match nil)) (visit-tags-table-buffer) (goto-char (point-min)) (setq tagname (concat "^" (regexp-quote tagname) "\177")) (while (and found-tag (not found-match)) (if (setq found-tag (re-search-forward tagname nil t)) (setq found-match (progn (end-of-line) (search-backward ",") (setq tempstring (buffer-substring (1+ (point)) (progn (end-of-line) (point)))) (end-of-line) (search-backward ",") (goto-char (1- (point))) (and (looking-at "f") (string-equal tempstring callername))))) (end-of-line)) (beginning-of-line) (or found-match (progn (setq last-caller nil) (error "No tag and caller match") nil)))) (defun match-tag-not-caller (tagname callername) (let (tempstring (found-tag t) (found-match nil)) (visit-tags-table-buffer) (setq tagname (concat "^" (regexp-quote tagname) "\177")) (while (and found-tag (not found-match)) (if (setq found-tag (re-search-forward tagname nil t)) (setq found-match (progn (end-of-line) (search-backward ",") (setq tempstring (buffer-substring (1+ (point)) (progn (end-of-line) (point)))) (end-of-line) (search-backward ",") (goto-char (1- (point))) (and (looking-at "f") (not (equal tempstring "")) (not (string-equal tempstring callername)))))) (end-of-line)) (beginning-of-line) (or found-match (setq tempstring (progn (setq last-caller nil) (error "No next caller for tag") nil))) ; Return the name of the new caller tempstring)) ;XXX (defun open-tag-callerline (other-window) (let (file startpos linebeg) (save-excursion (visit-tags-table-buffer) (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) (save-excursion (search-forward ",") (1- (point))))))) (if other-window (find-file-other-window file) (find-file file)) (widen) (push-mark) (let ((offset 80) found (pat (regexp-quote linebeg))) (or startpos (setq startpos (point-min))) (setq startpos (+ startpos offset)) (while (and (not found) (progn (goto-char (- startpos offset)) (not (bobp)))) (setq found (re-search-forward pat (+ startpos offset) t)) (setq offset (+ 80 offset))) (or found (re-search-forward pat))))) (defun find-tag-at-caller (tagname callername &optional other-window) (interactive (append (find-tag-tag "Find tag: ") (find-tag-tag "Find tag at caller: "))) (if (match-tag-and-caller tagname callername) (open-tag-callerline other-window)) (setq last-tag tagname) (setq last-instance nil) (setq last-subclass nil) (setq search-last-string tagname) (setq last-caller callername)) (defun find-last-tag-at-caller (callername &optional other-window) (interactive (find-tag-tag "Find tag at caller: ")) (let ((tagname last-tag)) (if (match-tag-and-caller tagname callername) (open-tag-callerline other-window)) (setq last-caller callername) (setq last-tag tagname) (setq last-instance nil) (setq last-subclass nil) (setq search-last-string tagname))) (defun find-tag-next-caller () (interactive) (if last-caller (progn (visit-tags-table-buffer) (forward-line 1) (if (setq last-caller (match-tag-not-caller last-tag last-caller)) (open-tag-callerline nil))) (progn (visit-tags-table-buffer) (goto-char (point-min)) (setq last-instance nil) (setq last-subclass nil) (if (setq last-caller (match-tag-not-caller last-tag nil)) (open-tag-callerline nil))))) (defun find-tag-callerlist (tagname) " Make a buffer with the names of all the callers for tag" (interactive (if current-prefix-arg '(nil t) (find-tag-tag "Find callers for tag: "))) (setq last-tag tagname) (setq last-caller nil) (setq last-instance nil) (setq last-subclass nil) (with-output-to-temp-buffer "*Tags Caller List*" (princ "Callers for tag ") (prin1 tagname) (terpri) (setq tagname (concat "^" (regexp-quote tagname) "\177")) (let ((callername nil)) (save-excursion (visit-tags-table-buffer) (goto-char 1) (while (re-search-forward tagname nil t) (end-of-line) (search-backward ",") (setq callername (buffer-substring (1+ (point)) (progn (end-of-line) (point)))) (end-of-line) (search-backward ",") (goto-char (1- (point))) (if (and (looking-at "f") (not (equal callername ""))) (progn (princ callername) (terpri))) (beginning-of-line) (forward-line 1)))))) (defun find-class (tagname &optional next) "Find tag (in current tag table) whose name contains TAGNAME. Must also match field containing c for class. Selects the buffer that the tag is contained in and puts point at its definition. If TAGNAME is a null string, the expression in the buffer around or before point is used as the tag name. See documentation of variable tags-file-name." (interactive (if current-prefix-arg '(nil t) (find-tag-tag "Find class: "))) (setq last-tag last-class) (find-tag tagname next nil "c") (if tagname (setq last-class tagname)) (setq last-tag nil) (setq last-instance nil) (setq search-last-string last-class) (setq last-subclass nil)) (defun find-instance (tagname &optional next) "Find tag (in current tag table) whose name contains TAGNAME. Must also match field containing i for instance. Selects the buffer that the tag is contained in and puts point at its definition. If TAGNAME is a null string, the expression in the buffer around or before point is used as the tag name. See documentation of variable tags-file-name." (interactive (if current-prefix-arg '(nil t) (find-tag-tag "Find instance: "))) (setq last-tag last-instance) (find-tag tagname next nil "i") (setq last-tag nil) (if tagname (setq last-instance tagname)) (setq last-subclass nil) (setq search-last-string last-instance) (setq last-caller nil)) (defun find-class-other-window (tagname) "Find tag (in current tag table) whose name contains TAGNAME. Must also match field containing c for class. Selects the buffer that the tag is contained in and puts point at its definition in another window. If TAGNAME is a null string, the expression in the buffer around or before point is used as the tag name. See documentation of variable tags-file-name." (interactive (if current-prefix-arg '(nil t) (find-tag-tag "Find class other window: "))) (find-tag tagname nil t "c") ; t is deleted parm other-window (setq last-class tagname) (setq last-tag nil) (setq last-instance nil) (setq search-last-string tagname) (setq last-subclass nil)) (defun find-inst-other-window (tagname) "Find tag (in current tag table) whose name contains TAGNAME. Must also match field containing i for instance. Selects the buffer that the tag is contained in and puts point at its definition in another window. If TAGNAME is a null string, the expression in the buffer around or before point is used as the tag name. See documentation of variable tags-file-name." (interactive (if current-prefix-arg '(nil t) (find-tag-tag "Find instance other window: "))) (find-tag tagname nil t "i"); t is deleted parm other-window (setq last-tag nil) (setq last-instance tagname) (setq last-subclass nil) (setq search-last-string tagname) (setq last-caller nil)) (defun match-class-and-instance (classname instance stype errstring) (let (tempstring (found-tag t) (found-match nil)) (visit-tags-table-buffer) (goto-char (point-min)) (setq instance (concat "^" (regexp-quote instance) "\177")) (while (and found-tag (not found-match)) (if (setq found-tag (re-search-forward instance nil t)) (setq found-match (progn (end-of-line) (search-backward ",") (setq tempstring (buffer-substring (1+ (point)) (progn (end-of-line) (point)))) (end-of-line) (search-backward ",") (goto-char (1- (point))) (and (looking-at stype) (string-equal tempstring classname))))) (end-of-line)) (beginning-of-line) (or found-match (progn (setq last-subclass nil) (setq last-instance nil) (error errstring) nil)))) (defun match-class-not-instance (tagname instance stype errstring) (let (tempstring (found-tag t) (found-match nil)) (visit-tags-table-buffer) (setq tagname (concat "," (regexp-quote tagname) )) (while (and found-tag (not found-match)) (if (setq found-tag (re-search-forward tagname nil t)) (setq found-match (progn (beginning-of-line) (search-forward "\177") (setq tempstring (buffer-substring (1- (point)) (progn (beginning-of-line) (point)))) (end-of-line) (search-backward ",") (goto-char (1- (point))) (and (not (equal tempstring "")) (looking-at stype) )))) (end-of-line)) ; for next regexp search starting place (beginning-of-line) (or found-match (setq tempstring (progn (setq last-subclass nil) (setq last-instance nil) (error errstring) nil))) ; Return the name of the new caller tempstring)) (defun find-class-subclasslist (tagname) " Make a buffer with the names of all the subclasses for tagname" (interactive (if current-prefix-arg '(nil t) (find-tag-tag "Find subclasses of class: "))) (setq last-class tagname) (setq last-tag nil) (setq last-instance nil) (setq last-subclass nil) (with-output-to-temp-buffer "*Tags Subclass List*" (princ "Subclasses of class ") (prin1 tagname) (terpri) (setq tagname (concat "," (regexp-quote tagname) )) (let ((siname nil)) (save-excursion (visit-tags-table-buffer) (goto-char 1) (while (re-search-forward tagname nil t) (beginning-of-line) (search-forward "\177") (setq siname (buffer-substring (1- (point)) (progn (beginning-of-line) (point)))) (end-of-line) (search-backward ",") (goto-char (1- (point))) (if (looking-at "c") (progn (princ siname) (terpri))) (beginning-of-line) (forward-line 1)))))) (defun find-class-instlist (tagname ) " Make a buffer with the names of all the instances for tag" (interactive (if current-prefix-arg '(nil t) (find-tag-tag "Find instances of class: "))) (setq last-class tagname) (setq last-instance nil) (setq last-subclass nil) (setq last-tag nil) (with-output-to-temp-buffer "*Tags Instance List*" (princ "Instances of class ") (prin1 tagname) (terpri) (setq tagname (concat "," (regexp-quote tagname) )) (let ((siname nil)) (save-excursion (visit-tags-table-buffer) (goto-char 1) (while (re-search-forward tagname nil t) (beginning-of-line) (search-forward "\177") (setq siname (buffer-substring (1- (point)) (progn (beginning-of-line) (point)))) (end-of-line) (search-backward ",") (goto-char (1- (point))) (if (looking-at "i") (progn (princ siname) (terpri))) (beginning-of-line) (forward-line 1)))))) (defun find-class-next-instance () (interactive) (if (not last-class) (error "Must do find-class-instlist first")) (if last-instance (progn (visit-tags-table-buffer) (forward-line 1) (if (setq last-instance (match-class-not-instance last-class last-instance "i" "No more instances")) (open-tag-callerline nil))) (progn (visit-tags-table-buffer) (goto-char (point-min)) (if (setq last-instance (match-class-not-instance last-class nil "i" "No instances")) (open-tag-callerline nil))))) (defun find-class-next-subclass () (interactive) (if (not last-class) (error "Must do find-class-subclasslist first")) (if last-subclass (progn (visit-tags-table-buffer) (forward-line 1) (if (setq last-subclass (match-class-not-instance last-class last-subclass "c" "No more subclasses")) (open-tag-callerline nil))) (progn (visit-tags-table-buffer) (goto-char (point-min)) (if (setq last-subclass (match-class-not-instance last-class nil "c" "No subclasses")) (open-tag-callerline nil))))) (defun is-member (item list) "[cl] MEMBER ITEM LIST => Is ITEM in LIST? Uses eql on the cars of LIST." (let ((ptr list) (done nil) (result '())) (while (not (or done (atom ptr))) (cond ((equal item (car ptr)) (setq done t) (setq result ptr))) (setq ptr (cdr ptr))) result)) (defun is-top-level (classname) " In order to be top level, the class name must not appear in any entry which defines it as a subclass of another class" (save-excursion (goto-char (point-min)) (if (re-search-forward (concat "^" classname "\177") nil t) (if (progn (end-of-line) (looking-at ",")) t nil) t))) (defun find-class-hierarchy () " Make a buffer with the names of all the callers for tag" (interactive) (let (classname (parentlist nil)) (with-output-to-temp-buffer "*Class Hierarchy*" (princ "Class Hierarchy") (save-excursion (visit-tags-table-buffer) (goto-char 1) ; Find all parent classes and make sure top level. (while (re-search-forward ",c," nil t) (if (and (not (is-member (setq classname (buffer-substring (point) (progn (end-of-line) (point)))) parentlist)) (not (equal classname "")) (is-top-level classname)) (setq parentlist (append parentlist (list classname)))) (beginning-of-line) (forward-line 1)) (goto-char (point-min)) ; get the parents with no subclasses too (while (re-search-forward ",c,$" nil t) (beginning-of-line) (search-forward "\177") (setq classname (buffer-substring (1- (point)) (progn (beginning-of-line) (point)))) (if (and (not (equal classname "")) (not (is-member classname parentlist))) (setq parentlist (append parentlist (list classname)))) (beginning-of-line) (forward-line 1)) ; Find and print all subclasses of these top level parent classes. (while (not (null parentlist)) (terpri) (setq classname (car parentlist)) (setq parentlist (cdr parentlist)) (princ classname) (print-subclasses classname " ")))))) (defun print-subclasses (classname offset) (let (subclass) (save-excursion (goto-char (point-min)) (while (re-search-forward (concat ",c," classname) nil t) (terpri) (beginning-of-line) (setq subclass (buffer-substring (point) (progn (search-forward "\177") (1- (point))))) (princ offset) (princ subclass) (print-subclasses subclass (concat offset " ")) (beginning-of-line) (forward-line 1))))) ; Set up some key bindings for these commands. (global-set-key "\^xT" 'find-tag-at-caller) (global-set-key "\^xN" 'find-tag-next-caller) (global-set-key "\^xL" 'find-tag-callerlist) (global-set-key "\^xC" 'find-class) (global-set-key "\^x4\^xC" 'find-class-other-window) (global-set-key "\^x4\^xI" 'find-instance-other-window) (global-set-key "\^xI" 'find-instance) (global-set-key "\^xJ" 'find-class-instlist) (global-set-key "\^xK" 'find-class-subclasslist) (global-set-key "\^xM" 'find-class-next-instance) (global-set-key "\^xS" 'find-class-next-subclass)