* Re: From etags to ctags?
2014-06-04 18:00 ` Stefan Monnier
@ 2014-06-04 18:44 ` John Yates
2014-06-04 19:40 ` Stefan Monnier
0 siblings, 1 reply; 6+ messages in thread
From: John Yates @ 2014-06-04 18:44 UTC (permalink / raw)
To: Stefan Monnier; +Cc: Edward Bishop, Danil Orlov, Emacs developers
[-- Attachment #1.1: Type: text/plain, Size: 2251 bytes --]
On Wed, Jun 4, 2014 at 2:00 PM, Stefan Monnier <monnier@iro.umontreal.ca>
wrote:
> > How do you think, does it make sense to create direct support of ctags
> > format, like it done for etags now?
>
> Sure. And it wouldn't surprise me if such support already exists "out
> there".
>
For instance Edward Bishop's vtags fork? He has indicated to me (see
below) that he would be delighted if someone wanted to assume ownership.
I have been using vtags for years and hence have never given any thought to
the fact that I get the benefits of exuberant ctags additional annotations
for free.
/john
---------- Forwarded message ----------
From: Edward Bishop <binutils@gmail.com>
Date: Tue, Aug 27, 2013 at 5:34 PM
Subject: Re: vatgs?
To: John Yates <john@yates-sheets.org>
Hi John,
I have been using Exuberant Ctags 5.6, Copyright (C) 1996-2004 Darren
Hiebert.
I create a tags file in my source tree with the command
% ctags -R .
My .emacs has
(load "~/vtags")
(global-set-key [f12] 'vtags-find);
(global-set-key [kp-next] 'vtags-next-placeholder);
(global-set-key [kp-end] 'vtags-prev-placeholder);
(global-set-key [kp-multiply] 'vtags-point-to-placeholder)
Let me know if you have any questions.
-Edward
On Mon, Aug 26, 2013 at 6:27 PM, Edward Bishop <binutils@gmail.com> wrote:
> Got busy today, I'll try to get to it tomorrow.
>
>
> On Saturday, August 24, 2013, Edward Bishop wrote:
>
>> Oops, I meant to say etags compatibility, not gtags compatibility.
>>
>>
>> On Sat, Aug 24, 2013 at 10:27 AM, Edward Bishop <binutils@gmail.com>
>> wrote:
>>
>>> Hi John,
>>> I would be delighted if someone would take ownership!
>>> I have a couple of versions. At one point I was trying to maintain
>>> compatibility with gtags but that was a nightmare. What I use now is a
>>> simpler stripped down version. I'm on the road right now, but I'll send you
>>> the latest when I get home tomorrow.
>>> -Edward
>>>
>>>
>>> On Saturday, August 24, 2013, John Yates wrote:
>>>
>>>> Do you have a version more recent than 1.6? Would you mind if someone
>>>> else
>>>> took more public ownership?
>>>>
>>>> /john
>>>>
>>>> _______________________________________________
>>>> Message sent via/by Savannah
>>>> http://savannah.gnu.org/
>>>>
>>>>
>>
[-- Attachment #1.2: Type: text/html, Size: 4388 bytes --]
[-- Attachment #2: vtags.el_20130827 --]
[-- Type: application/octet-stream, Size: 109836 bytes --]
;;; vtags.el --- vtags facility for Emacs
;; Copyright (C) 1985, 1986, 1988, 1989, 1992, 1993, 1994, 1995, 1996, 1998,
;; 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009,
;; 2010
;; Free Software Foundation, Inc.
;; Author: Edward Bishop
;; Maintainer:
;; 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 vtags.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 vtags-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 vtags-find 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 vtags-find-internal, etc. Now vtags-find-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 vtags-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.
;;
;; Eliminated `tags-table-computed-list'. There is no evidence that
;; this optimization was needed. Let Emacs and the OS cache file stats
;; if needed.
;;
;; 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 vtags-tags-apropos-additional
;; Or has this functionality been subsumed into vtags-find?
;; 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 vtags-goto-etag-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
;; vtags-find 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
;;
;; In old versions of etags, 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
;; 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:
;; Search up the directory tree from the current working directory for a
;; file named "tags"
;;
;; 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.
;;
;;; 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)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Define custom list widget like editable-list but with
;;; UP button
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-widget 'vtags-move-up-button 'push-button
"A up button for the `vtags-list' widget."
:tag "UP"
:help-echo "Move this item up in the list" ;; 'vtags-help-echo
:action 'vtags-widget-move-up-button-action)
(defun vtags-help-echo (widget)
(format "%d" (line-number (widget-get widget :from))))
(defun vtags-widget-move-up-button-action (widget &optional event)
;; Ask the parent to move item up.
(widget-apply (widget-get widget :parent)
:move-up (widget-get widget :widget)))
(define-widget 'vtags-list 'editable-list
"asdfasdf"
:format "%{%t%}:\n%v%i\n"
:value-create 'vtags-widget-list-value-create
:insert-before 'vtags-widget-list-insert-before
:move-up 'vtags-widget-list-move-up)
(defun vtags-widget-list-move-up (widget before)
"Move widget up in list by swapping value with widget above"
(save-excursion
(let (
(children (widget-get widget :children))
(children-ptr (widget-get widget :children))
(inhibit-read-only t)
before-change-functions
after-change-functions)
(cond (before
(goto-char (widget-get before :entry-from)))
(t
(goto-char (widget-get widget :value-pos))))
; Do nothing if already at top of list
(when (not (eq (car children) before))
(let (
val
newvals
)
; Find the corresponding place in children
(while (not (eq (cadr children-ptr) before))
(setq children-ptr (cdr children-ptr)))
; Swap the values in children
(setq val (widget-get (cadr children-ptr) :value))
(widget-put (cadr children-ptr) :value (widget-get (car children-ptr) :value))
(widget-put (car children-ptr) :value val)
; Strangly enough, these are not equal!
;(widget-get (car children-ptr) :value)
;(widget-value (car children-ptr) )
; Get the re-ordered list of values from children
; and set them in the parent widget.
(setq newvals (mapcar (lambda (x) (widget-get x :value)) children))
(widget-value-set widget newvals)
))))
(widget-setup)
(widget-apply widget :notify widget event)
)
(defun vtags-widget-print (w indent)
(let ((indent-str (concat "%" (number-to-string (* 2 indent)) "s"))
(children (widget-get w :children))
(buttons (widget-get w :buttons))
)
(message (concat indent-str "line %d: type: %s value: %s" )
""
(line-number (widget-get w :from))
(widget-type w)
(widget-get w :value ))
(while children
(vtags-widget-print (car children) (+ 1 indent))
(setq children (cdr children)))
(while buttons
(vtags-widget-print (car buttons) (+ 1 indent))
(setq buttons (cdr buttons)))
))
(defun vtags-widget-list-insert-before (widget before)
;; Insert a new child in the list of children.
(save-excursion
(let ((children (widget-get widget :children))
(inhibit-read-only t)
before-change-functions
after-change-functions)
(cond (before
(goto-char (widget-get before :entry-from)))
(t
(goto-char (widget-get widget :value-pos))))
(let ((child (vtags-widget-list-entry-create
widget nil nil)))
(when (< (widget-get child :entry-from) (widget-get widget :from))
(set-marker (widget-get widget :from)
(widget-get child :entry-from)))
(if (eq (car children) before)
(widget-put widget :children (cons child children))
(while (not (eq (car (cdr children)) before))
(setq children (cdr children)))
(setcdr children (cons child (cdr children)))))))
(widget-setup)
(widget-apply widget :notify widget))
(defun vtags-widget-list-value-create (widget)
;; Insert all values
(let* ((value (widget-get widget :value))
(type (nth 0 (widget-get widget :args)))
(inlinep (widget-get type :inline))
children)
(widget-put widget :value-pos (copy-marker (point)))
(set-marker-insertion-type (widget-get widget :value-pos) t)
(while value
(let (
(answer (widget-match-inline type value))
(entry-create (widget-get widget :entry-create))
)
(if answer
(setq children (cons
(vtags-widget-list-entry-create
widget
(if inlinep
(car answer)
(car (car answer)))
t)
children)
value (cdr answer))
(setq value nil))))
(widget-put widget :children (nreverse children))))
(defun vtags-widget-list-entry-create (widget value conv)
;; Create a new entry to the list.
(let ((type (nth 0 (widget-get widget :args)))
(widget-push-button-gui widget-editable-list-gui)
child delete insert up-button)
(widget-specify-insert
(save-excursion
(and (widget-get widget :indent)
(insert-char ?\ (widget-get widget :indent)))
(insert (widget-get widget :entry-format)))
;; Parse % escapes in format.
(while (re-search-forward "%\\(.\\)" nil t)
(let ((escape (aref (match-string 1) 0)))
(replace-match "" t t)
(cond ((eq escape ?%)
(insert "%"))
((eq escape ?u)
(setq up-button (apply 'widget-create-child-and-convert
widget 'vtags-move-up-button
(widget-get widget :vtags-move-up-button-args))))
((eq escape ?i)
(setq insert (apply 'widget-create-child-and-convert
widget 'insert-button
(widget-get widget :insert-button-args))))
((eq escape ?d)
(setq delete (apply 'widget-create-child-and-convert
widget 'delete-button
(widget-get widget :delete-button-args))))
((eq escape ?v)
(if conv
(setq child (widget-create-child-value
widget type value))
(setq child (widget-create-child-value
widget type (widget-default-get type)))))
(t
(signal 'error (list "Undefined escape" escape))))))
(widget-put widget
:buttons (cons up-button
(cons delete
(cons insert
(widget-get widget :buttons)))))
(let ((entry-from (copy-marker (point-min)))
(entry-to (copy-marker (point-max))))
(set-marker-insertion-type entry-from t)
(set-marker-insertion-type entry-to nil)
(widget-put child :entry-from entry-from)
(widget-put child :entry-to entry-to)))
(widget-put up-button :widget child)
(widget-put insert :widget child)
(widget-put delete :widget child)
child))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defgroup vtags 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 'vtags
:type '(choice (const :tag "Case-sensitive" nil)
(const :tag "Case-insensitive" t)
(other :tag "Use default" default))
:version "21.1")
;;;###autoload
(defcustom tags-compression-info-list '("" ".Z" ".bz2" ".gz" ".tgz")
"*List of extensions tried by vtags 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 'vtags)
;; !!! 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 'vtags
:type 'boolean)
; ;;;###autoload
(defcustom vtags-find-hook nil
"*Hook to be run by \\[vtags-find] after finding a tag. See `run-hooks'.
The value in the buffer in which \\[vtags-find] is done is used,
not the value in the buffer \\[vtags-find] goes to."
:group 'vtags
:type 'hook)
; ;;;###autoload
(defcustom vtags-find-default-function nil
"*A function of no arguments used by \\[vtags-find] to pick a default tag.
If nil, and the symbol that is the value of `major-mode'
has a `vtags-find-default-function' property (see `put'), that is used.
Otherwise, `vtags-find-default' is used."
:group 'vtags
:type '(choice (const nil) function))
(defcustom vtags-find-marker-ring-length 16
"*Length of marker rings `vtags-find-marker-ring' and `vtags-location-ring'."
:group 'vtags
:type 'integer
:version "20.3")
(defcustom tags-tag-face 'default
"*Face for tags in the output of `tags-apropos'."
:group 'vtags
: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 'vtags
: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 'vtags
:type '(repeat (list (string :tag "Title")
function
(sexp :tag "Tags to search")))
:version "21.1")
(defvar vtags-find-marker-ring (make-ring vtags-find-marker-ring-length)
"Ring of markers which are locations from which \\[vtags-find] was invoked.")
(defvar vtags-default-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 vtags-location-ring (make-ring vtags-find-marker-ring-length)
"Ring of markers which are locations visited by \\[vtags-find].
Pop back to the last location with \\[negative-argument] \\[vtags-find].")
(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 t)
;; Hooks for file formats.
(defvar vtags-table-format-functions '(vtags-recognize-etags-table
vtags-recognize-empty-etags-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 vtags-file-of-tag-function nil
"Function to do the work of `vtags-file-of-tag' (which see).
One optional argument, a boolean specifying to return complete path (nil) or
relative path (non-nil).")
(defvar vtags-table-files-function nil
"Function to do the work of `vtags-table-files' (which see).")
(defvar vtags-completion-table-function nil
"Function to build the `tags-completion-table'.")
(defvar vtags-snarf-function nil
"Function to get info about a matched tag for `vtags-goto-location-function'.
One optional argument, specifying to use explicit tag (non-nil) or not (nil).
The default is nil.")
(defvar vtags-goto-location-function nil
"Function of to go to the location in the buffer specified by a tag.
One argument, the tag info returned by `vtags-snarf-function'.")
(defvar vtags-find-regexp-search-function nil
"Search function passed to `vtags-find-in-order' for finding a regexp tag.")
(defvar vtags-find-regexp-tag-order nil
"Tag order passed to `vtags-find-in-order' for finding a regexp tag.")
(defvar vtags-find-regexp-next-line-after-failure-p nil
"Flag passed to `vtags-find-in-order' for finding a regexp tag.")
(defvar vtags-find-search-function nil
"Search function passed to `vtags-find-in-order' for finding a tag.")
(defvar vtags-find-tag-order nil
"Tag order passed to `vtags-find-in-order' for finding a tag.")
(defvar vtags-find-next-line-after-failure-p nil
"Flag passed to `vtags-find-in-order' for finding a tag.")
(defvar vtags-list-function nil
"Function to do the work of `vtags-list' (which see).")
(defvar vtags-apropos-function nil
"Function to do the work of `tags-apropos' (which see).")
(defvar vtags-included-tables-function nil
"Function to do the work of `tags-included-tables' (which see).")
(defvar vtags-verify-table-function nil
"Function to return t iff current buffer contains valid tags file.")
(defun vtags-decend-tree ()
"Find a tags or TAGS file in current or parent directories
and return the tagFileInfo struct."
(let (
(cur default-directory)
result
)
(while (and (not result) (not (and (equal (file-name-as-directory cur) cur)
(equal (directory-file-name cur) cur))))
(let ((files (directory-files cur)))
(if (member "tags" files)
(setq result (expand-file-name "tags" cur))
(if (member "TAGS" files)
(setq result (expand-file-name "TAGS" cur)))))
(setq cur (expand-file-name ".." cur)))
(if result (vtags-get-tagfile-header result) nil)
))
;; 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 vtags-initialize-new-etags-table ()
(set (make-local-variable 'vtags-table-files) nil)
;; We used to initialize vtags-find-marker-ring and vtags-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 'vtags-table-format-functions))
;; Expand tags table name FILE into a complete file name.
(defun vtags-expand-table-name (file)
(let ((result (expand-file-name file)))
(if (file-directory-p file)
(let ((files (directory-files file)))
(if (member "tags" files)
(setq result (expand-file-name "tags" file))
(if (member "TAGS" files)
(setq result (expand-file-name "TAGS" file))
(setq result nil)))))
result))
(defun vtags-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 vtags-verify-table-function (vtags-initialize-new-etags-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 vtags-verify-table-function
(funcall vtags-verify-table-function))
(revert-buffer t t)
(vtags-initialize-new-etags-table)))
(and file
(file-exists-p file)
(set-buffer (find-file-noselect file t t))
(vtags-initialize-new-etags-table))))))
(defun vtags-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 vtags-file-of-tag-function (funcall vtags-file-of-tag-function relative)))
; ;;;###autoload
(defun vtags-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
(vtags-get-buffer-and-verify-table tfi)
(vtags-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 vtags-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 vtags-table-files
(and vtags-table-files-function
(setq vtags-table-files
(funcall vtags-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 vtags-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))
(vtags-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 vtags-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
(vtags-get-buffer-and-verify-table tfi)
(vtags-etags-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-list on demand.
(defun vtags-complete-tag (string predicate what)
(if (eq what t)
(all-completions
string
(vtags-completion-table-from-tag-table-list
string
predicate
(vtags-compute-list vtags-table-list))
predicate)
(try-completion
string
(vtags-completion-table-from-tag-table-list
string
predicate
(vtags-compute-list vtags-table-list))
predicate)))
;; Return a default tag to search for, based on the text at point.
(defun vtags-find-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 vtags-find-tag (string)
(let* ((completion-ignore-case (if (memq tags-case-fold-search '(t nil))
tags-case-fold-search
case-fold-search))
(default (funcall (or vtags-find-default-function
(get major-mode 'vtags-find-default-function)
'vtags-find-default)))
(spec (completing-read (if default
(format "%s (default %s): "
(substring string 0 (string-match "[ :]+\\'" string))
default)
string)
'vtags-complete-tag
nil nil nil nil default)))
(if (equal spec "")
(or default (error "There is no default tag"))
spec)))
(defvar vtags-last-tag nil
"Last tag found by \\[vtags-find].")
;; Get interactive args for vtags-find{-noselect,-other-window,-regexp}.
(defun vtags-find-interactive (prompt &optional no-default)
(if (and current-prefix-arg vtags-last-tag)
(list nil (if (< (prefix-numeric-value current-prefix-arg) 0)
'-
t))
(list (if no-default
(read-string prompt)
(vtags-find-tag prompt)))))
(defvar vtags-find-history nil)
;; Dynamic bondage:
(eval-when-compile
(defvar vtags-case-fold-search)
(defvar vtags-syntax-table))
(defalias 'vtags-find 'vtags-find)
; ;;;###autoload
(defun vtags-find (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 \\[vtags-pop-tag-mark].
Contrast this with the ring of marks gone to by the command."
(interactive (vtags-find-interactive "Find tag: "))
(vtags-find-internal tagname regexp-p nil))
; ;;;###autoload (define-key esc-map "." 'vtags-find)
; ;;;###autoload
(defun vtags-find-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 \\[vtags-pop-tag-mark].
Contrast this with the ring of marks gone to by the command."
(interactive (vtags-find-interactive "Find tag other window: "))
(vtags-find-internal tagname regexp-p t))
; ;;;###autoload (define-key ctl-x-4-map "." 'vtags-find-other-window)
; ;;;###autoload
(defun vtags-find-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 \\[vtags-pop-tag-mark].
Contrast this with the ring of marks gone to by the command."
(interactive (vtags-find-interactive "Find tag other frame: "))
(let ((pop-up-frames t))
(vtags-find-other-window tagname)))
; ;;;###autoload (define-key ctl-x-5-map "." 'vtags-find-other-frame)
; ;;;###autoload
(defun vtags-find-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 \\[vtags-pop-tag-mark].
Contrast this with the ring of marks gone to by the command."
(interactive (vtags-find-interactive "Find tag regexp: " t))
;; We go through vtags-find-other-window to do all the display hair there.
(funcall (if other-window 'vtags-find-other-window 'vtags-find)
regexp t))
; ;;;###autoload (define-key esc-map [?\C-.] 'vtags-find-regexp)
; ;;;###autoload (define-key esc-map "*" 'vtags-pop-tag-mark)
; ;;;###autoload
(defun vtags-pop-tag-mark ()
"Pop back to where \\[vtags-find] was last invoked.
This is distinct from invoking \\[vtags-find] 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 vtags-find-marker-ring)
(error "No previous locations for vtags-find invocation"))
(let ((marker (ring-remove vtags-find-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 vtags-find-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 (vtags-find-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 `vtags-find-hook' before
;; selecting the tags table buffer.
;;(tables (list (find-tags-table-heuristically)))
(tables
(if vtags-default-table-function
(funcall vtags-default-table-function)
(vtags-compute-list vtags-table-list)))
(curr-dir default-directory)
(output-buf (get-buffer-create
(if vtags-reuse-buffer
vtags-buffer-name
(concat "TAG:" pattern))))
)
;; Record whence we came.
(setq vtags-find-history (cons pattern vtags-find-history))
(ring-insert vtags-find-marker-ring (point-marker))
(setq vtags-the-return-point (point-marker))
;; Send matches to output buffer
(save-excursion
(set-buffer output-buf)
;; Since we might be reusing this buffer
;; we update its default-directory
(setq default-directory curr-dir)
(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)
'vtags-find-etag-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)
(if other-window-p
(switch-to-buffer-other-window output-buf)
(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
(goto-char (point-min))
(forward-line 1)
;(search-backward-regexp "[^\n]" nil t) ;; 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))
)
(bury-buffer)
(vtags-go-to-file-and-location goto-func filepath tag-info nil)
)))))
;; 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 vtags-find-etag-in-order (
tfi
pattern
regexp-p
output-buf
)
"Buffer-centric tag search function.
Return count of matching tags."
;; Get the file buffer
(save-excursion
(vtags-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
vtags-find-regexp-search-function
vtags-find-search-function))
(order (if regexp-p
vtags-find-regexp-tag-order
vtags-find-tag-order))
(next-line-after-failure-p (if regexp-p
vtags-find-regexp-next-line-after-failure-p
vtags-find-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 vtags-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) '(vtags-exact-file-name-match-p
vtags-file-name-match-p
vtags-partial-file-name-match-p))
(save-excursion (next-line 1)
(vtags-file-of-tag))
(vtags-file-of-tag)))
tag-info (funcall vtags-snarf-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 'vtags-goto-etag-location output-line)
(put-text-property beg end
'action '(lambda (x) (vtags-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 vtag-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 vtag-find-file-of-tag (file &optional other-window-p)
(let ((buf (vtag-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 vtags-recognize-etags-table ()
(and (vtags-verify-etags-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)))
'((vtags-file-of-tag-function . vtags-file-of-etag)
(vtags-table-files-function . vtags-etags-table-files)
(vtags-completion-table-function . vtags-etags-completion-table)
(vtags-snarf-function . vtags-snarf-etag)
(vtags-goto-location-function . vtags-goto-etag-location)
(vtags-find-regexp-search-function . re-search-forward)
(vtags-find-regexp-tag-order . (vtags-re-match-p))
(vtags-find-regexp-next-line-after-failure-p . t)
(vtags-find-search-function . search-forward)
(vtags-find-tag-order . (vtags-exact-file-name-match-p
vtags-file-name-match-p
vtags-exact-match-p
vtags-implicit-name-match-p
vtags-symbol-match-p
vtags-word-match-p
vtags-partial-file-name-match-p
vtags-any-match-p))
(vtags-find-next-line-after-failure-p . nil)
(vtags-list-function . vtags-list-etags)
(vtags-apropos-function . etags-tags-apropos)
(vtags-included-tables-function . vtags-etags-included-tables)
(vtags-verify-table-function . vtags-verify-etags-table)
))))
;; Return non-nil iff the current buffer is a valid etags TAGS file.
(defun vtags-verify-etags-table ()
;; Use eq instead of = in case char-after returns nil.
(eq (char-after (point-min)) ?\f))
(defun vtags-file-of-etag (&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 vtags-etags-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 'vtags "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 'vtags)) ; clear progress bar
table))
(defun vtags-snarf-etag (&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 vtags-goto-etag-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 "vtags.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 vtags-list 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 vtags: `%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 vtags-list-etags (tfi file out-buf)
(when (tagfileinfo-etags-p tfi)
(save-excursion
(vtags-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) (vtags-file-of-tag)))
;; Get the local value in the tags table
;; buffer before switching buffers.
(goto-func vtags-goto-location-function)
tag tag-info end)
(forward-line 1)
(while (not (or (eobp) (looking-at "\f")))
(setq tag-info (save-excursion (funcall vtags-snarf-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)))
(vtag-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 tag 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 vtags-tags-apropos-additional (tfi regexp)
"Display tags matching REGEXP from `tags-apropos-additional-actions'."
(vtags-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 vtags-tags-apropos (tfi string)
(when (tagfileinfo-etags-p tfi)
(vtags-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 vtags-goto-location-function)
(tag-info (save-excursion (funcall vtags-snarf-function)))
(tag (if (eq t (car tag-info)) nil (car tag-info)))
(file-path (save-excursion (if tag (vtags-file-of-tag)
(save-excursion (next-line 1)
(vtags-file-of-tag)))))
(file-label (if tag (vtags-file-of-tag t)
(save-excursion (next-line 1)
(vtags-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) (vtags-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 ()
(vtag-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 vtags-etags-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 vtags-etags-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 vtags-recognize-empty-etags-table ()
(and (zerop (buffer-size))
(mapc (lambda (sym) (set (make-local-variable sym) 'ignore))
'(vtags-table-files-function
vtags-completion-table-function
vtags-find-regexp-search-function
vtags-find-search-function
vtags-apropos-function
vtags-included-tables-function))
(set (make-local-variable 'vtags-verify-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 (vtags-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 vtags-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 vtags-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 vtags-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 vtags-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 vtags-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 vtags-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 vtags-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 vtags-any-match-p (tag)
(looking-at ".*\177"))
;; t if point is at a tag line that matches RE as a regexp.
(defun vtags-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)))))
; ;;;###autoload
(defvar vtags-list-file-alist nil) ;; alist, an obarray, or a function
; ;;;###autoload
(defvar vtags-list-file-alist-for "")
;; See doc for `minibuffer-completion-table'
; ;;;###autoload
(defun vtags-complete-tags-table-file (string predicate what)
;; Check if list needs to be computed or refined
(cond
((and vtags-list-file-alist (string= vtags-list-file-alist-for string))
t ;; string is unchanged, do nothing
)
((and vtags-list-file-alist
(not (string= "" vtags-list-file-alist-for))
(eq 0 (let ((case-fold-search nil)) (string-match vtags-list-file-alist-for string))))
;; Filter list further? EEB No, slows things down.
;; (setq vtags-list-file-alist (delete-if
;; (lambda (x)
;; (not (eq 0 (string-match string (car x)))))
;; vtags-list-file-alist)))
t) ;; Do nothing.
(t
;; Recompute
(let (;;(enable-recursive-minibuffers t)
(tables (vtags-compute-list vtags-table-list)))
(message "(building completion table...)")
(setq vtags-list-file-alist nil
vtags-list-file-alist-for string)
(while tables
(setq vtags-list-file-alist
(nconc vtags-list-file-alist
(mapcar (lambda (x) (cons x t))
(vtags-table-files (car tables) string predicate))))
(setq tables (cdr tables))))))
(cond
((not vtags-list-file-alist) nil)
((eq what nil)
(try-completion string vtags-list-file-alist ))
((eq what t)
(all-completions string vtags-list-file-alist))
((eq what 'lambda)
(assoc string vtags-list-file-alist ) )
))
; ;;;###autoload
(defun vtags-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: "
'vtags-complete-tags-table-file
nil t nil)))
(let ((out-buf (get-buffer-create "*Tags List*"))
(tables (vtags-compute-list vtags-table-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))
(vtags-list-etags (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 vtags-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 (vtags-compute-list vtags-table-list)))
(while tables
;; TODO (funcall vtags-apropos-function tfi regexp))))
(vtags-tags-apropos (car tables) regexp)
(vtags-tags-apropos-additional (car tables) regexp)
(setq tables (cdr tables))))))
(with-current-buffer "*Tags List*"
(vtags-mode)
(setq buffer-read-only t)))
; ;;;###autoload
(defun vtags-complete ()
"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 \\[vtags-find] (which see)."
(interactive)
(or vtags-table-list
(error "%s"
(substitute-command-keys
"No tags table loaded; ")))
(let ((completion-ignore-case (if (memq vtags-case-fold-search '(t nil))
vtags-case-fold-search
case-fold-search))
(pattern (funcall (or vtags-find-default-function
(get major-mode 'vtags-find-default-function)
'vtags-find-default)))
beg
completion)
(or pattern
(error "Nothing to complete"))
(search-backward pattern)
(setq beg (point))
(forward-char (length pattern))
(setq completion (vtags-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 'vtags-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 vtags: `.*' 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 vtags-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 vtags-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))))
(vtags-activate))
(defun vtags-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))))
(vtags-activate t))
(defun vtags-go-to-file-and-location (goto-func filepath tag-info &optional other-window-p)
(when (not (equal (cdar vtags-current-placeholder) vtags-the-return-point))
(vtags-set-placeholder vtags-the-return-point))
(vtag-find-file-of-tag filepath other-window-p)
(funcall goto-func tag-info)
(vtags-set-placeholder (point-marker)))
(defun vtags-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))
)
(when vtags-debugging (progn
(message "tag-info is %s" tag-info )
(message "goto-func is %s" goto-func)
(message "filepath is %s" filepath)))
(vtags-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 (vtags-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 vtags.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 vtags-forward-slashes (filename)
"convert each backslash in filename to a forward slash"
(concat (mapcar (function (lambda (c)
(if (= c ?\\) ?/ c)))
filename)))
(defun vtags-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))
(filesize-from-perl 0))
;; Large tag files require work-around for non-bignum versions of xemacs.
;; Builtin 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 (and (featurep 'xemacs)(= (nth 7 attr) -1))
(let* ((cmd (concat "perl -e 'my @s = stat(\"" (vtags-forward-slashes tagfilename) "\"); print $s[7];'")))
(when vtags-debugging (message "command is %s" cmd))
(setq filesize-from-perl (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 (max filesize filesize-from-perl)
:format ""
:sorted 0
:program-name "vtags"
:program-url "http://www.gnu.org/software/emacs/emacs-lisp-intro/html_node/vtags.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 'vtags-goto-etag-location line)
(put-text-property beg end
'action '(lambda (x) (vtags-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 "\r" 'vtags-activate)
(define-key vtags-keymap [(shift button2)] 'vtags-mouse-activate-other-window)
(define-key vtags-keymap [button2] 'vtags-mouse-activate)
(define-key vtags-keymap [mouse-2] 'vtags-mouse-activate)
(define-key vtags-keymap "q" (lambda () (interactive) (bury-buffer) nil))
(define-key vtags-keymap "f" 'vtags-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")))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; vtags-table-list defined here because it depends on previous stuff
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun vtags-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 'vtags-expand-table-name input-list)))
(let* ((compute-for (mapcar 'copy-sequence expanded-list))
(tables (remove nil (copy-sequence compute-for))) ;Mutated in the loop.
(computed nil)
(tfi nil)
)
(while tables
(setq file (car tables))
(if (string-match "<tree>" file)
(setq tfi (vtags-decend-tree))
(setq tfi (get-tagfileinfo file)))
(when tfi
(setq computed (cons tfi computed))
(when (tagfileinfo-etags-p tfi)
(save-excursion
(vtags-get-buffer-and-verify-table tfi)
;; Check for includes and append them
;; TODO (setq tables (paths-unique-append tables (vtags-etags-included-tables)))))
(setq tables (append tables (vtags-etags-included-tables))))))
(setq tables (cdr tables)))
;; return value
(nreverse (remove-duplicates computed :test 'equal)))))
(defun set-vtags-table-list (theList theValue)
(set-default theList theValue)
;(setq tags-table-computed-list (vtags-compute-list theValue))
)
(defcustom vtags-table-list (list "<tree>")
"*List of file names of tags tables to search.
The element <tree> has special meaning: look in current directory and below
for file named tags or TAGS.
An element that is a directory means the file \"tags\" or \"TAGS\" in that directory.
To switch to a new list of tags tables, setting this variable is sufficient.
Use the `ctags' program to make a tags table file."
:group 'vtags
:type '(repeat file)
;; :type '(vtags-list file)
:set #'(lambda (x y) (set-vtags-table-list x y))
)
(provide 'vtags)
;;; vtags.el ends here
^ permalink raw reply [flat|nested] 6+ messages in thread