;;; vtags.el --- tags facility for Emacs ;; Copyright (C) 1985, 1986, 1988, 1989, 1992, 1993, 1994, 1995, 1996, 1998, ;; 2000, 2001, 2002, 2003, 2004, 2005, 2006 ;; Free Software Foundation, Inc. ;; Author: Edward Bishop ;; Maintainer: FSF ;; Keywords: tools ;; This file is part of GNU Emacs. ;; GNU Emacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;; Boston, MA 02111-1307, USA. ;;; Commentary: ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Changes from previous etags.el: ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; Added tags (as opposed to TAGS) functionality. ;; The code now has the ability to parse vi-style ;; tags tables generated by Exuberant Ctags. ;; By introduction of tags-get-tagfile-header and struct tagfileinfo, we have tried ;; to make the higher-level functions tag-type agnostic and non-buffer-centric. ;; Many functions that used to assume that the TAGS file is in ;; the current buffer now take a tagfileinfo, or tfi, parameter. ;; ;; Changed the behavior of find-tag for multiple matches. Previously the user ;; could iterate through the matches one at a time. Now the user ;; is presented with all the matches at once in a buffer, similar ;; to the way that completions, list-tags, or tags-apropos are handled. ;; Removed next-p in find-tag-internal, etc. Now find-tag-internal searches all tag files. ;; ;; Deprecated the tag ring in favor of placeholders. ;; Placeholders navigation is more natural, allowing forward and back, ;; similar to the way debuggers allow programmers to navigate up and down ;; a call stack, or to the way browsers allow history navigation. ;; ;; Ripped out cached completions, i.e. tags-completion-table. ;; These are not useful since they take forever to compute without a prefix ;; (and people almost never use completion without a prefix). ;; ;; Eliminated tags-file-name. Users should use tags-table-list instead. ;; There were too many global variables tracking ;; the same or overlapping functionality. ;; ;; Eliminated select-tags-table and all other references to tags-table-set-list. ;; There may be some merit to allowing the user to select a set of tags tables ;; from a list of sets, but it seems to me that the previous implementation ;; was too complicated, too rigid, and too poorly documented, and too implicitly ;; entangled with the rest of the tags functionality to be easily salvageable. ;; See Design Notes below. ;; ;; Changed `tags-table-computed-list' to be a list of tagfileinfo. ;; Furthermore, all computation is done up front, files are visited ;; and includes are added to the list. ;; ;; Removed 'button and 'apropos dependency, using vtags-mode instead. ;; We don't need all the features of button and apropos, and removing ;; them makes the code more portable and independent. ;; TODO implement vtags-tags-apropos; test etags-tags-apropos-additional ;; Or has this functionality been subsumed into find-tag? ;; TODO finish gtags integration ;; TODO fix comments ;; TODO remove unused functions and variables ;; TODO fix all TODO's ;; TODO debug allocation and garbage collection ;; TODO look at tinytag ;; TODO: This seems like a bug in previous version of etags-goto-tag-location: ;; If use-explicit was used when ;; snarfing the tag-info then tag-text may not start at beginning of line. ;; Example: Try (list-tags "gdb-6.3/include/elf/external.h") and then ;; select Elf_External_Sym_Shndx from the list. ;; I commented out the (concat ... "^") and it seems to work. ;; TODO complete the encapsulation of the type-specific functions ;; There should be a clearly defined interface so that anyone who ;; wishes to add a new type of tags table can do so without changing ;; existing code. ;;; BUGS ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Design notes ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; Efficiency vs platform independence ;; ;; When processing files there are two essentially different strategies: ;; ;; 1) read the file into a buffer and process it, or ;; ;; 2) use the operating system (via shell-command or call-process) ;; to process the file in place ;; ;; (1) has the advantage of platform independence. It also makes available ;; the full power of the elisp libraries. ;; ;; (2) often has the advantage of greater efficiency, but should only be used ;; when absolutely neccesary. ;; ;; In this module we use a combination of (1) and (2). For example, when doing ;; find-tag we follow strategy (1), reading some or all of the tag file into a ;; buffer and then invoking elisp functions on that buffer. We could have ;; called findTag() from the ctags C library, but that would assume that the library ;; had been intalled on the system. ;; On the other hand, when doing list-tags on Ctags-generated tag files, we ;; call (shell-command ...) to do some preliminary filtering and then invoke ;; elisp code on a buffer containing the filtered output. ;; Tag Table Selection ;; ;; Previously, tag table selection was implict, disjointed, and inextricably interwoven ;; (via global/local variables, etc.) into the fabric of the code. The function ;; visit-tags-table-buffer was the focal point and jumping off point for most of it. ;; ;; I have tried to identify and separate out those portions of the code that are for ;; table selection from the rest of the code. Unfortunately, I was unable to ;; preserve all of the previous functionality. ;; ;; The current strategy is very simple: ;; User sets tags-table-list. (TODO propmpt user if not set). ;; The tags-table-computed-list is constructed by ;; stat'ing each file, checking for includes. This becomes the working list ;; for all tags functions. The concept of "current table" no longer exists. ;; ;; Moving forward, it would be good to make table selection completely explicit ;; and separate from the rest of the code. Strategies for selection should be ;; easy to implement and easy for the user to select. ;; ;; Selection criteria might include current buffer, operation, language, ;; or other criteria not yet considered. ;; ;; Examples of table selection strategies, some of which appeared in visit-tags-table-buffer: ;; * Use the current table ;; * Use the current buffer-local table ;; * Use the next table (by calling next-table-function) ;; * Use the current list of tables ;; * Use the current list of tables, but stop when a match is found. ;; (applies only to find-tag, not to tags-apropos). ;; * Use only tables that have associated buffers. ;; * Use only sorted tables. ;; * Search up the directory tree from the current working directory for a ;; file named "tags" (from JonathanSimms entry in http://www.emacswiki.org/cgi-bin/wiki/EmacsTags). ;; Similar to the global tags way of GTAG file selection. ;; * Use the current table and any included tables (this is how tags-completion-table used to work). ;;; Code: (require 'ring) ;(require 'gtags) ;(eval-when-compile (require 'cl) ;) (require 'edebug) (setq edebug-form-data nil) ;(make-local-variable debug-on-error) ;(setq debug-on-error t) (defvar vtags-debugging nil) (defgroup etags nil "Tags tables." :group 'tools) ;;;###autoload (defcustom tags-case-fold-search 'default "*Whether tags operations should be case-sensitive. A value of t means case-insensitive, a value of nil means case-sensitive. Any other value means use the setting of `case-fold-search'." :group 'etags :type '(choice (const :tag "Case-sensitive" nil) (const :tag "Case-insensitive" t) (other :tag "Use default" default)) :version "21.1") (defvar tags-table-computed-list nil "List of tags tables to search, computed from `tags-table-list'. This includes tables implicitly included by other tables. See `tags-compute-list'.") ;;;###autoload (defcustom tags-compression-info-list '("" ".Z" ".bz2" ".gz" ".tgz") "*List of extensions tried by etags when jka-compr is used. An empty string means search the non-compressed file. These extensions will be tried only if jka-compr was activated \(i.e. via customize of `auto-compression-mode' or by calling the function `auto-compression-mode')." :type '(repeat string) :group 'etags) ;; !!! tags-compression-info-list should probably be replaced by access ;; to directory list and matching jka-compr-compression-info-list. Currently, ;; this implementation forces each modification of ;; jka-compr-compression-info-list to be reflected in this var. ;; An alternative could be to say that introducing a special ;; element in this list (e.g. t) means : try at this point ;; using directory listing and regexp matching using ;; jka-compr-compression-info-list. (defcustom tags-revert-without-query nil "*Non-nil means reread a TAGS table without querying, if it has changed." :group 'etags :type 'boolean) ;;;###autoload (defcustom find-tag-hook nil "*Hook to be run by \\[find-tag] after finding a tag. See `run-hooks'. The value in the buffer in which \\[find-tag] is done is used, not the value in the buffer \\[find-tag] goes to." :group 'etags :type 'hook) ;;;###autoload (defcustom find-tag-default-function nil "*A function of no arguments used by \\[find-tag] to pick a default tag. If nil, and the symbol that is the value of `major-mode' has a `find-tag-default-function' property (see `put'), that is used. Otherwise, `find-tag-default' is used." :group 'etags :type '(choice (const nil) function)) (defcustom find-tag-marker-ring-length 16 "*Length of marker rings `find-tag-marker-ring' and `tags-location-ring'." :group 'etags :type 'integer :version "20.3") (defcustom tags-tag-face 'default "*Face for tags in the output of `tags-apropos'." :group 'etags :type 'face :version "21.1") (defcustom tags-apropos-verbose nil "If non-nil, print the name of the tags file in the *Tags List* buffer." :group 'etags :type 'boolean :version "21.1") (defcustom tags-apropos-additional-actions nil "Specify additional actions for `tags-apropos'. If non-nil, value should be a list of triples (TITLE FUNCTION TO-SEARCH). For each triple, `tags-apropos' processes TO-SEARCH and lists tags from it. TO-SEARCH should be an alist, obarray, or symbol. If it is a symbol, the symbol's value is used. TITLE, a string, is a title used to label the additional list of tags. FUNCTION is a function to call when a symbol is selected in the *Tags List* buffer. It will be called with one argument SYMBOL which is the symbol being selected. Example value: '((\"Emacs Lisp\" Info-goto-emacs-command-node obarray) (\"Common Lisp\" common-lisp-hyperspec common-lisp-hyperspec-obarray) (\"SCWM\" scwm-documentation scwm-obarray))" :group 'etags :type '(repeat (list (string :tag "Title") function (sexp :tag "Tags to search"))) :version "21.1") (defvar find-tag-marker-ring (make-ring find-tag-marker-ring-length) "Ring of markers which are locations from which \\[find-tag] was invoked.") (defvar default-tags-table-function nil "If non-nil, a function to choose a default tags file for a buffer. This function receives no arguments and should return the default tags table file to use for the current buffer.") (defvar tags-location-ring (make-ring find-tag-marker-ring-length) "Ring of markers which are locations visited by \\[find-tag]. Pop back to the last location with \\[negative-argument] \\[find-tag].") (defconst vtags-history-buffer "*Vtags-History*") (defconst vtags-buffer-name "*Vtags-Buffer*") (defvar vtags-the-return-point nil "Ugly global variable" ) (defvar vtags-other-window nil "Ugly global variable" ) (defvar vtags-truncate-lines t) ; Default value for truncate-lines (defvar vtags-reuse-buffer t) ; Use the same buffer for all tag command (defvar vtags-debugging nil) ;; Tags table state. ;; These variables are local in tags table buffers. (defvar tags-table-files nil "List of file names covered by current tags table. nil means it has not yet been computed; use `tags-table-files' to do so.") (defvar next-file-list nil "List of files for \\[next-file] to process.") ;; Hooks for file formats. (defvar tags-table-format-functions '(etags-recognize-tags-table tags-recognize-empty-tags-table) "Hook to be called in a tags table buffer to identify the type of tags table. The functions are called in order, with no arguments, until one returns non-nil. The function should make buffer-local bindings of the format-parsing tags function variables if successful.") (defvar file-of-tag-function nil "Function to do the work of `file-of-tag' (which see). One optional argument, a boolean specifying to return complete path (nil) or relative path (non-nil).") (defvar tags-table-files-function nil "Function to do the work of `tags-table-files' (which see).") (defvar tags-completion-table-function nil "Function to build the `tags-completion-table'.") (defvar snarf-tag-function nil "Function to get info about a matched tag for `goto-tag-location-function'. One optional argument, specifying to use explicit tag (non-nil) or not (nil). The default is nil.") (defvar goto-tag-location-function nil "Function of to go to the location in the buffer specified by a tag. One argument, the tag info returned by `snarf-tag-function'.") (defvar find-tag-regexp-search-function nil "Search function passed to `find-tag-in-order' for finding a regexp tag.") (defvar find-tag-regexp-tag-order nil "Tag order passed to `find-tag-in-order' for finding a regexp tag.") (defvar find-tag-regexp-next-line-after-failure-p nil "Flag passed to `find-tag-in-order' for finding a regexp tag.") (defvar find-tag-search-function nil "Search function passed to `find-tag-in-order' for finding a tag.") (defvar find-tag-tag-order nil "Tag order passed to `find-tag-in-order' for finding a tag.") (defvar find-tag-next-line-after-failure-p nil "Flag passed to `find-tag-in-order' for finding a tag.") (defvar list-tags-function nil "Function to do the work of `list-tags' (which see).") (defvar tags-apropos-function nil "Function to do the work of `tags-apropos' (which see).") (defvar tags-included-tables-function nil "Function to do the work of `tags-included-tables' (which see).") (defvar verify-tags-table-function nil "Function to return t iff current buffer contains valid tags file.") ;; Initialize the tags table in the current buffer. ;; Returns non-nil iff it is a valid tags table. On ;; non-nil return, the tags table state variable are ;; made buffer-local and initialized to nil. (defun initialize-new-tags-table () (set (make-local-variable 'tags-table-files) nil) ;; We used to initialize find-tag-marker-ring and tags-location-ring ;; here, to new empty rings. But that is wrong, because those ;; are global. ;; Value is t if we have found a valid tags table buffer. (run-hook-with-args-until-success 'tags-table-format-functions)) ;; Expand tags table name FILE into a complete file name. (defun tags-expand-table-name (file) (setq file (expand-file-name file)) (if (file-directory-p file) (expand-file-name "TAGS" file) file)) (defun tags-get-buffer-and-verify-table (tfi) "Read FILE into a buffer and verify that it is a valid tags table. Returns non-nil iff it is a valid table. a) read file into a buffer b) verify the syntax c) set buffer-local variables Don't do this for non-etags files. Sets the current buffer to one visiting FILE (if it exists). " (if (tagfileinfo-etags-p tfi) (let ((file (tagfileinfo-file tfi))) (if (and file (get-file-buffer file)) (let () ;; The file is already in a buffer. Check for the visited file ;; having changed since we last used it. (set-buffer (get-file-buffer file)) (or verify-tags-table-function (initialize-new-tags-table)) (if (or (verify-visited-file-modtime (current-buffer)) ;; Decide whether to revert the file. ;; revert-without-query can say to revert ;; or the user can say to revert. (not (or (let ((tail revert-without-query) (found nil)) (while tail (if (string-match (car tail) buffer-file-name) (setq found t)) (setq tail (cdr tail))) found) tags-revert-without-query (yes-or-no-p (format "Tags file %s has changed, read new contents? " file))))) (and verify-tags-table-function (funcall verify-tags-table-function)) (revert-buffer t t) (initialize-new-tags-table))) (and file (file-exists-p file) (set-buffer (find-file-noselect file t t)) (initialize-new-tags-table)))))) ;;;###autoload (defun find-tags-table-heuristically () "Select a tags table and return the tagfileinfo. This function, the last vestige of visit-tags-table-buffer, was a mess of options and side effects. The two main purposes were a) select a tags table, and b) visit the tags table buffer. We are no longer buffer-centric so we don't do (b) here. Choose a tags table: * try a user-specified function to guess * tags table that contains tags for the current buffer's file * use tags-table-computed-list * Finally, prompt the user for a file name Returns table if it finds a tags table, or nil if there are no more in the list." ;; Pick a table out of our hat. (let (tfi) (or ;; First, try a local variable. EEB: Deprecated. ;; Second, try a user-specified function to guess. (and default-tags-table-function (funcall default-tags-table-function)) ;; Third, look for a tags table that contains tags for the ;; current buffer's file. If one is found, the lists will ;; be frobnicated, and CONT will be set non-nil so we don't ;; do it below. ;; EEB this is really inefficient ;; (and buffer-file-name ;; ;; First check only tables already in buffers. ;; ;; EEB: No, check all the tables. We don't want ;; ;; to be buffer-centric at this point ;; (tags-table-including buffer-file-name)) ;; Fourth, use the user variable ;; EEB: deprecated. ;; Fifth, use the user variable giving the table list. ;; Find the first element of the list that actually exists. (let ((list tags-table-computed-list) file) (while (and list (setq file (tagfileinfo-file (car list))) ;; (not (get-file-buffer file)) (not (file-exists-p file))) (setq list (cdr list))) (car list)) ;; Finally, prompt the user for a file name. EEB: insert into computed list? (get-tagfileinfo (expand-file-name (read-file-name "Visit tags table: (default TAGS) " default-directory "TAGS" t)))) tfi) ) (defun file-of-tag (&optional relative) "Return the file name of the file whose tags point is within. Assumes the tags table is the current buffer. If RELATIVE is non-nil, file name returned is relative to tags table file's directory. If RELATIVE is nil, file name returned is complete." (and file-of-tag-function (funcall file-of-tag-function relative))) ;;;###autoload (defun tags-table-files (tfi string &optional predicate) "Return a list of files in the tags table. The file names are returned, usually without directory names." ;; TODO use the predicate (save-excursion (if (tagfileinfo-etags-p tfi) ;; Do it the old etags way: in a buffer. (progn (tags-get-buffer-and-verify-table tfi) (tags-table-files-from-buffer)) ;; Use perl to dump file names from tag file into filelist ;; The horror... the horror... (let* ((filelist nil) (tag-file (tagfileinfo-file tfi)) (output "") (cmd (concat "my %seen = (); # Match all non-white space following first tab. # That is the file name. while ($line = <>) { next if $line =~ /^!/; if ($line =~ m#^[^\t]+\t(" string "\\S*)#) { if (! $seen{$1}) { ++$seen{$1}; print \"$1\\n\"; } } } " ))) ;;(message "command is %s" cmd) (setq output (with-output-to-string (apply 'call-process "perl" ; program nil ; INFILE t ; BUFFER nil ; DISPLAYP (list "-e" ; ARGS cmd tag-file ) ))) (if (featurep 'xemacs) (setq filelist (split-string output "\n" t )) (setq filelist (split-string output "\n"))) filelist)))) ;;;###autoload (defun tags-table-files-from-buffer () "Return a list of files in the current tags table. Assumes the tags table is the current buffer. The file names are returned as they appeared in the `etags' command that created the table, usually without directory names." (or tags-table-files (and tags-table-files-function (setq tags-table-files (funcall tags-table-files-function))))) ;; Build tags-completion-table on demand. The single current tags table ;; and its included tags tables (and their included tables, etc.) have ;; their tags included in the completion table. (defun tags-completion-table-from-tag-table-list (string predicate tfi-list) (let ((table (make-vector 511 0)) (tfi-pointer tfi-list)) (condition-case () (prog2 (message "Making tags completion table for %s..." buffer-file-name) ;; Iterate over the list of tables, and combine each ;; table's completion obarray to the parent obarray. (while tfi-pointer ;; Combine the tables. (mapatoms (lambda (sym) (intern (symbol-name sym) table)) (tags-completion-table-from-tagfile string predicate (car tfi-pointer))) (setq tfi-pointer (cdr tfi-pointer))) (message "Making tags completion table for %s...done" buffer-file-name)) (quit (message "Tags completion table construction aborted.") )) table)) (defun tags-completion-table-from-tagfile (string predicate tfi) "Return tags from this tagfile. Don't go into included tagfiles." (cond ((not (tagfileinfo-etags-p tfi)) (vtags-find-and-return-table string predicate tfi )) (t ;; Do etags tags (save-excursion (tags-get-buffer-and-verify-table tfi) (etags-tags-completion-table string predicate))))) (defun vtags-get-tag () (save-excursion (beginning-of-line) (let ((beg (point)) (tmp-string "") end tabpos) (search-forward "\t" nil t) (backward-char 1) (setq end (point)) (beginning-of-line) (setq tabpos (point)) ;; set property on correct entry (if (eq beg tabpos) ; found a tab on this line (progn (setq tmp-string (buffer-substring-no-properties tabpos end)) ;(message "tmp-string is %s" tmp-string) ) ;; else incorrect entry? ) tmp-string))) (defconst vtags-completion-buffer-name "*Vtags-Completion-Buffer*") (defun vtags-find-and-return-table (pattern predicate tfi) "Creates \"*Vtags-Completion-Buffer*\" creates an alist of matches to pattern. Use `vtags-table-list'." (save-excursion ;; TODO predicate (let (tag (output-buf (get-buffer-create vtags-completion-buffer-name)) (table (make-vector 511 0))) (set-buffer output-buf) (setq buffer-read-only nil) (fundamental-mode) (setq truncate-lines vtags-truncate-lines) (erase-buffer) ;; look up tag in each tagfile ;;(message "pattern is %s" pattern) (when tfi (vtags-look pattern tfi (lambda (line count) (save-excursion (set-buffer output-buf) (insert-string line))))) (set-buffer output-buf) (goto-char (point-min)) (skip-chars-forward " \n\t") (unless (eq (point) (point-max)) (goto-char (point-max)) (while (and (eq (forward-line -1) 0)) (setq tag (vtags-get-tag)) (when tag (intern tag table)))) table))) ;; Completion function for tags. Does normal try-completion, ;; but builds tags-completion-table from tags-table-computed-list on demand. (defun tags-complete-tag (string predicate what) (if (eq what t) (all-completions string (tags-completion-table-from-tag-table-list string predicate tags-table-computed-list) predicate) (try-completion string (tags-completion-table-from-tag-table-list string predicate tags-table-computed-list) predicate))) ;; Return a default tag to search for, based on the text at point. (defun find-tag-default () (save-excursion (while (looking-at "\\sw\\|\\s_") (forward-char 1)) (if (or (re-search-backward "\\sw\\|\\s_" (save-excursion (beginning-of-line) (point)) t) (re-search-forward "\\(\\sw\\|\\s_\\)+" (save-excursion (end-of-line) (point)) t)) (progn (goto-char (match-end 0)) (buffer-substring (point) (progn (forward-sexp -1) (while (looking-at "\\s'") (forward-char 1)) (point)))) nil))) ;; Read a tag name from the minibuffer with defaulting and completion. (defun find-tag-tag (string) (let* ((completion-ignore-case (if (memq tags-case-fold-search '(t nil)) tags-case-fold-search case-fold-search)) (default (funcall (or find-tag-default-function (get major-mode 'find-tag-default-function) 'find-tag-default))) (spec (completing-read (if default (format "%s (default %s): " (substring string 0 (string-match "[ :]+\\'" string)) default) string) 'tags-complete-tag nil nil nil nil default))) (if (equal spec "") (or default (error "There is no default tag")) spec))) (defvar last-tag nil "Last tag found by \\[find-tag].") ;; Get interactive args for find-tag{-noselect,-other-window,-regexp}. (defun find-tag-interactive (prompt &optional no-default) (if (and current-prefix-arg last-tag) (list nil (if (< (prefix-numeric-value current-prefix-arg) 0) '- t)) (list (if no-default (read-string prompt) (find-tag-tag prompt))))) (defvar find-tag-history nil) ;; Dynamic bondage: (eval-when-compile (defvar etags-case-fold-search) (defvar etags-syntax-table)) ;;;###autoload (defun find-tag (tagname &optional regexp-p) "Find tag whose name contains TAGNAME. Select the buffer containing the tag's definition, and move point there. The default for TAGNAME is the expression in the buffer around or before point. If REGEXP-P is non-nil, treat TAGNAME as a regexp. A marker representing the point when this command is invoked is pushed onto a ring and may be popped back to with \\[pop-tag-mark]. Contrast this with the ring of marks gone to by the command." (interactive (find-tag-interactive "Find tag: ")) (find-tag-internal tagname regexp-p nil)) ;;;###autoload (define-key esc-map "." 'find-tag) ;;;###autoload (defun find-tag-other-window (tagname &optional regexp-p) "Find tag whose name contains TAGNAME. 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 REGEXP-P is non-nil, treat TAGNAME as a regexp. A marker representing the point when this command is invoked is pushed onto a ring and may be popped back to with \\[pop-tag-mark]. Contrast this with the ring of marks gone to by the command." (interactive (find-tag-interactive "Find tag other window: ")) (find-tag-internal tagname regexp-p t)) ;;;###autoload (define-key ctl-x-4-map "." 'find-tag-other-window) ;;;###autoload (defun find-tag-other-frame (tagname) "Find tag whose name contains TAGNAME. Select the buffer containing the tag's definition in another frame, and move point there. The default for TAGNAME is the expression in the buffer around or before point. If REGEXP-P is non-nil, treat TAGNAME as a regexp. A marker representing the point when this command is invoked is pushed onto a ring and may be popped back to with \\[pop-tag-mark]. Contrast this with the ring of marks gone to by the command." (interactive (find-tag-interactive "Find tag other frame: ")) (let ((pop-up-frames t)) (find-tag-other-window tagname))) ;;;###autoload (define-key ctl-x-5-map "." 'find-tag-other-frame) ;;;###autoload (defun find-tag-regexp (regexp &optional other-window) "Find tag whose name matches REGEXP. Select the buffer containing the tag's definition and move point there. If OTHER-WINDOW is non-nil, select the buffer in another window. A marker representing the point when this command is invoked is pushed onto a ring and may be popped back to with \\[pop-tag-mark]. Contrast this with the ring of marks gone to by the command." (interactive (find-tag-interactive "Find tag regexp: " t)) ;; We go through find-tag-other-window to do all the display hair there. (funcall (if other-window 'find-tag-other-window 'find-tag) regexp t)) ;;;###autoload (define-key esc-map [?\C-.] 'find-tag-regexp) ;;;###autoload (define-key esc-map "*" 'pop-tag-mark) ;;;###autoload (defun pop-tag-mark () "Pop back to where \\[find-tag] was last invoked. This is distinct from invoking \\[find-tag] with a negative argument since that pops a stack of markers at which tags were found, not from where they were found." (interactive) (if (ring-empty-p find-tag-marker-ring) (error "No previous locations for find-tag invocation")) (let ((marker (ring-remove find-tag-marker-ring 0))) (switch-to-buffer (or (marker-buffer marker) (error "The marked buffer has been deleted"))) (goto-char (marker-position marker)) (set-marker marker nil nil))) ;;;###autoload (defun find-tag-internal ( pattern &optional regexp-p other-window-p ) "Find tag (in current tags table list) whose name contains PATTERN. The default for PATTERN is the expression in the buffer near point. When there are multiple matches for a tag, matches are displayed in a buffer. If REGEXP-P is non-nil, treat PATTERN as a regexp. The current point and the destination of this search are added to the placeholder list." (interactive (find-tag-interactive "Find tag: ")) (let ( (matching (if regexp-p "matching" "containing")) (match-count 0) (case-fold-search (if (memq tags-case-fold-search '(nil t)) tags-case-fold-search case-fold-search)) ;; Save the current buffer's value of `find-tag-hook' before ;; selecting the tags table buffer. (tables (progn (find-tags-table-heuristically) tags-table-computed-list)) (output-buf (get-buffer-create (if vtags-reuse-buffer vtags-buffer-name (concat "TAG:" pattern)))) ) ;; Record whence we came. (setq find-tag-history (cons pattern find-tag-history)) (ring-insert find-tag-marker-ring (point-marker)) (setq vtags-the-return-point (point-marker)) ;; Send matches to output buffer (save-excursion (set-buffer output-buf) (setq buffer-read-only nil) (erase-buffer)) ;; Get a qualified match. ;; Iterate over the list of tags tables. (while tables (let* ((tfi (car tables)) (search-func (cond ((tagfileinfo-etags-p tfi) 'etags-find-tag-in-order) (t 'vtags-find-tag-in-order)))) (setq match-count (+ match-count (funcall search-func (car tables) pattern regexp-p output-buf )))) (setq tables (cdr tables))) ;; Check for GTAGS. TODO is this the best way to specify GTAGS? (when (and (getenv "GTAGSROOT") (fboundp 'gtags-visit-rootdir)) (setq match-count (+ match-count (funcall 'gtags-find-tag-in-order (car tables) pattern regexp-p output-buf )))) (if (= 0 match-count) (error "No tags %s %s" matching pattern) (switch-to-buffer output-buf) (if (> match-count 1) ;; multiple matches, leave user in *Vtags-Buffer* to make choice (progn (goto-char (point-min)) (forward-line 1) (vtags-mode)) ;; Just one match; go to location (search-backward-regexp "[^\n]") ;; go back from trailing new-lines (beginning-of-line) (let ( (tag-info (get-text-property (point) 'tag-info)) (goto-func (get-text-property (point) 'goto-func)) (filepath (get-text-property (point) 'file-path)) ) (tags-go-to-file-and-location goto-func filepath tag-info other-window-p) ))))) ;; Internal tag finding function. ;; 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. (defun etags-find-tag-in-order ( tfi pattern regexp-p output-buf ) "Buffer-centric tag search function. Return count of matching tags." ;; Get the file buffer (save-excursion (tags-get-buffer-and-verify-table tfi) (let ((file nil) (tag-info nil) (match-count 0) (match-marker (make-marker)) (tag-lines-already-matched nil) (search-forward-func (if regexp-p find-tag-regexp-search-function find-tag-search-function)) (order (if regexp-p find-tag-regexp-tag-order find-tag-tag-order)) (next-line-after-failure-p (if regexp-p find-tag-regexp-next-line-after-failure-p find-tag-next-line-after-failure-p))) ;; Iterate over the list of ordering predicates. (while (and order) ;; Start at beginning of tags file. (goto-char (point-min)) (while (funcall search-forward-func pattern nil t) ;; Naive match found. Qualify the match. (and (funcall (car order) pattern) ;; Make sure it is not a previous qualified match. (not (member (set-marker match-marker (save-excursion (beginning-of-line) (point))) tag-lines-already-matched)) (progn ;; Found a tag; extract location info. (beginning-of-line) (setq tag-lines-already-matched (cons match-marker tag-lines-already-matched)) (setq match-marker (make-marker)) ;; Expand the filename, using the tags table buffer's default-directory. ;; We should be able to search for file-name backwards in file-of-tag: ;; the beginning-of-line is ok except when positioned on a "file-name" tag. (setq file (expand-file-name (if (memq (car order) '(tag-exact-file-name-match-p tag-file-name-match-p tag-partial-file-name-match-p)) (save-excursion (next-line 1) (file-of-tag)) (file-of-tag))) tag-info (funcall snarf-tag-function)) ;; Store line in output-buf (setq match-count (1+ match-count)) (let* ((tag-line (save-excursion (buffer-substring-no-properties (progn (forward-line -1) (beginning-of-line)(point)) (progn (end-of-line) (point))))) ;;(output-line (concat (if (eq t (car tag-info)) file (car tag-info)) "\n")) (output-line (concat tag-line "\t" file "\n")) (beg 0) (end (length output-line))) ;;(put-text-property beg end 'help-echo file output-line) (put-text-property beg end 'tag-info tag-info output-line) (put-text-property beg end 'file-path file output-line) (put-text-property beg end 'goto-func 'etags-goto-tag-location output-line) (put-text-property beg end 'action '(lambda (x) (tags-go-to-source x)) output-line) (put-text-property beg (1- end) 'mouse-face 'highlight output-line) (save-excursion (set-buffer output-buf) (when (= 1 match-count) (insert-string (concat "Found in " (tagfileinfo-file tfi) ":\n"))) (insert-string output-line))) )) (if next-line-after-failure-p (forward-line 1))) ;; Try the next flavor of match. (setq order (cdr order))) (unless (= 0 match-count) (save-excursion (set-buffer output-buf) (insert-string "\n"))) match-count))) (defun vtags-find-tag-in-order ( tfi pattern regexp-p output-buf ) "file-centric tag search function, return count of matching tag info" ;; Ignore all predicates for now (save-excursion ;; look up tag ;; (message "tagname is %s" tagname) (let* ((dir (file-name-directory (tagfileinfo-file tfi))) (match-count (vtags-look pattern tfi (lambda (line count) (vtags-set-action-properties (vtags-parse-line line) line dir) (save-excursion (set-buffer output-buf) (when (= 1 count) (insert-string (concat "Found in " (tagfileinfo-file tfi) ":\n"))) (insert-string line)))))) (unless (= 0 match-count) (set-buffer output-buf) (insert-string "\n")) match-count))) (defun gtags-find-tag-in-order ( tfi pattern regexp-p output-buf ) (let ( (match-count 0) (tag-line-list nil) (output "") (dir (file-name-directory (or (getenv "GTAGSROOT") default-directory))) (entry nil) (status 0) ) (set-buffer output-buf) (setq output (with-output-to-string ;; (setq status (call-process "global" ; program nil ; INFILE t ; BUFFER nil ; DISPLAYP ; ARGS ;;"--foo" "-axt" (concat "^" pattern "*") ) ;; ) )) (when (not (= 0 status)) (error (buffer-substring (point-min)(1- (point-max))))) (setq tag-line-list (split-string output "\n" t )) (dolist (tag-line tag-line-list (not (= (length tag-line-list) 0))) (when vtags-debugging (message "Checking %s" tag-line)) (setq match-count (1+ match-count)) (when (= 1 match-count) (insert-string (concat "Found by GTAGS:\n"))) (let* ((output-line (concat tag-line "\n") )) (setq entry (vtags-parse-line tag-line)) (vtags-set-action-properties entry output-line dir) (insert-string output-line))) (unless (= 0 match-count) (set-buffer output-buf) (insert-string "\n")) match-count)) (defun tag-find-file-of-tag-noselect (file) ;; Find the right line in the specified file. ;; If we are interested in compressed-files, ;; we search files with extensions. ;; otherwise only the real file. ;; EEB: Above comment is wrong. This function finds and returns a ;; buffer matching file, possibly with extensions. (let* ((buffer-search-extensions (if (featurep 'jka-compr) tags-compression-info-list '(""))) the-buffer (file-search-extensions buffer-search-extensions)) ;; search a buffer visiting the file with each possible extension ;; Note: there is a small inefficiency in find-buffer-visiting : ;; truename is computed even if not needed. Not too sure about this ;; but I suspect truename computation accesses the disk. ;; It is maybe a good idea to optimise this find-buffer-visiting. ;; An alternative would be to use only get-file-buffer ;; but this looks less "sure" to find the buffer for the file. (while (and (not the-buffer) buffer-search-extensions) (setq the-buffer (find-buffer-visiting (concat file (car buffer-search-extensions)))) (setq buffer-search-extensions (cdr buffer-search-extensions))) ;; if found a buffer but file modified, ensure we re-read ! (if (and the-buffer (not (verify-visited-file-modtime the-buffer))) (find-file-noselect (buffer-file-name the-buffer))) ;; if no buffer found, search for files with possible extensions on disk (while (and (not the-buffer) file-search-extensions) (if (not (file-exists-p (concat file (car file-search-extensions)))) (setq file-search-extensions (cdr file-search-extensions)) (setq the-buffer (find-file-noselect (concat file (car file-search-extensions)))))) (if (not the-buffer) (if (featurep 'jka-compr) (error "File %s (with or without extensions %s) not found" file tags-compression-info-list) (error "File %s not found" file)) (set-buffer the-buffer)))) (defun tag-find-file-of-tag (file &optional other-window-p) (let ((buf (tag-find-file-of-tag-noselect file))) (condition-case nil (if other-window-p (switch-to-buffer-other-window buf) (switch-to-buffer buf)) (error (pop-to-buffer buf))))) ;; `etags' TAGS file format support. ;; If the current buffer is a valid etags TAGS file, give it local values of ;; the tags table format variables, and return non-nil. (defun etags-recognize-tags-table () (and (etags-verify-tags-table) ;; It is annoying to flash messages on the screen briefly, ;; and this message is not useful. -- rms ;; (message "%s is an `etags' TAGS file" buffer-file-name) (mapc (lambda (elt) (set (make-local-variable (car elt)) (cdr elt))) '((file-of-tag-function . etags-file-of-tag) (tags-table-files-function . etags-tags-table-files) (tags-completion-table-function . etags-tags-completion-table) (snarf-tag-function . etags-snarf-tag) (goto-tag-location-function . etags-goto-tag-location) (find-tag-regexp-search-function . re-search-forward) (find-tag-regexp-tag-order . (tag-re-match-p)) (find-tag-regexp-next-line-after-failure-p . t) (find-tag-search-function . search-forward) (find-tag-tag-order . (tag-exact-file-name-match-p tag-file-name-match-p tag-exact-match-p tag-implicit-name-match-p tag-symbol-match-p tag-word-match-p tag-partial-file-name-match-p tag-any-match-p)) (find-tag-next-line-after-failure-p . nil) (list-tags-function . etags-list-tags) (tags-apropos-function . etags-tags-apropos) (tags-included-tables-function . etags-tags-included-tables) (verify-tags-table-function . etags-verify-tags-table) )))) ;; Return non-nil iff the current buffer is a valid etags TAGS file. (defun etags-verify-tags-table () ;; Use eq instead of = in case char-after returns nil. (eq (char-after (point-min)) ?\f)) (defun etags-file-of-tag (&optional relative) (save-excursion (re-search-backward "\f\n\\([^\n]+\\),[0-9]*\n") (let ((str (buffer-substring (match-beginning 1) (match-end 1)))) (if relative str (expand-file-name str (file-truename default-directory)))))) (defun etags-tags-completion-table (&optional string predicate) "Return completion table of tags in the current TAGS buffer. This may take a very long time if string is nil." (let ((table (make-vector 511 0)) (progress-reporter nil) (progress 0) (old-progress 0) (tag-buf (get-buffer-create vtags-completion-buffer-name)) (end (point-max))) ;; Set up scratch area for completion stuff (save-excursion (set-buffer tag-buf) (setq buffer-read-only nil) (fundamental-mode) (setq truncate-lines vtags-truncate-lines) (erase-buffer)) ;; Narrow down the regex thrashing by doing simple search first ;; and putting results into scratch buffer (goto-char (point-min)) (while (search-forward string end t) (vtags-insert-string-into-buffer (buffer-substring (progn (beginning-of-line)(point)) (progn (end-of-line)(1+(point)))) tag-buf nil)) (save-excursion (set-buffer tag-buf) (goto-char (point-min)) (when (fboundp 'make-progress-reporter) (setq progress-reporter (make-progress-reporter (format "Making tags completion table for %s..." buffer-file-name) (point-min) (point-max)))) (goto-char (point-min)) ;; This monster regexp matches an etags tag line. ;; \1 is the string to match; ;; \2 is not interesting; ;; \3 is the guessed tag name; XXX guess should be better eg DEFUN ;; \4 is not interesting; ;; \5 is the explicitly-specified tag name. ;; \6 is the line to start searching at; ;; \7 is the char to start searching at. (while (re-search-forward "^\\(\\([^\177]+[^-a-zA-Z0-9_+*$:\177]+\\)?\ \\([-a-zA-Z0-9_+*$?:]+\\)[^-a-zA-Z0-9_+*$?:\177]*\\)\177\ \\(\\([^\n\001]+\\)\001\\)?\\([0-9]+\\)?,\\([0-9]+\\)?\n" nil t) (intern (prog1 (if (match-beginning 5) ;; There is an explicit tag name. (buffer-substring (match-beginning 5) (match-end 5)) ;; No explicit tag name. Best guess. (buffer-substring (match-beginning 3) (match-end 3))) (if (featurep 'xemacs) (progn (setq progress (/ (* 100 (- (point) (point-min))) (- (point-max) (point-min)) )) (when (> progress old-progress) ;; Couldn't get this to work: (display-progress-feedback 'etags "Making tags completion table for ..." progress) (lmessage 'progress "Making tags completion table...%%%d" progress) (setq old-progress progress) )) (when (fboundp 'make-progress-reporter) (progress-reporter-update progress-reporter (point))))) table))) (when (featurep 'xemacs) (lmessage 'progress "Making tags completion table...done" progress)) ;; (clear-progress-feedback 'etags)) ; clear progress bar table)) (defun etags-snarf-tag (&optional use-explicit) (let (tag-text line startpos explicit-start) (if (save-excursion (forward-line -1) (looking-at "\f\n")) ;; The match was for a source file name, not any tag within a file. ;; Give text of t, meaning to go exactly to the location we specify, ;; the beginning of the file. (setq tag-text t line nil startpos (point-min)) ;; Find the end of the tag and record the whole tag text. (search-forward "\177") (setq tag-text (buffer-substring (1- (point)) (save-excursion (search-backward "\002" (save-excursion (beginning-of-line)(1- (point))) ;; LIMIT to beginning-of-line 1 ;;Optional third argument NOERROR, If neither nil nor t, set point to LIMIT ) (1+ (point))))) ;; If use-explicit is non nil and explicit tag is present, use it as part of ;; return value. Else just skip it. (setq explicit-start (point)) (when (and (search-forward "\001" (save-excursion (forward-line 1) (point)) t) use-explicit) (setq tag-text (buffer-substring explicit-start (1- (point))))) (if (looking-at "[0-9]") (setq line (string-to-number (buffer-substring (point) (progn (skip-chars-forward "0-9") (point)))))) (search-forward ",") (if (looking-at "[0-9]") (setq startpos (string-to-number (buffer-substring (point) (progn (skip-chars-forward "0-9") (point))))))) ;; Leave point on the next line of the tags file. (forward-line 1) (cons tag-text (cons line startpos)))) (defun vtags-regexp-quote (line) "Just leave the ^ and $ on the ends and regexp-quote the rest." (let ((prev-char-was-backslash nil) (search_string "") ) (let ((i 0) (len (length line)) x) (while (< i len) ;; loop through the string adding backslashes as needed for ;; special characters. ;; "loop" would require loading cl lisp library ;; that is why we use "while" instead of ... ;; (loop for x across tmp_string ;; do (progn (setq x (aref line i)) (setq i (1+ i)) ;; tags files sometimes use search patterns that ;; look ;; like this: / ... / ;; or this: / ... \\/ (if (and prev-char-was-backslash (eq x ?\\ )) ;; or this: / ... \\$/ if the line ends with a backslash (progn (setq search_string (concat search_string "\\\\")) (setq prev-char-was-backslash nil)) (if (and prev-char-was-backslash (not (eq x ?/ )) ) (setq search_string (concat search_string "\\\\"))) (setq prev-char-was-backslash (eq x ?\\ )) (if (not prev-char-was-backslash) (setq search_string (concat search_string (cond ((eq x ?* ) "\\\*" ) ((eq x ?? ) "\\\?" ) ((eq x ?. ) "\\\." ) ((eq x ?+ ) "\\\+" ) ((eq x ?[ ) "\\\[" ) ((eq x ?] ) "\\\]" ) (t (char-to-string x))))))))) search_string)) ;; TAG-INFO is ;; ('vtags-search-string CTAGS_SEARCH_STRING) or ;; (TEXT LINE . POSITION) or ;; (t LINE . POSITION) where TEXT is the initial part ;; a cons (TEXT LINE . POSITION) where TEXT is the initial part ;; of a line containing the tag and POSITION is the character position of ;; TEXT within the file (starting from 1); LINE is the line number. If ;; TEXT is t, it means the tag refers to exactly LINE or POSITION ;; (whichever is present, LINE having preference, no searching. Either ;; LINE or POSITION may be nil; POSITION is used if present. If the tag ;; isn't exactly at the given position then look around that position using ;; a search window which expands until it hits the start of file. (defun etags-goto-tag-location (tag-info) (cond ((eq (car tag-info) 'vtags-search-string) (goto-char (point-min)) (re-search-forward (vtags-regexp-quote (cdr tag-info)))) ((eq (car tag-info) t) ;; Direct file tag. (let ((startpos (cdr (cdr tag-info))) (line (car (cdr tag-info)))) (cond (line (goto-line line)) (startpos (goto-char startpos)) (t (error "etags.el BUG: bogus direct file tag"))))) (t (let ((startpos (cdr (cdr tag-info))) (line (car (cdr tag-info))) offset found pat) ;; This constant is 1/2 the initial search window. ;; There is no sense in making it too small, ;; since just going around the loop once probably ;; costs about as much as searching 2000 chars. (setq offset 1000 found nil) ;; TODO: This seems like a bug. If use-explicit was used when ;; snarfing the tag-info then tag-text may not start at beginning of line. ;; Try list-tags and then select Elf_External_Sym_Shndx from the list. (setq pat ; (concat (if (eq selective-display t) ; "\\(^\\|\^m\\)" "^") (regexp-quote (car tag-info))) ;; The character position in the tags table is 0-origin. ;; Convert it to a 1-origin Emacs character position. (if startpos (setq startpos (1+ startpos))) ;; If no char pos was given, try the given line number. (or startpos (if line (setq startpos (progn (goto-line line) (point))))) (or startpos (setq startpos (point-min))) ;; First see if the tag is right at the specified location. (goto-char startpos) (setq found (looking-at pat)) (while (and (not found) (progn (goto-char (- startpos offset)) (not (bobp)))) (setq found (re-search-forward pat (+ startpos offset) t) offset (* 3 offset))) ; expand search window (or found (re-search-forward pat nil t) (error "Rerun etags: `%s' not found in %s" pat buffer-file-name))))) ;; Position point at the right place ;; if the search string matched an extra Ctrl-m at the beginning. (and (eq selective-display t) (looking-at "\^m") (forward-char 1)) (beginning-of-line)) (defun etags-list-tags (tfi file out-buf) (when (tagfileinfo-etags-p tfi) (save-excursion (tags-get-buffer-and-verify-table tfi) (goto-char (point-min)) (when (re-search-forward (concat "\f\n" "\\(" file "\\)" ",") nil t) (let ((firstline t) (path (save-excursion (forward-line 1) (file-of-tag))) ;; Get the local value in the tags table ;; buffer before switching buffers. (goto-func goto-tag-location-function) tag tag-info end) (forward-line 1) (while (not (or (eobp) (looking-at "\f"))) (setq tag-info (save-excursion (funcall snarf-tag-function t)) tag (car tag-info) end (length tag)) (put-text-property 0 end 'tag-info tag-info tag) (put-text-property 0 end 'file-path path tag) (put-text-property 0 end 'goto-func goto-func tag) (put-text-property 0 end 'action '(lambda () (let ((tag-info (get-text-property (point) 'tag-info)) (goto-func (get-text-property (point) 'goto-func))) (tag-find-file-of-tag (get-text-property (point) 'file-path)) (widen) (funcall goto-func tag-info) ;; TODO should we set placeholders here? )) tag) (put-text-property 0 end 'mouse-face 'highlight tag) (save-excursion (set-buffer out-buf) (when firstline (insert-string (concat "Found in " (tagfileinfo-file tfi) ":\n")) (setq firstline nil)) (insert-string tag) (when (= (aref tag 0) ?\() (insert-string " ...)")) (insert-string "\n")) (forward-line 1)) t))))) (defun vtags-list-tags (tfi file out-buf) (when (not (tagfileinfo-etags-p tfi)) ;; Use perl to match file names from tag file and extract corresponding tags ;; The horror... the horror... (let* ((dir (file-name-directory (tagfileinfo-file tfi))) (tag nil) (entry nil) (firstline t) (output "") (tag-line-list nil) (tag-file (tagfileinfo-file tfi)) (cmd (concat "my $pattern = qw#[^\\t]+\\t" file "#; while ($line = <>) { next if $line =~ /^!/; if ($line =~ /$pattern/) { print \"$line\"; } } "))) ;;(message "command is %s" cmd) (setq output (with-output-to-string (apply 'call-process "perl" ; program nil ; INFILE t ; BUFFER nil ; DISPLAYP (list ; ARGS "-e" cmd tag-file ) ))) (if (featurep 'xemacs) (setq tag-line-list (split-string output "\n" t )) (setq tag-line-list (split-string output "\n"))) ;;(message "taglist is %s" taglist) (dolist (tag-line tag-line-list (not (= (length tag-line-list) 0))) (when firstline (insert-string (concat "Found in " (tagfileinfo-file tfi) ":\n")) (setq firstline nil)) (setq entry (vtags-parse-line tag-line)) (setq tag (tagEntryInfo-name entry)) (vtags-set-action-properties entry tag dir) (insert-string (concat tag "\n" ))) ) )) (defmacro tags-with-face (face &rest body) "Execute BODY, give output to `standard-output' face FACE." (let ((pp (make-symbol "start"))) `(let ((,pp (with-current-buffer standard-output (point)))) ,@body (put-text-property ,pp (with-current-buffer standard-output (point)) 'face ,face standard-output)))) (defun etags-tags-apropos-additional (tfi regexp) "Display tags matching REGEXP from `tags-apropos-additional-actions'." (tags-get-buffer-and-verify-table tfi) (with-current-buffer standard-output (dolist (oba tags-apropos-additional-actions) (princ "\n\n") (tags-with-face 'highlight (princ (car oba))) (princ":\n\n") (let* ((beg (point)) (symbs (car (cddr oba))) (ins-symb (lambda (sy) (let ((sn (symbol-name sy))) (when (string-match regexp sn) (let ((end (progn (princ sy) (point)))) (put-text-property beg end 'action-internal(cadr oba)) (put-text-property beg end 'action (lambda () (funcall (get-text-property (point) 'action-internal) (get-text-property (point) 'item)))) (put-text-property beg end 'item sn) (put-text-property beg end 'mouse-face 'highlight) ) (terpri)))))) (when (symbolp symbs) (if (boundp symbs) (setq symbs (symbol-value symbs)) (insert "symbol `" (symbol-name symbs) "' has no value\n") (setq symbs nil))) (if (vectorp symbs) (mapatoms ins-symb symbs) (dolist (sy symbs) (funcall ins-symb (car sy)))) (sort-lines nil beg (point)))))) (defun etags-tags-apropos (tfi string) (when (tagfileinfo-etags-p tfi) (tags-get-buffer-and-verify-table tfi) (when tags-apropos-verbose (princ "Tags in file `") (tags-with-face 'highlight (princ buffer-file-name)) (princ "':\n\n")) (goto-char (point-min)) (let ((progress-reporter nil)) (when (fboundp 'make-progress-reporter) (make-progress-reporter (format "Making tags apropos buffer for `%s'..." string) (point-min) (point-max))) (while (re-search-forward string nil t) (when (fboundp 'make-progress-reporter) (progress-reporter-update progress-reporter (point))) (beginning-of-line) (let* ( ;; Get the local value in the tags table ;; buffer before switching buffers. (goto-func goto-tag-location-function) (tag-info (save-excursion (funcall snarf-tag-function))) (tag (if (eq t (car tag-info)) nil (car tag-info))) (file-path (save-excursion (if tag (file-of-tag) (save-excursion (next-line 1) (file-of-tag))))) (file-label (if tag (file-of-tag t) (save-excursion (next-line 1) (file-of-tag t)))) (pt (with-current-buffer standard-output (point)))) (if tag (progn (princ (format "[%s]: " file-label)) (princ tag) (when (= (aref tag 0) ?\() (princ " ...)")) (with-current-buffer standard-output (put-text-property pt (point) 'tag-info tag-info) (put-text-property pt (point) 'file-path file-path) (put-text-property pt (point) 'goto-func goto-func) (put-text-property pt (point) 'action '(lambda (x) (tags-go-to-source x))) (put-text-property pt (point) 'mouse-face 'highlight))) (princ (format "- %s" file-label)) (with-current-buffer standard-output (put-text-property pt (point) 'file-path file-path) (put-text-property pt (point) 'action '(lambda () (tag-find-file-of-tag (get-text-property (point) 'file-path)) ;; Get the local value in the tags table ;; buffer before switching buffers. (goto-char (point-min)))) (put-text-property pt (point) 'mouse-face 'highlight)) )) (terpri) (forward-line 1)) (message nil)) (when tags-apropos-verbose (princ "\n")))) (defun etags-tags-table-files () (let ((files nil) beg) (goto-char (point-min)) (while (search-forward "\f\n" nil t) (setq beg (point)) (end-of-line) (skip-chars-backward "^," beg) (or (looking-at "include$") (setq files (cons (buffer-substring beg (1- (point))) files)))) (nreverse files))) (defun etags-tags-included-tables () (let ((files nil) beg) (goto-char (point-min)) (while (search-forward "\f\n" nil t) (setq beg (point)) (end-of-line) (skip-chars-backward "^," beg) (if (looking-at "include$") ;; Expand in the default-directory of the tags table buffer. (setq files (cons (expand-file-name (buffer-substring beg (1- (point)))) files)))) (nreverse files))) ;; Empty tags file support. ;; Recognize an empty file and give it local values of the tags table format ;; variables which do nothing. (defun tags-recognize-empty-tags-table () (and (zerop (buffer-size)) (mapc (lambda (sym) (set (make-local-variable sym) 'ignore)) '(tags-table-files-function tags-completion-table-function find-tag-regexp-search-function find-tag-search-function tags-apropos-function tags-included-tables-function)) (set (make-local-variable 'verify-tags-table-function) (lambda () (zerop (buffer-size)))))) ;; Match qualifier functions for tagnames. ;; These functions assume the etags file format defined in etc/ETAGS.EBNF. ;; This might be a neat idea, but it's too hairy at the moment. ;;(defmacro tags-with-syntax (&rest body) ;; `(let ((current (current-buffer)) ;; (otable (syntax-table)) ;; (buffer (find-file-noselect (file-of-tag))) ;; table) ;; (unwind-protect ;; (progn ;; (set-buffer buffer) ;; (setq table (syntax-table)) ;; (set-buffer current) ;; (set-syntax-table table) ;; ,@body) ;; (set-syntax-table otable)))) ;;(put 'tags-with-syntax 'edebug-form-spec '(&rest form)) ;; exact file name match, i.e. searched tag must match complete file ;; name including directories parts if there are some. (defun tag-exact-file-name-match-p (tag) (and (looking-at ",[0-9\n]") (save-excursion (backward-char (+ 2 (length tag))) (looking-at "\f\n")))) ;; file name match as above, but searched tag must match the file ;; name not including the directories if there are some. (defun tag-file-name-match-p (tag) (and (looking-at ",[0-9\n]") (save-excursion (backward-char (1+ (length tag))) (looking-at "/")))) ;; this / to detect we are after a directory separator is ok for unix, ;; is there a variable that contains the regexp for directory separator ;; on whatever operating system ? ;; Looks like ms-win will lose here :). ;; t if point is at a tag line that matches TAG exactly. ;; point should be just after a string that matches TAG. (defun tag-exact-match-p (tag) ;; The match is really exact if there is an explicit tag name. (or (and (eq (char-after (point)) ?\001) (eq (char-after (- (point) (length tag) 1)) ?\177)) ;; We are not on the explicit tag name, but perhaps it follows. (looking-at (concat "[^\177\n]*\177" (regexp-quote tag) "\001")))) ;; t if point is at a tag line that has an implicit name. ;; point should be just after a string that matches TAG. (defun tag-implicit-name-match-p (tag) ;; Look at the comment of the make_tag function in lib-src/etags.c for ;; a textual description of the four rules. (and (string-match "^[^ \t()=,;]+$" tag) ;rule #1 (looking-at "[ \t()=,;]?\177") ;rules #2 and #4 (save-excursion (backward-char (1+ (length tag))) (looking-at "[\n \t()=,;]")))) ;rule #3 ;; t if point is at a tag line that matches TAG as a symbol. ;; point should be just after a string that matches TAG. (defun tag-symbol-match-p (tag) (and (looking-at "\\Sw.*\177") (looking-at "\\S_.*\177") (save-excursion (backward-char (1+ (length tag))) (and (looking-at "\\Sw") (looking-at "\\S_"))))) ;; t if point is at a tag line that matches TAG as a word. ;; point should be just after a string that matches TAG. (defun tag-word-match-p (tag) (and (looking-at "\\b.*\177") (save-excursion (backward-char (length tag)) (looking-at "\\b")))) ;; partial file name match, i.e. searched tag must match a substring ;; of the file name (potentially including a directory separator). (defun tag-partial-file-name-match-p (tag) (and (looking-at ".*,[0-9\n]") (save-excursion (beginning-of-line) (backward-char 2) (looking-at "\f\n")))) ;; t if point is in a tag line with a tag containing TAG as a substring. (defun tag-any-match-p (tag) (looking-at ".*\177")) ;; t if point is at a tag line that matches RE as a regexp. (defun tag-re-match-p (re) (save-excursion (beginning-of-line) (let ((bol (point))) (and (search-forward "\177" (save-excursion (end-of-line) (point)) t) (re-search-backward re bol t))))) (defcustom tags-loop-revert-buffers nil "*Non-nil means tags-scanning loops should offer to reread changed files. These loops normally read each file into Emacs, but when a file is already visited, they use the existing buffer. When this flag is non-nil, they offer to revert the existing buffer in the case where the file has changed since you visited it." :type 'boolean :group 'etags) ;;;###autoload (defun next-file (&optional initialize novisit) "Select next file among files in current tags table. A first argument of t (prefix arg, if interactive) initializes to the beginning of the list of files in the tags table. If the argument is neither nil nor t, it is evalled to initialize the list of files. Non-nil second argument NOVISIT means use a temporary buffer to save time and avoid uninteresting warnings. Value is nil if the file was already visited; if the file was newly read in, the value is the filename." ;; Make the interactive arg t if there was any prefix arg. (interactive (list (if current-prefix-arg t))) (cond ((not initialize) ;; Not the first run. ) ((eq initialize t) ;; Initialize the list from the tags table. (save-excursion ;; get list of files. (let ((dir nil) (tables (progn (find-tags-table-heuristically) tags-table-computed-list))) (setq next-file-list nil) ;; Iterate over all the tags table files, collecting ;; a complete list of referenced file names. (while tables (setq dir (file-name-directory (tagfileinfo-file (car tables)))) (setq next-file-list (nconc next-file-list (mapcar (lambda (name) (expand-file-name name dir)) (tags-table-files (car tables) "")))) (setq tables (cdr tables)))))) (t ;; Initialize the list by evalling the argument. (setq next-file-list (eval initialize)))) (unless next-file-list (and novisit (get-buffer " *next-file*") (kill-buffer " *next-file*")) (error "All files processed")) (let* ((next (car next-file-list)) (buffer (get-file-buffer next)) (new (not buffer))) ;; Advance the list before trying to find the file. ;; If we get an error finding the file, don't get stuck on it. (setq next-file-list (cdr next-file-list)) ;; Optionally offer to revert buffers ;; if the files have changed on disk. (and buffer tags-loop-revert-buffers (not (verify-visited-file-modtime buffer)) (with-current-buffer buffer (revert-buffer t))) (if (not (and new novisit)) (set-buffer (find-file-noselect next novisit)) ;; Like find-file, but avoids random warning messages. (set-buffer (get-buffer-create " *next-file*")) (kill-all-local-variables) (erase-buffer) (setq new next) (insert-file-contents new nil)) new)) (defvar tags-loop-operate nil "Form for `tags-loop-continue' to eval to change one file.") (defvar tags-loop-scan '(error "%s" (substitute-command-keys "No \\[tags-search] or \\[tags-query-replace] in progress")) "Form for `tags-loop-continue' to eval to scan one file. If it returns non-nil, this file needs processing by evalling \`tags-loop-operate'. Otherwise, move on to the next file.") (defun tags-loop-eval (form) "Evaluate FORM and return its result. Bind `case-fold-search' during the evaluation, depending on the value of `tags-case-fold-search'." (let ((case-fold-search (if (memq tags-case-fold-search '(t nil)) tags-case-fold-search case-fold-search))) (eval form))) ;;;###autoload (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 (the argument is passed to `next-file', which see). Two variables control the processing we do on each file: the value of `tags-loop-scan' is a form to be executed on each file to see if it is interesting (it returns non-nil if so) and `tags-loop-operate' is a form to evaluate to operate on an interesting file. If the latter evaluates to nil, we exit; otherwise we scan the next file." (interactive) (let (new ;; Non-nil means we have finished one file ;; and should not scan it again. file-finished original-point (messaged nil)) (while (progn ;; Scan files quickly for the first or next interesting one. ;; This starts at point in the current buffer. (while (or first-time file-finished (save-restriction (widen) (not (tags-loop-eval tags-loop-scan)))) ;; If nothing was found in the previous file, and ;; that file isn't in a temp buffer, restore point to ;; where it was. (when original-point (goto-char original-point)) (setq file-finished nil) (setq new (next-file first-time t)) ;; If NEW is non-nil, we got a temp buffer, ;; and NEW is the file name. (when (or messaged (and (not first-time) (not (featurep 'xemacs)) (> baud-rate search-slow-speed) (setq messaged t))) (message "Scanning file %s..." (or new buffer-file-name))) (setq first-time nil) (setq original-point (if new nil (point))) (goto-char (point-min))) ;; If we visited it in a temp buffer, visit it now for real. (if new (let ((pos (point))) (erase-buffer) (set-buffer (find-file-noselect new)) (setq new nil) ;No longer in a temp buffer. (widen) (goto-char pos)) (push-mark original-point t)) (switch-to-buffer (current-buffer)) ;; Now operate on the file. ;; If value is non-nil, continue to scan the next file. (tags-loop-eval tags-loop-operate)) (setq file-finished t)) (and messaged (null tags-loop-operate) (message "Scanning file %s...found" buffer-file-name)))) ;;;###autoload (define-key esc-map "," 'tags-loop-continue) ;;;###autoload (defun tags-search (regexp &optional file-list-form) "Search through all files listed in tags table for match for REGEXP. Stops when a match is found. To continue searching for next match, use command \\[tags-loop-continue]." (interactive "sTags search (regexp): ") (if (and (equal regexp "") (eq (car tags-loop-scan) 're-search-forward) (null tags-loop-operate)) ;; Continue last tags-search as if by M-,. (tags-loop-continue nil) (setq tags-loop-scan `(re-search-forward ',regexp nil t) tags-loop-operate nil) (tags-loop-continue (or file-list-form t)))) ;;;###autoload (defun tags-query-replace (from to &optional delimited file-list-form) "Do `query-replace-regexp' of FROM with TO on all files listed in tags table. Third arg DELIMITED (prefix arg) means replace only word-delimited matches. If you exit (\\[keyboard-quit], RET or q), you can resume the query replace with the command \\[tags-loop-continue].." (interactive (query-replace-read-args "Tags query replace (regexp)" t )) (setq tags-loop-scan `(let ,(unless (equal from (downcase from)) '((case-fold-search nil))) (if (re-search-forward ',from nil t) ;; When we find a match, move back ;; to the beginning of it so perform-replace ;; will see it. (goto-char (match-beginning 0)))) tags-loop-operate `(perform-replace ',from ',to t t ',delimited)) (tags-loop-continue (or file-list-form t))) ;;;###autoload (defvar list-tags-file-alist nil) ;; alist, an obarray, or a function ;;;###autoload (defvar list-tags-file-alist-for "") ;; See doc for `minibuffer-completion-table' ;;;###autoload (defun tags-complete-tags-table-file (string predicate what) ;; Check if list needs to be computed or refined (cond ((and list-tags-file-alist (string= list-tags-file-alist-for string)) t ;; string is unchanged, do nothing ) ((and list-tags-file-alist (not (string= "" list-tags-file-alist-for)) (eq 0 (let ((case-fold-search nil)) (string-match list-tags-file-alist-for string)))) ;; Filter list further? EEB No, slows things down. ;; (setq list-tags-file-alist (delete-if ;; (lambda (x) ;; (not (eq 0 (string-match string (car x))))) ;; list-tags-file-alist))) t) ;; Do nothing. (t ;; Recompute (let (;;(enable-recursive-minibuffers t) (tables tags-table-computed-list)) (message "(building completion table...)") (setq list-tags-file-alist nil list-tags-file-alist-for string) (while tables (setq list-tags-file-alist (nconc list-tags-file-alist (mapcar (lambda (x) (cons x t)) (tags-table-files (car tables) string predicate)))) (setq tables (cdr tables)))))) (cond ((not list-tags-file-alist) nil) ((eq what nil) (try-completion string list-tags-file-alist )) ((eq what t) (all-completions string list-tags-file-alist)) ((eq what 'lambda) (assoc string list-tags-file-alist ) ) )) ;;;###autoload (defun list-tags (file) "Display list of tags in file FILE. FILE should be as it appeares in the tags file, usually without a directory specification." (interactive (list (completing-read "List tags in file: " 'tags-complete-tags-table-file nil t nil))) (let ((out-buf (get-buffer-create "*Tags List*")) (tables tags-table-computed-list) (gotany nil)) (set-buffer out-buf) (setq buffer-read-only nil) (erase-buffer) (insert-string "Tags in file `") (insert-string file) (insert-string "':\n\n") (while tables (setq gotany (or (if (tagfileinfo-etags-p (car tables)) (etags-list-tags (car tables) file out-buf) (vtags-list-tags (car tables) file out-buf)) gotany)) (setq tables (cdr tables))) (or gotany (error "File %s not in current tags tables" file)) (switch-to-buffer out-buf) (goto-char (point-min)) (forward-line 1) (vtags-mode) (setq buffer-read-only t))) ;;;###autoload (defun tags-apropos (regexp) "Display list of all tags in tags table REGEXP matches." (interactive "sTags apropos (regexp): ") (with-output-to-temp-buffer "*Tags List*" (princ "Click mouse-2 to follow tags.\n\nTags matching regexp `") (tags-with-face 'highlight (princ regexp)) (princ "':\n\n") (save-excursion (let ((tables tags-table-computed-list)) (while tables ;; TODO (funcall tags-apropos-function tfi regexp)))) (etags-tags-apropos (car tables) regexp) (etags-tags-apropos-additional (car tables) regexp) (setq tables (cdr tables)))))) (with-current-buffer "*Tags List*" (vtags-mode) (setq buffer-read-only t))) ;; PF_ ;; Note, there is another definition of this function in bindings.el. ;;;###autoload (defun complete-tag () "Perform tags completion on the text around point. Completes to the set of names listed in the current tags table. The string to complete is chosen in the same way as the default for \\[find-tag] (which see)." (interactive) (or tags-table-list (error "%s" (substitute-command-keys "No tags table loaded; "))) (let ((completion-ignore-case (if (memq tags-case-fold-search '(t nil)) tags-case-fold-search case-fold-search)) (pattern (funcall (or find-tag-default-function (get major-mode 'find-tag-default-function) 'find-tag-default))) beg completion) (or pattern (error "Nothing to complete")) (search-backward pattern) (setq beg (point)) (forward-char (length pattern)) (setq completion (tags-complete-tag pattern nil nil)) (cond ((eq completion t)) ((null completion) (message "Can't find completion for \"%s\"" pattern) (ding)) ((not (string= pattern completion)) (delete-region beg (point)) (insert completion)) (t (message "Making completion list...") (with-output-to-temp-buffer "*Completions*" (display-completion-list (all-completions pattern 'tags-complete-tag nil))) (message "Making completion list...%s" "done"))))) (dolist (x '("^No tags table in use; use .* to select one$" "^There is no default tag$" "^No previous tag locations$" "^File .* is not a valid tags table$" "^No \\(more \\|\\)tags \\(matching\\|containing\\) " "^Rerun etags: `.*' not found in " "^All files processed$" "^No .* or .* in progress$" "^File .* not in current tags tables$" "^No tags table loaded" "^Nothing to complete$")) (add-to-list 'debug-ignored-errors x)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; New functions for vtags support ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;###autoload (defun tags-activate (&optional other-window-p) "Get the 'action from the properties and do it." (interactive) (let ((action nil)) (beginning-of-line) (setq action (get-text-property (point) 'action)) (funcall action other-window-p))) ;;;###autoload (defun tags-mouse-activate (event) (interactive "e") (if (featurep 'xemacs) (goto-char (mouse-set-point event)) (select-window (posn-window (event-end event))) (goto-char (posn-point (event-end event)))) (tags-activate)) (defun tags-mouse-activate-other-window (event) (interactive "e") (if (featurep 'xemacs) (goto-char (mouse-set-point event)) (select-window (posn-window (event-end event))) (goto-char (posn-point (event-end event)))) (tags-activate t)) (defun tags-go-to-file-and-location (goto-func filepath tag-info &optional other-window-p) (vtags-set-placeholder vtags-the-return-point) (tag-find-file-of-tag filepath other-window-p) (funcall goto-func tag-info) (vtags-set-placeholder (point-marker))) (defun tags-go-to-source (&optional other-window-p) "Called from within a vtag buffer, find the tag nearest point and go to the corresponding location." (interactive) (let ( (tag-info (get-text-property (point) 'tag-info)) (goto-func (get-text-property (point) 'goto-func)) (filepath (get-text-property (point) 'file-path)) ) (tags-go-to-file-and-location goto-func filepath tag-info other-window-p) )) (defun get-tagfileinfo (tagfilename) "Return tagfileinfolist element corresponding to tagfilename. Parse the file header if necessary." (interactive) (if (and tagfilename (file-exists-p tagfilename)) (let ( (tfi (tags-get-tagfile-header tagfilename))) tfi) nil)) (defsubst vtags-insert-chunk (file beg default-chunk-size) "Grab a chunk of the file. The chunk has to be big enough that we are sure to get at least one complete line. That means that the chunk must contain at least two newline characters." (let ((chunk-size default-chunk-size)) (while (eq 0 (buffer-size)) (insert-file-contents-literally file nil beg (+ beg chunk-size)) (unless (eq 0 (forward-line 2)) (progn ;(beep) (warn "tag line length is greater than max %d. Fix your tag file or increase chunk-size in etags.el" chunk-size) (when (< chunk-size 16384) ;; try a bigger chunk (erase-buffer) (setq chunk-size (* 2 chunk-size))))))) (goto-char (point-min))) ;;; Example of tags header generated by Exuberant ctags: ;; ;; !_TAG_FILE_FORMAT 2 /extended format; --format=1 will not append ;" to lines/ ;; !_TAG_FILE_SORTED 1 /0=unsorted, 1=sorted, 2=foldcase/ ;; !_TAG_PROGRAM_AUTHOR Darren Hiebert /dhiebert@users.sourceforge.net/ ;; !_TAG_PROGRAM_NAME Exuberant Ctags // ;; !_TAG_PROGRAM_URL http://ctags.sourceforge.net /official site/ ;; !_TAG_PROGRAM_VERSION 5.5 // (defstruct ;( tagfileinfo ; (:type list) :named) file size format sorted program-name program-url program-version etags-p buffer ; if this is an etags file it might have an associated buffer master ; for keeping track of nested tags tables ) (defun tags-get-tagfile-header (tagfilename) "Some tag files have headers. If this one does, then parse the header, put into tagfileinfo structure. If it doesn't have a header then return default tagfileinfo. Also, if there is no header we assume that this is an etags file (we should perhaps come up with a more sophisticated test)." (interactive (list (read-file-name "File: " "~"))) (let* ((tfi nil) (default-chunk-size 1024) ;;(header-buf (get-buffer-create (concat (file-name-nondirectory tagfilename) "-header"))) (header-buf (get-buffer-create "*Vtags-tagfile-header*")) ;EEB TODO hide this buffer (attr (file-attributes tagfilename)) (filesize (nth 7 attr))) ;; Large tag files require work-around for xemacs. ;; Builting function file-attributes seems to be broken. For large files it reports ;; the wrong size. Only using 31 bits. Note that Gnu/Emacs returns ;; float for large file sizes. Why doesn't xemacs do that? ;; Here is some related code from xemacs/src/dired.c 1.38.6.1: ;; 903 steve 1.1 values[7] = make_int ((EMACS_INT) s.st_size); ;; 904 /* If the size is out of range, give back -1. */ ;; 905 /* #### Fix when Emacs gets bignums! */ ;; 906 if (XINT (values[7]) != s.st_size) ;; 907 steve 1.16 values[7] = make_int (-1); ;; Unfortunately, even this code is wrong since the value being compared ;; is already truncated. It should be something like this: ;; 906 if (s.st_size > 2**31 - 1 ) ... (when (featurep 'xemacs) (when (featurep 'xemacs) (let* ((cmd (concat "perl -e 'my @s = stat(\"" tagfilename "\"); print $s[7];'"))) (when vtags-debugging (message "command is %s" cmd)) (setq filesize (string-to-number (shell-command-to-string cmd))))) ;; Create a tagfileinfo with some real values and some default values (setf tfi (make-tagfileinfo :file tagfilename :size filesize :format "" :sorted 0 :program-name "etags" :program-url "http://www.gnu.org/software/emacs/emacs-lisp-intro/html_node/etags.html" :program-version "GNU Emacs 21.3" :etags-p t :buffer nil :master "")) (save-current-buffer (set-buffer header-buf) (erase-buffer) (insert-file-contents-literally tagfilename nil 0 default-chunk-size) ;; EEB TODO wrap this repetitive stuff in a function (goto-char (point-min)) (if (search-forward-regexp "!_TAG_FILE_FORMAT[ \t\n]*\\([0-9]+\\)" nil t) (progn (setf (tagfileinfo-format tfi) (match-string 1)) (when vtags-debugging (message "format is %s" (tagfileinfo-format tfi))))) (goto-char (point-min)) (if (search-forward-regexp "!_TAG_FILE_SORTED[ \t\n]*\\([0-9]+\\)" nil t) (progn (setf (tagfileinfo-sorted tfi) (match-string 1)) (when vtags-debugging (message "sorted is %s" (tagfileinfo-sorted tfi))) )) (goto-char (point-min)) (if (search-forward-regexp "!_TAG_PROGRAM_NAME[ \t\n]*\\([^\n]+\\)" nil t) (progn (setf (tagfileinfo-program-name tfi) (match-string 1)) (when vtags-debugging (message "program name is %s" (tagfileinfo-program-name tfi))) )) (goto-char (point-min)) (if (search-forward-regexp "!_TAG_PROGRAM_URL[ \t\n]*\\([^ \t\n]+\\)" nil t) (progn (setf (tagfileinfo-program-url tfi) (match-string 1)) (when vtags-debugging (message "program url is %s" (tagfileinfo-program-url tfi))) )) (goto-char (point-min)) (if (search-forward-regexp "!_TAG_PROGRAM_VERSION[ \t\n]*\\([0-9\\.]+\\)" nil t) (progn (setf (tagfileinfo-program-version tfi) (match-string 1)) ;; if there is no header we assume that this is an etags file ;; (we should perhaps come up with a more sophisticated test) (setf (tagfileinfo-etags-p tfi) nil) (when vtags-debugging (message "version is %s" (tagfileinfo-program-version tfi))) )) (when vtags-debugging (message "file is %s, which %s an etags file" (tagfileinfo-file tfi) (if (tagfileinfo-etags-p tfi) "is" "is not"))) tfi ))) ;; vtags-look (defun vtags-look (tag tfi callback-func) "Like unix look command. Does a binary search on file looking for tag. For each match, calls (callback-func line match-count). Returns the number of matched lines." ;; TODO deal with unsorted tags files (if (equal "0" (tagfileinfo-sorted tfi)) (error "vtags-look is being called on unsorted file %s" (tagfileinfo-file tfi)) (let ((vtags-look-buf (get-buffer-create "*Vtags-Look-Buffer*")) ; scratch buffer (blksize 4096) ; big enough to hold all matching entries (default-chunk-size 4096) ; twice the length of longest line (max-block 0) (min-block 0) (mid 0) (beg 0) (match-count 0) (done nil) (tag-length (length tag)) (size (tagfileinfo-size tfi)) (file (tagfileinfo-file tfi)) (folding (equal "2" (tagfileinfo-sorted tfi))) tmp-string tag-line) (setq max-block (truncate (/ size blksize))) (set-buffer vtags-look-buf) (setq buffer-read-only nil) (if folding (setq tag (upcase tag))) (when vtags-debugging (message "vtags-look file is %s, size is %f, folding is %s" file size folding)) ;; ;; Do a binary search on the file. ;; Stop when we have narrowed the search down ;; to a particular block within the file. ;; (while (> max-block (+ 1 min-block)) (setq mid (truncate (/ (+ max-block min-block) 2))) (setq beg (truncate (* mid blksize))) (when vtags-debugging (progn (message "min-block is %d" min-block ) (message "mid is %d" mid) (message "max-block is %d" max-block) (message "Set beg to %d" beg))) (erase-buffer) ;; Get a chunk of the tag file (vtags-insert-chunk file beg default-chunk-size) ;; skip past partial line (forward-line 1) ;; Put line into tmp-string (setq tmp-string (buffer-substring-no-properties (point) (min (point-max) (+ (point) tag-length)))) ;; Compare with tag (if folding (setq tmp-string (upcase tmp-string))) (if (string-lessp tmp-string tag) (progn (setq min-block mid) (when vtags-debugging (message "%s < %s" tmp-string tag)) ) (when vtags-debugging (message "%s >= %s" tmp-string tag)) (setq max-block mid))) ;; ;; Begin linear search on block (actually 2 blocks since ;; matching lines could span block boundary) ;; (erase-buffer) (setq beg (* min-block blksize)) ;; read the block into buffer (insert-file-contents-literally file nil beg (+ beg (* 2 blksize ))) (if min-block (forward-line)) ;; skip past partial line (setq case-fold-search folding) ;;(message "case-fold-search is %s" case-fold-search) (search-forward tag nil t) (beginning-of-line) (while (and (not done) (not (= (point) (point-max)))) (let* ((beg (progn (beginning-of-line) (point))) (end (progn (end-of-line) (point)))) (if (not (looking-at "\n")) ;; This is just a fragment at the end of the buffer (setq done t) ;; read a line (setq tag-line (buffer-substring-no-properties beg end)) (when vtags-debugging (message "Checking %s" tag-line)) (when (< tag-length (length tag-line)) ;; are we past all lines which could match ? (setq tmp-string (substring tag-line 0 tag-length)) (when folding (setq tmp-string (upcase tmp-string))) (if (string-lessp tag tmp-string) (setq done t) ;; save lines which match (when (string-equal tag tmp-string) ;; TODO do regexp matching (setq match-count (1+ match-count)) (let* ((line (concat tag-line "\n") )) (funcall callback-func line match-count))))) (forward-line 1)))) match-count))) (defun vtags-set-action-properties (entry line dir) "Set the text properties based on the parsed entry and directory." (let* ( (beg 0) (end (length line)) (filepath (expand-file-name (tagEntryInfo-file entry) dir)) (lineNumber (tagEntryInfo-lineNumber entry)) (pattern (tagEntryInfo-pattern entry)) (tag-info nil) ) (if (not (= 0 lineNumber)) ;; line number given (setq tag-info (cons 't (cons lineNumber nil))) ;; else search string given (setq tag-info (cons 'vtags-search-string pattern))) (put-text-property beg end 'tag-info tag-info line) (put-text-property beg end 'file-path filepath line) (put-text-property beg end 'goto-func 'etags-goto-tag-location line) (put-text-property beg end 'action '(lambda (x) (tags-go-to-source x)) line) (put-text-property beg (1- end) 'mouse-face 'highlight line) ;; return parsed entry )) (defstruct extensionField access ;; const char* ;;; fileScope ;; const char* ;;; implementation ;; const char* ;;; inheritance ;; const char* ;;; scope1 ;; const char* scope [;;]; /* value and key */ scope2 ;; const char* scope [;;]; /* value and key */ signature ;; const char* ;;; ) (defstruct tagEntryInfo name ; name of tag file ; path of source file pattern ; pattern for locating source line ; (may be NULL if not present) lineNumber ; line number in source file of tag definition ; (may be zero if not known) kind ; kind of tag (may by name, character, or NULL) fileScope ; is tag of file-limited scope? count ; number of entries in extensionFields extensionFields ; list of key value pairs ) (defun vtags-parse-line (line) "Parse the CTags line. See parseTagLine() in Exuberant Ctags readtags.c" (let* ( (tab (string-match "\t" line)) (entry (make-tagEntryInfo :name (substring line 0 tab) ; name of tag :file nil ; path of source file :pattern nil ; pattern for locating source line ; (may be NULL if not present) :lineNumber 0 ; line number in source file of tag definition ; (may be zero if not known) :kind nil ; kind of tag (may by name, character, or NULL) :fileScope nil ; is tag of file-limited scope? :count 0 ; number of entries in extensionFields :extensionFields nil ; list of key value pairs )) (p 0) ;; pointer into line? ) (when tab (setq p (1+ tab)) (setq tab (string-match "\t" line p)) (setf (tagEntryInfo-file entry) (substring line p tab)) (when tab (setq p (1+ tab)) (if (or (= (aref line p) '?') (= (aref line p) ?/ )) ;;parse pattern */ (let ((start (1+ p)) (delimiter (aref line p))) ;; get non-backslashed delimiter (setq p (string-match (make-string 1 delimiter) line (1+ p))) (while (and p (= (aref line (1- p)) ?\ )) (setq p (string-match delimiter line (1+ p)))) (if (not p) (error "invalid pattern delimiter in %s" line) (setf (tagEntryInfo-pattern entry) (substring line start p)) (setq p (1+ p)))) (if (string-match "\\([0-9]+\\)" line p) ;; parse line number (setf (tagEntryInfo-lineNumber entry) (string-to-int (match-string 1 line))) (error "invalid pattern %s" line) ))) (when (string-match ";\"" line p) (setf (tagEntryInfo-extensionFields entry) (vtags-parse-extension-fields entry line (+ p 2)))) ) entry)) ;; TODO test this (defun vtags-parse-extension-fields (entry line p) (let* ((tab 0) (field nil) (colon 0) (key nil) (value nil)) (while (< p (length line)) ;; skip past leading tabs (if (= (aref line p) ?\t) (setq p (1+ p)) (setq tab (or (string-match "\t" line p) (length line))) (setq field (substring line p tab)) (setq colon (string-match ":" field )) (if (not colon) (progn (setf (tagEntryInfo-kind entry) field) (setq p (1+ tab))) (setq key (substring line p (+ p colon))) (setq value (substring line (+ p 1 colon) tab)) (cond ((string= key "kind") (setf (tagEntryInfo-kind entry) value)) ((string= key "file") (setf (tagEntryInfo-fileScope entry) 1)) ((string= key "line") (setf (tagEntryInfo-lineNumber entry) (string-to-number value))) (t (setf (tagEntryInfo-extensionFields entry) (cons (cons key value) (tagEntryInfo-extensionFields entry))) (setf (tagEntryInfo-count entry) (1+ (tagEntryInfo-count entry) )) ))) (setq p (1+ tab)))))) (defsubst vtags-insert-string-into-buffer (the-string the-buffer property-func) "Insert string with properties." (save-excursion (set-buffer the-buffer) (when property-func (funcall property-func the-string)) (insert-string the-string) )) (defvar vtags-keymap nil "Local keymap for vtags-menu buffers") (if vtags-keymap nil (setq vtags-keymap (make-keymap)) (suppress-keymap vtags-keymap) (define-key vtags-keymap " " 'tags-activate) (define-key vtags-keymap [(shift button2)] 'tags-mouse-activate-other-window) (define-key vtags-keymap [button2] 'tags-mouse-activate) (define-key vtags-keymap [mouse-2] 'tags-mouse-activate) (define-key vtags-keymap "q" (lambda () (interactive) (bury-buffer) nil)) (define-key vtags-keymap "f" 'tags-activate) ) (defun vtags-mode () "Set major-mode to vtags-mode" (interactive) (setq truncate-lines t) (setq buffer-read-only t) (setq major-mode 'vtags-mode) (setq mode-name "Vtags") (use-local-map vtags-keymap)) (if (featurep 'xemacs) (copy-face 'default 'vt-face)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; placeholder stuff ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; Placeholders are set at your departure and arrival points ; when you jump to tags. You can navigate forward and back through ; the places to which you have tagged. (defvar vtags-placeholder-alist nil "Alist of elements (key . CONTENTS), one for each vtags placeholder.") (defvar vtags-current-placeholder nil "vtags-current-placeholder") (defun vtags-prev-placeholder () "vtags-prev-placeholder" (interactive) (vtags-jump-to-placeholder (1- 0))) (defun vtags-goto-current-placeholder () "vtags-goto-current-placeholder" (interactive) (vtags-jump-to-placeholder 0)) (defun vtags-next-placeholder () "next-placeholder" (interactive) (vtags-jump-to-placeholder 1)) (defun vtags-reset-placeholders () "reset-placeholders" (interactive) (setq vtags-placeholder-alist nil) (setq vtags-current-placeholder nil)) (defun vtags-current-char () "vtags-current-char" (if vtags-current-placeholder (car (car vtags-current-placeholder)) 0)) (defun vtags-get-placeholder () "Return contents of current placeholder, or nil if none." (if vtags-current-placeholder (car vtags-current-placeholder) nil)) (defun vtags-set-placeholder (value) "Store the marker in the vtags placeholder list" (interactive "S") (let (aelt char) (progn (setq char (1+ (vtags-current-char))) (setq aelt (cons char value)) (if (not (equal vtags-placeholder-alist vtags-current-placeholder)) (setq vtags-placeholder-alist vtags-current-placeholder)) (setq vtags-placeholder-alist (cons aelt vtags-placeholder-alist)) (setq vtags-current-placeholder vtags-placeholder-alist)))) (defun vtags-point-to-placeholder () "Store current location of point in placeholder PLACEHOLDER." (interactive) (vtags-set-placeholder (point-marker))) (defalias 'vtags-placeholder-to-point 'vtags-jump-to-placeholder) (defun vtags-placeholder-find (item) "Find the first occurrence of ITEM in placeholder-alist. Return the sublist of placeholder-alist whose car is ITEM." (let ((tmp-list vtags-placeholder-alist)) (while (and tmp-list (not (equal item (car (car tmp-list))))) (setq tmp-list (cdr tmp-list))) tmp-list)) (defun vtags-jump-to-placeholder (direction) "Move point to location stored in the next curr or prev (+ 0 -) placeholder." (interactive) ;; (message "direction is %d" direction) (cond ((> 0 direction) (if (consp (cdr vtags-current-placeholder)) (setq vtags-current-placeholder (cdr vtags-current-placeholder)) (message "At beginning of vtags-placeholder-alist"))) ((< 0 direction) (let ( ;; (tmp-placeholder (member* (1+ (vtags-current-char)) placeholder-alist ;; :key 'car )) (tmp-placeholder (vtags-placeholder-find (1+ (vtags-current-char))))) (if tmp-placeholder (setq vtags-current-placeholder tmp-placeholder) (message "At end of vtags-placeholder-alist"))))) (let ((val (cdr (car vtags-current-placeholder)))) (cond ((markerp val) (or (marker-buffer val) (error "That placeholder's buffer no longer exists")) (switch-to-buffer (marker-buffer val)) (goto-char val)) ((and (consp val) (eq (car val) 'file)) (find-file (cdr val))) (t (error "Placeholder doesn't contain a buffer position"))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; tags-table-list defined here because it depends on previous stuff ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun tags-compute-list (input-list) "Compute a list of tagfileinfo from paths in `input-list'. Looks for and includes nested tags tables. Skip over nonexistent files." (let ((expanded-list (mapcar 'tags-expand-table-name input-list))) (let* ((compute-for (mapcar 'copy-sequence expanded-list)) (tables (copy-sequence compute-for)) ;Mutated in the loop. (computed nil) (tfi nil) ) (while tables (setq tfi (get-tagfileinfo (car tables))) (when tfi (setq computed (cons tfi computed)) (when (tagfileinfo-etags-p tfi) (save-excursion (tags-get-buffer-and-verify-table tfi) ;; Check for includes and append them ;; TODO (setq tables (paths-unique-append tables (etags-tags-included-tables))))) (setq tables (append tables (etags-tags-included-tables)))))) (setq tables (cdr tables))) ;; return value (nreverse computed)))) (defun set-tags-table-list (theList theValue) (set-default theList theValue) (setq tags-table-computed-list (tags-compute-list theValue)) ) ;;;###autoload (defcustom tags-table-list (list "~/tags") "*List of file names of tags tables to search. An element that is a directory means the file \"TAGS\" in that directory. To switch to a new list of tags tables, setting this variable is sufficient. Use the `etags' or `ctags' programs to make a tags table file." :group 'etags :type '(repeat file) :set #'(lambda (x y) (set-tags-table-list x y))) (provide 'etags) (provide 'vtags) ;;; arch-tag: b897c2b5-08f3-4837-b2d3-0e7d6db1b63e ;;; etags.el ends here