X-Git-Url: https://code.delx.au/gnu-emacs-elpa/blobdiff_plain/1426189978bd696a2935e948dd94cb1108b65e70..3dc7169f617fbaeac115e8089e470fc115ae444f:/packages/ggtags/ggtags.el diff --git a/packages/ggtags/ggtags.el b/packages/ggtags/ggtags.el index 9dfc10d39..faf4d06e5 100644 --- a/packages/ggtags/ggtags.el +++ b/packages/ggtags/ggtags.el @@ -1,12 +1,13 @@ -;;; ggtags.el --- GNU Global source code tagging system -*- lexical-binding: t; -*- +;;; ggtags.el --- emacs frontend to GNU Global source code tagging system -*- lexical-binding: t; -*- -;; Copyright (C) 2013 Free Software Foundation, Inc. +;; Copyright (C) 2013-2014 Free Software Foundation, Inc. ;; Author: Leo Liu -;; Version: 0.6.5 +;; Version: 0.8.1 ;; Keywords: tools, convenience ;; Created: 2013-01-29 ;; URL: https://github.com/leoliu/ggtags +;; Package-Requires: ((emacs "24") (cl-lib "0.5")) ;; This program is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by @@ -28,33 +29,23 @@ ;; ;; Usage: ;; -;; Type `M-x ggtags-mode' to enable the minor mode, or as usual enable -;; it in your desired major mode hooks. When the mode is on the symbol -;; at point is underlined if it is a valid (definition) tag. +;; `ggtags' is similar to the standard `etags' package. These keys +;; `M-.', `M-,', `M-*' and `C-M-.' should work as expected in +;; `ggtags-mode'. See the README in https://github.com/leoliu/ggtags +;; for more details. ;; -;; `M-.' finds definition or references according to the context at -;; point, i.e. if point is at a definition tag find references and -;; vice versa. `C-u M-.' is verbose and will ask you the name - with -;; completion - and the type of tag to search. -;; -;; If multiple matches are found, navigation mode is entered. In this -;; mode, `M-n' and `M-p' moves to next and previous match, `M-}' and -;; `M-{' to next and previous file respectively. `M-o' toggles between -;; full and abbreviated displays of file names in the auxiliary popup -;; window. When you locate the right match, press RET to finish which -;; hides the auxiliary window and exits navigation mode. You can -;; resume the search using `M-,'. To abort the search press `M-*'. -;; -;; Normally after a few searches a dozen buffers are created visiting -;; files tracked by GNU Global. `C-c M-k' helps clean them up. +;; All commands are available from the `Ggtags' menu in `ggtags-mode'. ;;; Code: -(eval-when-compile (require 'cl)) -(require 'compile) +(eval-when-compile + (require 'url-parse)) -(if (not (fboundp 'comment-string-strip)) - (autoload 'comment-string-strip "newcomment")) +(require 'cl-lib) +(require 'ewoc) +(require 'compile) +(require 'etags) +(require 'tabulated-list) ;preloaded since 24.3 (eval-when-compile (unless (fboundp 'setq-local) @@ -65,28 +56,110 @@ (defmacro defvar-local (var val &optional docstring) (declare (debug defvar) (doc-string 3)) (list 'progn (list 'defvar var val docstring) - (list 'make-variable-buffer-local (list 'quote var)))))) + (list 'make-variable-buffer-local (list 'quote var))))) + + (defmacro ignore-errors-unless-debug (&rest body) + "Ignore all errors while executing BODY unless debug is on." + (declare (debug t) (indent 0)) + `(condition-case-unless-debug nil (progn ,@body) (error nil)))) + +(eval-and-compile + (or (fboundp 'user-error) ;24.3 + (defalias 'user-error 'error)) + (or (fboundp 'read-only-mode) ;24.3 + (defalias 'read-only-mode 'toggle-read-only)) + (or (fboundp 'register-read-with-preview) ;24.4 + (defalias 'register-read-with-preview 'read-char))) (defgroup ggtags nil "GNU Global source code tagging system." :group 'tools) (defface ggtags-highlight '((t (:underline t))) - "Face used to highlight a valid tag at point.") + "Face used to highlight a valid tag at point." + :group 'ggtags) + +(defface ggtags-global-line '((t (:inherit secondary-selection))) + "Face used to highlight matched line in Global buffer." + :group 'ggtags) + +(defcustom ggtags-executable-directory nil + "If non-nil the directory to search global executables." + :type '(choice (const :tag "Unset" nil) directory) + :risky t + :group 'ggtags) -(defcustom ggtags-auto-jump-to-first-match t - "Non-nil to automatically jump to the first match." +(defcustom ggtags-oversize-limit (* 10 1024 1024) + "The over size limit for the GTAGS file. +For large source trees, running 'global -u' can be expensive. +Thus when GTAGS file is larger than this limit, ggtags +automatically switches to 'global --single-update'." + :safe 'numberp + :type '(choice (const :tag "None" nil) + (const :tag "Always" t) + number) + :group 'ggtags) + +(defcustom ggtags-global-always-update nil + "If non-nil always update tags for current file on save." + :safe 'booleanp :type 'boolean :group 'ggtags) +(defcustom ggtags-include-pattern + '("^\\s-*#\\(?:include\\|import\\)\\s-*[\"<]\\(?:[./]*\\)?\\(.*?\\)[\">]" . 1) + "Pattern used to detect #include files. +Value can be (REGEXP . SUB) or a function with no arguments." + :type '(choice (const :tag "Disable" nil) + (cons regexp integer) + function) + :safe 'stringp + :group 'ggtags) + +(defcustom ggtags-use-project-gtagsconf t + "Non-nil to use GTAGSCONF file found at project root. +File .globalrc and gtags.conf are checked in order." + :safe 'booleanp + :type 'boolean + :group 'ggtags) + +(defcustom ggtags-project-duration 600 + "Seconds to keep information of a project in memory." + :type 'number + :group 'ggtags) + +(defcustom ggtags-process-environment nil + "Similar to `process-environment' with higher precedence. +Elements are run through `substitute-env-vars' before use. +GTAGSROOT will always be expanded to current project root +directory. This is intended for project-wise ggtags-specific +process environment settings. Note on remote hosts (e.g. tramp) +directory local variables is not enabled by default per +`enable-remote-dir-locals' (which see)." + :safe 'ggtags-list-of-string-p + :type '(repeat string) + :group 'ggtags) + +(defcustom ggtags-auto-jump-to-match 'first + "Strategy on how to jump to match: nil, first or history. + + nil: never automatically jump to any match; + first: jump to the first match; +history: jump to the match stored in search history." + :type '(choice (const :tag "First match" first) + (const :tag "Search History" history) + (const :tag "Never" nil)) + :group 'ggtags) + (defcustom ggtags-global-window-height 8 ; ggtags-global-mode - "Number of lines for the 'global' popup window. + "Number of lines for the *ggtags-global* popup window. If nil, use Emacs default." :type '(choice (const :tag "Default" nil) integer) :group 'ggtags) -(defcustom ggtags-global-abbreviate-filename 35 - "Non-nil to display file names abbreviated such as '/u/b/env'." +(defcustom ggtags-global-abbreviate-filename 40 + "Non-nil to display file names abbreviated e.g. \"/u/b/env\". +If an integer abbreviate only names longer than that number." :type '(choice (const :tag "No" nil) (const :tag "Always" t) integer) @@ -97,8 +170,13 @@ If nil, use Emacs default." :type 'function :group 'ggtags) +(defcustom ggtags-use-idutils (and (executable-find "mkid") t) + "Non-nil to also generate the idutils DB." + :type 'boolean + :group 'ggtags) + (defcustom ggtags-global-output-format 'grep - "The output format for the 'global' command." + "Global output format: path, ctags, ctags-x, grep or cscope." :type '(choice (const path) (const ctags) (const ctags-x) @@ -106,202 +184,1049 @@ If nil, use Emacs default." (const cscope)) :group 'ggtags) -(defvar ggtags-cache nil) ; (ROOT TABLE DIRTY TIMESTAMP) +(defcustom ggtags-global-use-color t + "Non-nil to use color in output if supported by Global." + :type 'boolean + :safe 'booleanp + :group 'ggtags) -(defvar ggtags-current-tag-name nil) +(defcustom ggtags-global-ignore-case nil + "Non-nil if Global should ignore case in the search pattern." + :safe 'booleanp + :type 'boolean + :group 'ggtags) + +(defcustom ggtags-global-treat-text nil + "Non-nil if Global should include matches from text files. +This affects `ggtags-find-file' and `ggtags-grep'." + :safe 'booleanp + :type 'boolean + :group 'ggtags) + +(defcustom ggtags-global-large-output 1000 + "Number of lines in the Global buffer to indicate large output." + :type 'number + :group 'ggtags) + +(defcustom ggtags-global-history-length history-length + "Maximum number of items to keep in `ggtags-global-search-history'." + :type 'integer + :group 'ggtags) + +(defcustom ggtags-enable-navigation-keys t + "If non-nil key bindings in `ggtags-navigation-map' are enabled." + :safe 'booleanp + :type 'boolean + :group 'ggtags) + +(defcustom ggtags-find-tag-hook nil + "Hook run immediately after finding a tag." + :options '(recenter reposition-window) + :type 'hook + :group 'ggtags) + +(defcustom ggtags-show-definition-function #'ggtags-show-definition-default + "Function called by `ggtags-show-definition' to show definition. +It is passed a list of definition candidates of the form: + + (TEXT NAME FILE LINE) + +where TEXT is usually the source line of the definition." + :type 'function + :group 'ggtags) + +(defcustom ggtags-mode-sticky t + "If non-nil enable Ggtags Mode in files visited." + :safe 'booleanp + :type 'boolean + :group 'ggtags) + +(defcustom ggtags-mode-prefix-key "\C-c" + "Key binding used for `ggtags-mode-prefix-map'. +Users should change the value using `customize-variable' to +properly update `ggtags-mode-map'." + :set (lambda (sym value) + (when (bound-and-true-p ggtags-mode-map) + (let ((old (and (boundp sym) (symbol-value sym)))) + (and old (define-key ggtags-mode-map old nil))) + (and value + (bound-and-true-p ggtags-mode-prefix-map) + (define-key ggtags-mode-map value ggtags-mode-prefix-map))) + (set-default sym value)) + :type 'key-sequence + :group 'ggtags) + +(defcustom ggtags-highlight-tag-delay 0.25 + "Time in seconds before highlighting tag at point." + :set (lambda (sym value) + (when (bound-and-true-p ggtags-highlight-tag-timer) + (timer-set-idle-time ggtags-highlight-tag-timer value t)) + (set-default sym value)) + :type 'number + :group 'ggtags) + +(defcustom ggtags-bounds-of-tag-function (lambda () + (bounds-of-thing-at-point 'symbol)) + "Function to get the start and end positions of the tag at point." + :type 'function + :group 'ggtags) ;; Used by ggtags-global-mode (defvar ggtags-global-error "match" "Stem of message to print when no matches are found.") -;; http://thread.gmane.org/gmane.comp.gnu.global.bugs/1518 -(defvar ggtags-global-has-path-style ; introduced in global 6.2.8 - (with-demoted-errors ; in case `global' not found - (and (string-match-p "^--path-style " - (shell-command-to-string "global --help")) - t)) - "Non-nil if `global' supports --path-style switch.") +(defconst ggtags-bug-url "https://github.com/leoliu/ggtags/issues") + +(defvar ggtags-global-last-buffer nil) + +(defvar ggtags-current-tag-name nil) + +(defvar ggtags-highlight-tag-overlay nil) + +(defvar ggtags-highlight-tag-timer nil) (defmacro ggtags-ensure-global-buffer (&rest body) (declare (indent 0)) `(progn - (or (and (buffer-live-p compilation-last-buffer) - (with-current-buffer compilation-last-buffer + (or (and (buffer-live-p ggtags-global-last-buffer) + (with-current-buffer ggtags-global-last-buffer (derived-mode-p 'ggtags-global-mode))) (error "No global buffer found")) - (with-current-buffer compilation-last-buffer ,@body))) - -(defun ggtags-get-timestamp (root) - "Get the timestamp (float) of file GTAGS in ROOT directory. -Return -1 if it does not exist." - (let ((file (expand-file-name "GTAGS" root))) - (if (file-exists-p file) - (float-time (nth 5 (file-attributes file))) - -1))) + (with-current-buffer ggtags-global-last-buffer ,@body))) -(defun ggtags-get-libpath () - (split-string (or (getenv "GTAGSLIBPATH") "") - (regexp-quote path-separator) t)) - -(defun ggtags-cache-get (key) - (assoc key ggtags-cache)) - -(defun ggtags-cache-set (key val &optional dirty) - (let ((c (ggtags-cache-get key))) - (if c - (setcdr c (list val dirty (float-time))) - (push (list key val dirty (float-time)) ggtags-cache)))) - -(defun ggtags-cache-mark-dirty (key flag) - "Return non-nil if operation is successful." - (let ((cache (ggtags-cache-get key))) - (when cache - (setcar (cddr cache) flag)))) - -(defun ggtags-cache-dirty-p (key) - "Value is non-nil if 'global -u' is needed." - (third (ggtags-cache-get key))) +(defun ggtags-list-of-string-p (xs) + "Return non-nil if XS is a list of strings." + (cl-every #'stringp xs)) -(defun ggtags-cache-stale-p (key) - "Value is non-nil if tags in cache needs to be rebuilt." - (> (ggtags-get-timestamp key) - (or (fourth (ggtags-cache-get key)) 0))) - -(defvar-local ggtags-root-directory 'unset - "Internal; use function `ggtags-root-directory' instead.") +(defun ggtags-forward-to-line (line) + "Move to line number LINE in current buffer." + (cl-check-type line (integer 1)) + (save-restriction + (widen) + (goto-char (point-min)) + (forward-line (1- line)))) + +(defun ggtags-program-path (name) + (if ggtags-executable-directory + (expand-file-name name ggtags-executable-directory) + name)) + +(defun ggtags-process-string (program &rest args) + (with-temp-buffer + (let ((exit (apply #'process-file + (ggtags-program-path program) nil t nil args)) + (output (progn + (goto-char (point-max)) + (skip-chars-backward " \t\n") + (buffer-substring (point-min) (point))))) + (or (zerop exit) + (error "`%s' non-zero exit: %s" program output)) + output))) + +(defun ggtags-tag-at-point () + (pcase (funcall ggtags-bounds-of-tag-function) + (`(,beg . ,end) (buffer-substring beg end)))) + +;;; Store for project info and settings + +(defvar ggtags-projects (make-hash-table :size 7 :test #'equal)) + +(cl-defstruct (ggtags-project (:constructor ggtags-project--make) + (:copier nil) + (:type vector) + :named) + root config tag-size has-refs has-path-style has-color dirty-p mtime timestamp) + +(defun ggtags-make-project (root) + (cl-check-type root string) + (pcase (nthcdr 5 (file-attributes (expand-file-name "GTAGS" root))) + (`(,mtime ,_ ,tag-size . ,_) + (let* ((default-directory (file-name-as-directory root)) + (config (cl-some (lambda (c) (and (file-exists-p c) c)) + '(".globalrc" "gtags.conf"))) + (rtags-size (nth 7 (file-attributes "GRTAGS"))) + (has-refs + (when rtags-size + (and (or (> rtags-size (* 32 1024)) + (with-demoted-errors + (not (equal "" (ggtags-process-string "global" "-crs"))))) + 'has-refs))) + ;; http://thread.gmane.org/gmane.comp.gnu.global.bugs/1518 + (has-path-style + (with-demoted-errors ; in case `global' not found + (and (zerop (process-file (ggtags-program-path "global") + nil nil nil + "--path-style" "shorter" "--help")) + 'has-path-style))) + ;; http://thread.gmane.org/gmane.comp.gnu.global.bugs/1542 + (has-color + (with-demoted-errors + (and (zerop (process-file (ggtags-program-path "global") + nil nil nil + "--color" "--help")) + 'has-color)))) + (puthash default-directory + (ggtags-project--make :root default-directory + :config config + :tag-size tag-size + :has-refs has-refs + :has-path-style has-path-style + :has-color has-color + :mtime (float-time mtime) + :timestamp (float-time)) + ggtags-projects))))) + +(defun ggtags-project-expired-p (project) + (or (< (ggtags-project-timestamp project) 0) + (> (- (float-time) + (ggtags-project-timestamp project)) + ggtags-project-duration))) + +(defun ggtags-project-update-mtime-maybe (&optional project) + "Update PROJECT's modtime and if current file is newer. +Value is new modtime if updated." + (let ((project (or project (ggtags-find-project)))) + (when (and (ggtags-project-p project) + (consp (visited-file-modtime)) + (> (float-time (visited-file-modtime)) + (ggtags-project-mtime project))) + (setf (ggtags-project-dirty-p project) t) + (setf (ggtags-project-mtime project) + (float-time (visited-file-modtime)))))) + +(defun ggtags-project-oversize-p (&optional project) + (pcase ggtags-oversize-limit + (`nil nil) + (`t t) + (size (let ((project (or project (ggtags-find-project)))) + (and project (> (ggtags-project-tag-size project) size)))))) + +(defvar-local ggtags-project-root 'unset + "Internal variable for project root directory.") + +(defun ggtags-clear-project-root () + (kill-local-variable 'ggtags-project-root)) ;;;###autoload -(defun ggtags-root-directory () - (if (string-or-null-p ggtags-root-directory) - ggtags-root-directory - (setq ggtags-root-directory - (with-temp-buffer - (when (zerop (call-process "global" nil (list t nil) nil "-pr")) - (file-name-as-directory - (comment-string-strip (buffer-string) t t))))))) - -(defun ggtags-check-root-directory () - (or (ggtags-root-directory) (error "File GTAGS not found"))) - -(defun ggtags-ensure-root-directory () - (or (ggtags-root-directory) - (if (yes-or-no-p "File GTAGS not found; run gtags? ") - (let ((root (read-directory-name "Directory: " nil nil t))) - (and (= (length root) 0) (error "No directory chosen")) - (with-temp-buffer - (if (zerop (let ((default-directory - (file-name-as-directory root))) - (call-process "gtags" nil t))) - (message "File GTAGS generated in `%s'" - (ggtags-root-directory)) - (error "%s" (comment-string-strip (buffer-string) t t))))) - (error "Aborted")))) - -(defun ggtags-tag-names-1 (root &optional prefix) - (when root - (if (ggtags-cache-stale-p root) - (let* ((default-directory (file-name-as-directory root)) - (tags (with-demoted-errors - (split-string - (with-output-to-string - (call-process "global" nil (list standard-output nil) - nil "-c" (or prefix ""))))))) - (and tags (ggtags-cache-set root tags)) - tags) - (cadr (ggtags-cache-get root))))) +(defun ggtags-find-project () + ;; See https://github.com/leoliu/ggtags/issues/42 + ;; + ;; It is unsafe to cache `ggtags-project-root' in non-file buffers. + ;; But we keep the cache for a command's duration so that multiple + ;; calls of `ggtags-find-project' has no performance impact. + (unless buffer-file-name + (add-hook 'pre-command-hook #'ggtags-clear-project-root nil t)) + (let ((project (gethash ggtags-project-root ggtags-projects))) + (if (ggtags-project-p project) + (if (ggtags-project-expired-p project) + (progn + (remhash ggtags-project-root ggtags-projects) + (ggtags-find-project)) + project) + (setq ggtags-project-root + (or (ignore-errors-unless-debug + (file-name-as-directory + (concat (file-remote-p default-directory) + ;; Resolves symbolic links + (ggtags-process-string "global" "-pr")))) + ;; 'global -pr' resolves symlinks before checking the + ;; GTAGS file which could cause issues such as + ;; https://github.com/leoliu/ggtags/issues/22, so + ;; let's help it out. + ;; + ;; Note: `locate-dominating-file' doesn't accept + ;; function for NAME before 24.3. + (let ((dir (locate-dominating-file default-directory "GTAGS"))) + ;; `file-truename' may strip the trailing '/' on + ;; remote hosts, see http://debbugs.gnu.org/16851 + (and dir (file-regular-p (expand-file-name "GTAGS" dir)) + (file-name-as-directory (file-truename dir)))))) + (when ggtags-project-root + (if (gethash ggtags-project-root ggtags-projects) + (ggtags-find-project) + (ggtags-make-project ggtags-project-root)))))) + +(defun ggtags-current-project-root () + (and (ggtags-find-project) + (ggtags-project-root (ggtags-find-project)))) + +(defun ggtags-check-project () + (or (ggtags-find-project) (error "File GTAGS not found"))) + +(defun ggtags-ensure-project () + (or (ggtags-find-project) + (when (or (yes-or-no-p "File GTAGS not found; run gtags? ") + (user-error "Aborted")) + (call-interactively #'ggtags-create-tags) + ;; Need checking because `ggtags-create-tags' can create tags + ;; in any directory. + (ggtags-check-project)))) + +(defvar delete-trailing-lines) ;new in 24.3 + +(defun ggtags-save-project-settings (&optional noconfirm) + "Save Gnu Global's specific environment variables." + (interactive "P") + (ggtags-check-project) + (let* ((inhibit-read-only t) ; for `add-dir-local-variable' + (default-directory (ggtags-current-project-root)) + ;; Not using `ggtags-with-current-project' to preserve + ;; environment variables that may be present in + ;; `ggtags-process-environment'. + (process-environment + (append ggtags-process-environment + process-environment + (and (not (ggtags-project-has-refs (ggtags-find-project))) + (list "GTAGSLABEL=ctags")))) + (envlist (delete-dups + (cl-loop for x in process-environment + when (string-match + "^\\(GTAGS[^=\n]*\\|MAKEOBJDIRPREFIX\\)=" x) + ;; May have duplicates thus `delete-dups'. + collect (concat (match-string 1 x) + "=" + (getenv (match-string 1 x)))))) + (help-form (format "y: save\nn: don't save\n=: diff\n?: help\n"))) + (add-dir-local-variable nil 'ggtags-process-environment envlist) + ;; Remove trailing newlines by `add-dir-local-variable'. + (let ((delete-trailing-lines t)) (delete-trailing-whitespace)) + (or noconfirm + (while (pcase (read-char-choice + (format "Save `%s'? (y/n/=/?) " buffer-file-name) + '(?y ?n ?= ??)) + ;; ` required for 24.1 and 24.2 + (`?n (user-error "Aborted")) + (`?y nil) + (`?= (diff-buffer-with-file) 'loop) + (`?? (help-form-show) 'loop)))) + (save-buffer) + (kill-buffer))) + +(defun ggtags-toggle-project-read-only () + (interactive) + (ggtags-check-project) + (let ((inhibit-read-only t) ; for `add-dir-local-variable' + (val (not buffer-read-only)) + (default-directory (ggtags-current-project-root))) + (add-dir-local-variable nil 'buffer-read-only val) + (save-buffer) + (kill-buffer) + (when buffer-file-name + (read-only-mode (if val +1 -1))) + (when (called-interactively-p 'interactive) + (message "Project read-only-mode is %s" (if val "on" "off"))) + val)) + +(defun ggtags-visit-project-root () + (interactive) + (ggtags-ensure-project) + (dired (ggtags-current-project-root))) + +(defmacro ggtags-with-current-project (&rest body) + "Eval BODY in current project's `process-environment'." + (declare (debug t)) + (let ((gtagsroot (make-symbol "-gtagsroot-")) + (root (make-symbol "-ggtags-project-root-"))) + `(let* ((,root ggtags-project-root) + (,gtagsroot (when (ggtags-find-project) + (directory-file-name (ggtags-current-project-root)))) + (process-environment + (append (let ((process-environment process-environment)) + (and ,gtagsroot (setenv "GTAGSROOT" ,gtagsroot)) + (mapcar #'substitute-env-vars ggtags-process-environment)) + process-environment + (and ,gtagsroot (list (concat "GTAGSROOT=" ,gtagsroot))) + (and (ggtags-find-project) + (not (ggtags-project-has-refs (ggtags-find-project))) + (list "GTAGSLABEL=ctags")) + (and ggtags-use-project-gtagsconf ,gtagsroot + (ggtags-project-config (ggtags-find-project)) + (list (concat "GTAGSCONF=" + (expand-file-name (ggtags-project-config + (ggtags-find-project)) + ,gtagsroot))))))) + (unwind-protect (save-current-buffer ,@body) + (setq ggtags-project-root ,root))))) -;;;###autoload -(defun ggtags-tag-names (&optional prefix) - "Get a list of tag names starting with PREFIX." - (let ((root (ggtags-root-directory))) - (when (and root (ggtags-cache-dirty-p root)) - (if (zerop (call-process "global" nil nil nil "-u")) - (ggtags-cache-mark-dirty root nil) - (message "ggtags: error running 'global -u'"))) - (apply 'append (mapcar (lambda (r) - (ggtags-tag-names-1 r prefix)) - (cons root (ggtags-get-libpath)))))) - -(defun ggtags-read-tag (quick) - (ggtags-ensure-root-directory) - (let* ((tags (ggtags-tag-names)) - (sym (thing-at-point 'symbol)) - (default (and (member sym tags) sym))) +(defun ggtags-get-libpath () + (let ((path (ggtags-with-current-project (getenv "GTAGSLIBPATH")))) + (and path (mapcar (apply-partially #'concat (file-remote-p default-directory)) + (split-string path (regexp-quote path-separator) t))))) + +(defun ggtags-create-tags (root) + "Create tag files (e.g. GTAGS) in directory ROOT. +If file .globalrc or gtags.conf exists in ROOT, it will be used +as configuration file per `ggtags-use-project-gtagsconf'. + +If file gtags.files exists in ROOT, it should be a list of source +files to index, which can be used to speed gtags up in large +source trees. See Info node `(global)gtags' for details." + (interactive "DRoot directory: ") + (let ((process-environment process-environment)) + (when (zerop (length root)) (error "No root directory provided")) + (setenv "GTAGSROOT" (expand-file-name + (directory-file-name (file-name-as-directory root)))) + (ggtags-with-current-project + (let ((conf (and ggtags-use-project-gtagsconf + (cl-loop for name in '(".globalrc" "gtags.conf") + for full = (expand-file-name name root) + thereis (and (file-exists-p full) full))))) + (cond (conf (setenv "GTAGSCONF" conf)) + ((and (not (getenv "GTAGSLABEL")) + (yes-or-no-p "Use `ctags' backend? ")) + (setenv "GTAGSLABEL" "ctags")))) + (with-temp-message "`gtags' in progress..." + (let ((default-directory (file-name-as-directory root))) + (condition-case err + (apply #'ggtags-process-string + "gtags" (and ggtags-use-idutils '("--idutils"))) + (error (if (and ggtags-use-idutils + (stringp (cadr err)) + (string-match-p "mkid not found" (cadr err))) + ;; Retry without mkid + (ggtags-process-string "gtags") + (signal (car err) (cdr err)))))))) + (message "GTAGS generated in `%s'" root) + root)) + +(defun ggtags-update-tags (&optional force) + "Update GNU Global tag database. +Do nothing if GTAGS exceeds the oversize limit unless FORCE." + (interactive (progn + (ggtags-check-project) + ;; Mark project info expired. + (setf (ggtags-project-timestamp (ggtags-find-project)) -1) + (list t))) + (when (or force (and (ggtags-find-project) + (not (ggtags-project-oversize-p)) + (ggtags-project-dirty-p (ggtags-find-project)))) + (ggtags-with-current-project + (with-temp-message "`global -u' in progress..." + (ggtags-process-string "global" "-u") + (setf (ggtags-project-dirty-p (ggtags-find-project)) nil) + (setf (ggtags-project-mtime (ggtags-find-project)) (float-time)))))) + +(defvar-local ggtags-completion-cache nil) + +;; See global/libutil/char.c +;; (defconst ggtags-regexp-metachars "[][$()*+.?\\{}|^]") +(defvar ggtags-completion-flag "") ;internal use + +(defvar ggtags-completion-table + (completion-table-dynamic + (lambda (prefix) + (let ((cache-key (concat prefix "$" ggtags-completion-flag))) + (unless (equal cache-key (car ggtags-completion-cache)) + (setq ggtags-completion-cache + (cons cache-key + (ignore-errors-unless-debug + ;; May throw global: only name char is allowed + ;; with -c option. + (ggtags-with-current-project + (split-string + (apply #'ggtags-process-string + "global" + (append (and completion-ignore-case '("--ignore-case")) + ;; Note -c alone returns only definitions + (list (concat "-c" ggtags-completion-flag) prefix))) + "\n" t))))))) + (cdr ggtags-completion-cache)))) + +(defun ggtags-completion-at-point () + "A function for `completion-at-point-functions'." + (pcase (funcall ggtags-bounds-of-tag-function) + (`(,beg . ,end) + (and (< beg end) (list beg end ggtags-completion-table))))) + +(defun ggtags-read-tag (&optional type confirm prompt require-match default) + (ggtags-ensure-project) + (let ((default (or default (ggtags-tag-at-point))) + (prompt (or prompt (capitalize (symbol-name (or type 'tag))))) + (ggtags-completion-flag (pcase type + (`(or nil definition) "T") + (`symbol "s") + (`reference "r") + (`id "I") + (`path "P") + ((pred stringp) type) + (_ ggtags-completion-flag)))) (setq ggtags-current-tag-name - (if quick (or default (error "No valid tag at point")) - (completing-read - (format (if default "Tag (default %s): " "Tag: ") default) - tags nil t nil nil default))))) + (cond (confirm + (ggtags-update-tags) + (completing-read + (format (if default "%s (default %s): " "%s: ") prompt default) + ggtags-completion-table nil require-match nil nil default)) + (default (substring-no-properties default)) + (t (ggtags-read-tag type t prompt require-match default)))))) + +(defun ggtags-global-build-command (cmd &rest args) + ;; CMD can be definition, reference, symbol, grep, idutils + (let ((xs (append (list (shell-quote-argument (ggtags-program-path "global")) + "-v" + (format "--result=%s" ggtags-global-output-format) + (and ggtags-global-ignore-case "--ignore-case") + (and ggtags-global-use-color + (ggtags-find-project) + (ggtags-project-has-color (ggtags-find-project)) + "--color=always") + (and (ggtags-find-project) + (ggtags-project-has-path-style (ggtags-find-project)) + "--path-style=shorter") + (and ggtags-global-treat-text "--other") + (pcase cmd + ((pred stringp) cmd) + (`definition "") ;-d not supported by Global 5.7.1 + (`reference "-r") + (`symbol "-s") + (`path "--path") + (`grep "--grep") + (`idutils "--idutils"))) + args))) + (mapconcat #'identity (delq nil xs) " "))) + +;; takes three values: nil, t and a marker +(defvar ggtags-global-start-marker nil) +(defvar ggtags-global-exit-status 0) +(defvar ggtags-global-match-count 0) +(defvar ggtags-tag-ring-index nil) +(defvar ggtags-global-search-history nil) + +(defvar ggtags-auto-jump-to-match-target nil) + +(defun ggtags-global-save-start-marker () + (when (markerp ggtags-global-start-marker) + (setq ggtags-tag-ring-index nil) + (ring-insert find-tag-marker-ring ggtags-global-start-marker) + (setq ggtags-global-start-marker t))) + +(defun ggtags-global-start (command &optional directory) + (let* ((default-directory (or directory (ggtags-current-project-root))) + (split-window-preferred-function ggtags-split-window-function) + ;; See http://debbugs.gnu.org/13594 + (display-buffer-overriding-action + (if (and ggtags-auto-jump-to-match + ;; Appeared in emacs 24.4. + (fboundp 'display-buffer-no-window)) + (list #'display-buffer-no-window) + display-buffer-overriding-action)) + (env ggtags-process-environment)) + (setq ggtags-global-start-marker (point-marker)) + (setq ggtags-auto-jump-to-match-target + (nth 4 (assoc (ggtags-global-search-id command default-directory) + ggtags-global-search-history))) + (ggtags-navigation-mode +1) + (setq ggtags-global-exit-status 0 + ggtags-global-match-count 0) + (ggtags-update-tags) + (ggtags-with-current-project + (with-current-buffer (compilation-start command 'ggtags-global-mode) + (setq-local ggtags-process-environment env) + (setq ggtags-global-last-buffer (current-buffer)))))) + +(defun ggtags-find-tag-continue () + (interactive) + (ggtags-ensure-global-buffer + (ggtags-navigation-mode +1) + (let ((split-window-preferred-function ggtags-split-window-function)) + (ignore-errors (compilation-next-error 1)) + (compile-goto-error)))) -(defun ggtags-global-options () - (concat "-v --result=" - (symbol-name ggtags-global-output-format) - (and ggtags-global-has-path-style " --path-style=shorter"))) +(defun ggtags-find-tag (cmd &rest args) + (ggtags-check-project) + (ggtags-global-start (apply #'ggtags-global-build-command cmd args))) ;;;###autoload -(defun ggtags-find-tag (name &optional verbose) - "Find definitions or references to tag NAME by context. +(defun ggtags-find-tag-dwim (name &optional what) + "Find NAME by context. If point is at a definition tag, find references, and vice versa. -When called with prefix, ask the name and kind of tag." - (interactive (list (ggtags-read-tag (not current-prefix-arg)) +If point is at a line that matches `ggtags-include-pattern', find +the include file instead. + +When called interactively with a prefix arg, always find +definition tags." + (interactive + (let ((include (and (not current-prefix-arg) + ggtags-include-pattern + (save-excursion + (beginning-of-line) + (if (functionp ggtags-include-pattern) + (funcall ggtags-include-pattern) + (and (looking-at (car ggtags-include-pattern)) + (match-string (cdr ggtags-include-pattern)))))))) + (if include (list include 'include) + (list (ggtags-read-tag 'definition current-prefix-arg) + (and current-prefix-arg 'definition))))) + (ggtags-check-project) ; for `ggtags-current-project-root' below + (cond + ((eq what 'include) + (ggtags-find-file name)) + ((or (eq what 'definition) + (not buffer-file-name) + (and (ggtags-find-project) + (not (ggtags-project-has-refs (ggtags-find-project))))) + (ggtags-find-tag 'definition (shell-quote-argument name))) + (t (ggtags-find-tag + (format "--from-here=%d:%s" + (line-number-at-pos) + (shell-quote-argument + ;; Note `ggtags-global-start' binds default-directory to + ;; project root. + (file-relative-name + buffer-file-name + (if (string-prefix-p (ggtags-current-project-root) + buffer-file-name) + (ggtags-current-project-root) + (locate-dominating-file buffer-file-name "GTAGS"))))) + (shell-quote-argument name))))) + +(defun ggtags-find-reference (name) + (interactive (list (ggtags-read-tag 'reference current-prefix-arg))) + (ggtags-find-tag 'reference (shell-quote-argument name))) + +(defun ggtags-find-other-symbol (name) + "Find tag NAME that is a reference without a definition." + (interactive (list (ggtags-read-tag 'symbol current-prefix-arg))) + (ggtags-find-tag 'symbol (shell-quote-argument name))) + +(defun ggtags-quote-pattern (pattern) + (prin1-to-string (substring-no-properties pattern))) + +(defun ggtags-idutils-query (pattern) + (interactive (list (ggtags-read-tag 'id t))) + (ggtags-find-tag 'idutils "--" (ggtags-quote-pattern pattern))) + +(defun ggtags-grep (pattern &optional invert-match) + "Grep for lines matching PATTERN. +Invert the match when called with a prefix arg \\[universal-argument]." + (interactive (list (ggtags-read-tag 'definition 'confirm + (if current-prefix-arg + "Inverted grep pattern" "Grep pattern")) + current-prefix-arg)) + (ggtags-find-tag 'grep (and invert-match "--invert-match") + "--" (ggtags-quote-pattern pattern))) + +(defun ggtags-find-file (pattern &optional invert-match) + (interactive (list (ggtags-read-tag 'path 'confirm (if current-prefix-arg + "Inverted path pattern" + "Path pattern") + nil (thing-at-point 'filename)) current-prefix-arg)) - (eval-and-compile (require 'etags)) - (ggtags-check-root-directory) - (ggtags-navigation-mode +1) - (ring-insert find-tag-marker-ring (point-marker)) + (let ((ggtags-global-output-format 'path)) + (ggtags-find-tag 'path (and invert-match "--invert-match") + "--" (ggtags-quote-pattern pattern)))) + +;; NOTE: Coloured output in grep requested: http://goo.gl/Y9IcX +(defun ggtags-find-tag-regexp (regexp directory) + "List tags matching REGEXP in DIRECTORY (default to project root). +When called interactively with a prefix, ask for the directory." + (interactive + (progn + (ggtags-check-project) + (list (ggtags-read-tag "" t "POSIX regexp") + (if current-prefix-arg + (read-directory-name "Directory: " nil nil t) + (ggtags-current-project-root))))) + (ggtags-check-project) + (ggtags-global-start + (ggtags-global-build-command nil nil "-l" "--" (ggtags-quote-pattern regexp)) + (file-name-as-directory directory))) + +(defvar ggtags-navigation-mode) + +(defun ggtags-query-replace (from to &optional delimited) + "Query replace FROM with TO on files in the Global buffer. +If not in navigation mode, do a grep on FROM first. + +Note: the regular expression FROM must be supported by both +Global and Emacs." + (interactive + ;; Note: in 24.4 query-replace-read-args returns a list of 4 elements. + (let ((args (query-replace-read-args "Query replace (regexp)" t t))) + (list (nth 0 args) (nth 1 args) (nth 2 args)))) + (unless ggtags-navigation-mode + (let ((ggtags-auto-jump-to-match nil)) + (ggtags-grep from))) + (let ((file-form + '(let ((files)) + (ggtags-ensure-global-buffer + (with-temp-message "Waiting for Grep to finish..." + (while (get-buffer-process (current-buffer)) + (sit-for 0.2))) + (goto-char (point-min)) + (while (ignore-errors (compilation-next-file 1) t) + (let ((m (get-text-property (point) 'compilation-message))) + (push (expand-file-name + (caar (compilation--loc->file-struct + (compilation--message->loc m)))) + files)))) + (ggtags-navigation-mode -1) + (nreverse files)))) + (tags-query-replace from to delimited file-form))) + +(defun ggtags-global-search-id (cmd directory) + (sha1 (concat directory (make-string 1 0) cmd))) + +(defun ggtags-global-current-search () + ;; CMD DIR ENV LINE TEXT + (ggtags-ensure-global-buffer + (list (car compilation-arguments) + default-directory + ggtags-process-environment + (line-number-at-pos) + (buffer-substring-no-properties + (line-beginning-position) (line-end-position))))) + +(defun ggtags-global-rerun-search-1 (data) + (pcase data + (`(,cmd ,dir ,env ,line ,_text) + (with-current-buffer (let ((ggtags-auto-jump-to-match nil) + ;; Switch current project to DIR. + (default-directory dir) + (ggtags-project-root dir) + (ggtags-process-environment env)) + (ggtags-global-start cmd dir)) + (add-hook 'compilation-finish-functions + (lambda (buf _msg) + (with-current-buffer buf + (ggtags-forward-to-line line) + (compile-goto-error))) + nil t))))) + +(defvar-local ggtags-global-search-ewoc nil) +(defvar ggtags-global-rerun-search-last nil) + +(defvar ggtags-global-rerun-search-map + (cl-labels + ((save () + (setq ggtags-global-rerun-search-last + (ewoc-data (ewoc-locate ggtags-global-search-ewoc)))) + (next (arg) + (interactive "p") + (ewoc-goto-next ggtags-global-search-ewoc arg) + (save)) + (prev (arg) + (interactive "p") + (ewoc-goto-prev ggtags-global-search-ewoc arg) + (save)) + (quit () + (interactive) + (quit-windows-on (ewoc-buffer ggtags-global-search-ewoc) t)) + (done () + (interactive) + (let ((node (ewoc-locate ggtags-global-search-ewoc))) + (when node + (save) + (quit) + (ggtags-global-rerun-search-1 (cdr (ewoc-data node))))))) + (let ((m (make-sparse-keymap))) + (set-keymap-parent m special-mode-map) + (define-key m "p" #'prev) + (define-key m "\M-p" #'prev) + (define-key m "n" #'next) + (define-key m "\M-n" #'next) + (define-key m "r" #'ggtags-save-to-register) + (define-key m "q" #'quit) + (define-key m "\r" #'done) + m))) + +(defvar bookmark-make-record-function) + +(defun ggtags-global-rerun-search () + "Pop up a buffer to choose a past search to re-run. + +\\{ggtags-global-rerun-search-map}" + (interactive) + (or ggtags-global-search-history (user-error "No search history")) (let ((split-window-preferred-function ggtags-split-window-function) - (default-directory (ggtags-root-directory))) - (compilation-start - (if (or verbose (not buffer-file-name)) - (format "global %s %s \"%s\"" - (ggtags-global-options) - (if (y-or-n-p "Find definition (n for reference)? ") - "" "-r") - name) - (format "global %s --from-here=%d:'%s' \"%s\"" - (ggtags-global-options) - (line-number-at-pos) - (expand-file-name (file-truename buffer-file-name)) - name)) - 'ggtags-global-mode))) - -(defun ggtags-find-tag-resume () + (inhibit-read-only t)) + (pop-to-buffer "*Ggtags Search History*") + (erase-buffer) + (special-mode) + (use-local-map ggtags-global-rerun-search-map) + (setq-local ggtags-enable-navigation-keys nil) + (setq-local bookmark-make-record-function #'ggtags-make-bookmark-record) + (setq truncate-lines t) + (cl-labels ((prop (s) (propertize s 'face 'minibuffer-prompt)) + (pp (data) + (pcase data + (`(,_id ,cmd ,dir ,_env ,line ,text) + (insert (prop " cmd: ") cmd "\n" + (prop " dir: ") dir "\n" + (prop "line: ") (number-to-string line) "\n" + (prop "text: ") text "\n" + (propertize (make-string 32 ?-) 'face 'shadow)))))) + (setq ggtags-global-search-ewoc + (ewoc-create #'pp "Global search history keys: n:next p:prev r:register RET:choose\n"))) + (dolist (data ggtags-global-search-history) + (ewoc-enter-last ggtags-global-search-ewoc data)) + (and ggtags-global-rerun-search-last + (re-search-forward (cadr ggtags-global-rerun-search-last) nil t) + (ewoc-goto-node ggtags-global-search-ewoc + (ewoc-locate ggtags-global-search-ewoc))) + (set-buffer-modified-p nil) + (fit-window-to-buffer nil (floor (frame-height) 2)))) + +(defun ggtags-save-to-register (r) + "Save current search session to register R. +Use \\[jump-to-register] to restore the search session." + (interactive (list (register-read-with-preview "Save search to register: "))) + (cl-labels ((prn (data) + (pcase data + (`(,command ,root ,_env ,line ,_) + (princ (format "a ggtags search session `%s' in directory `%s' at line %d." + command root line)))))) + (set-register r (registerv-make + (if ggtags-global-search-ewoc + (cdr (ewoc-data (ewoc-locate ggtags-global-search-ewoc))) + (ggtags-global-current-search)) + :jump-func #'ggtags-global-rerun-search-1 + :print-func #'prn)))) + +(defun ggtags-make-bookmark-record () + `(,(and ggtags-current-tag-name (format "*ggtags %s*" ggtags-current-tag-name)) + (ggtags-search . ,(if ggtags-global-search-ewoc + (cdr (ewoc-data (ewoc-locate ggtags-global-search-ewoc))) + (ggtags-global-current-search))) + (handler . ggtags-bookmark-jump))) + +(declare-function bookmark-prop-get "bookmark") + +(defun ggtags-bookmark-jump (bmk) + (ggtags-global-rerun-search-1 (bookmark-prop-get bmk 'ggtags-search))) + +(defun ggtags-delete-tag-files () + "Delete the GTAGS, GRTAGS, GPATH etc. files generated by gtags." + (interactive (ignore (ggtags-check-project))) + (when (ggtags-current-project-root) + (let* ((re (concat "\\`" (regexp-opt '("GPATH" "GRTAGS" "GTAGS" "ID")) "\\'")) + (files (cl-remove-if-not + (lambda (file) + ;; Don't trust `directory-files'. + (let ((case-fold-search nil)) + (string-match-p re (file-name-nondirectory file)))) + (directory-files (ggtags-current-project-root) t re))) + (buffer "*GTags File List*")) + (or files (user-error "No tag files found")) + (with-output-to-temp-buffer buffer + (princ (mapconcat #'identity files "\n"))) + (let ((win (get-buffer-window buffer))) + (unwind-protect + (progn + (fit-window-to-buffer win) + (when (yes-or-no-p "Remove GNU Global tag files? ") + (with-demoted-errors (mapc #'delete-file files)) + (remhash (ggtags-current-project-root) ggtags-projects) + (and (overlayp ggtags-highlight-tag-overlay) + (delete-overlay ggtags-highlight-tag-overlay)))) + (when (window-live-p win) + (quit-window t win))))))) + +(defun ggtags-browse-file-as-hypertext (file line) + "Browse FILE in hypertext (HTML) form." + (interactive (if (or current-prefix-arg (not buffer-file-name)) + (list (read-file-name "Browse file: " nil nil t) + (read-number "Line: " 1)) + (list buffer-file-name (line-number-at-pos)))) + (cl-check-type line (integer 1)) + (or (and file (file-exists-p file)) (error "File `%s' doesn't exist" file)) + (ggtags-check-project) + (or (file-exists-p (expand-file-name "HTML" (ggtags-current-project-root))) + (if (yes-or-no-p "No hypertext form exists; run htags? ") + (let ((default-directory (ggtags-current-project-root))) + (ggtags-with-current-project (ggtags-process-string "htags"))) + (user-error "Aborted"))) + (let ((url (ggtags-process-string "gozilla" "-p" (format "+%d" line) + (file-relative-name file)))) + (or (equal (file-name-extension + (url-filename (url-generic-parse-url url))) "html") + (user-error "No hypertext form for `%s'" file)) + (when (called-interactively-p 'interactive) + (message "Browsing %s" url)) + (browse-url url))) + +(defun ggtags-next-mark (&optional arg) + "Move to the next (newer) mark in the tag marker ring." (interactive) - (ggtags-ensure-global-buffer - (ggtags-navigation-mode +1) - (let ((split-window-preferred-function ggtags-split-window-function)) - (compile-goto-error)))) + (and (ring-empty-p find-tag-marker-ring) (user-error "Tag ring empty")) + (setq ggtags-tag-ring-index + ;; Note `ring-minus1' gets newer item. + (funcall (if arg #'ring-plus1 #'ring-minus1) + (or ggtags-tag-ring-index + (progn + (ring-insert find-tag-marker-ring (point-marker)) + 0)) + (ring-length find-tag-marker-ring))) + (let ((m (ring-ref find-tag-marker-ring ggtags-tag-ring-index)) + (i (- (ring-length find-tag-marker-ring) ggtags-tag-ring-index)) + (message-log-max nil)) + (message "%d%s marker%s" i (pcase (mod i 10) + ;; ` required for 24.1 and 24.2 + (`1 "st") + (`2 "nd") + (`3 "rd") + (_ "th")) + (if (marker-buffer m) "" " (dead)")) + (if (not (marker-buffer m)) + (ding) + (switch-to-buffer (marker-buffer m)) + (goto-char m)))) + +(defun ggtags-prev-mark () + "Move to the previous (older) mark in the tag marker ring." + (interactive) + (ggtags-next-mark 'previous)) + +(defvar ggtags-view-tag-history-mode-map + (let ((m (make-sparse-keymap))) + (define-key m "\M-n" 'next-error-no-select) + (define-key m "\M-p" 'previous-error-no-select) + (define-key m "q" (lambda () (interactive) (quit-window t))) + m)) -(defvar-local ggtags-global-exit-status nil) +(define-derived-mode ggtags-view-tag-history-mode tabulated-list-mode "TagHist" + :abbrev-table nil :group 'ggtags) + +(defun ggtags-view-tag-history () + "Pop to a buffer listing visited locations from newest to oldest. +The buffer is a next error buffer and works with standard +commands `next-error' and `previous-error'. + +\\{ggtags-view-tag-history-mode-map}" + (interactive) + (and (ring-empty-p find-tag-marker-ring) + (user-error "Tag ring empty")) + (let ((split-window-preferred-function ggtags-split-window-function) + (inhibit-read-only t)) + (pop-to-buffer "*Tag Ring*") + (erase-buffer) + (ggtags-view-tag-history-mode) + (setq next-error-function #'ggtags-view-tag-history-next-error + next-error-last-buffer (current-buffer)) + (setq tabulated-list-entries + ;; Use a function so that revert can work properly. + (lambda () + (let ((counter (ring-length find-tag-marker-ring)) + (elements (or (ring-elements find-tag-marker-ring) + (user-error "Tag ring empty"))) + (action (lambda (_button) (next-error 0))) + (get-line (lambda (m) + (with-current-buffer (marker-buffer m) + (save-excursion + (goto-char m) + (buffer-substring (line-beginning-position) + (line-end-position))))))) + (setq tabulated-list-format + `[("ID" ,(max (1+ (floor (log counter 10))) 2) + car-less-than-car) + ("Buffer" ,(max (cl-loop for m in elements + for b = (marker-buffer m) + maximize + (length (and b (buffer-name b)))) + 6) + t :right-align t) + ("Position" ,(max (cl-loop for m in elements + for p = (or (marker-position m) 1) + maximize (1+ (floor (log p 10)))) + 8) + (lambda (x y) + (< (string-to-number (aref (cadr x) 2)) + (string-to-number (aref (cadr y) 2)))) + :right-align t) + ("Contents" 100 t)]) + (tabulated-list-init-header) + (mapcar (lambda (x) + (prog1 + (list counter + (if (marker-buffer x) + (vector (number-to-string counter) + `(,(buffer-name (marker-buffer x)) + face link + follow-link t + marker ,x + action ,action) + (number-to-string (marker-position x)) + (funcall get-line x)) + (vector (number-to-string counter) + "(dead)" "?" "?"))) + (cl-decf counter))) + elements)))) + (setq tabulated-list-sort-key '("ID" . t)) + (tabulated-list-print) + (fit-window-to-buffer nil (floor (frame-height) 2)))) + +(defun ggtags-view-tag-history-next-error (&optional arg reset) + (if (not reset) + (forward-button arg) + (goto-char (point-min)) + (forward-button (if (button-at (point)) 0 1))) + (when (get-buffer-window) + (set-window-point (get-buffer-window) (point))) + (pcase (button-get (button-at (point)) 'marker) + ((and (pred markerp) m) + (if (eq (get-buffer-window) (selected-window)) + (pop-to-buffer (marker-buffer m)) + (switch-to-buffer (marker-buffer m))) + (goto-char (marker-position m))) + (_ (error "Dead marker")))) (defun ggtags-global-exit-message-function (_process-status exit-status msg) (setq ggtags-global-exit-status exit-status) - (let ((count (save-excursion + (pcase-let ((`(,count . ,db) + (save-excursion (goto-char (point-max)) - (if (re-search-backward "^\\([0-9]+\\) \\w+ located" nil t) - (string-to-number (match-string 1)) - 0)))) + (if (re-search-backward + "^\\w+ \\(not found\\)\\|^\\([0-9]+\\) \\w+ located" nil t) + (cons (or (and (match-string 1) 0) + (string-to-number (match-string 2))) + (when (re-search-forward + "using \\(?:\\(idutils\\)\\|'[^']*/\\(\\w+\\)'\\)" + (line-end-position) + t) + (or (and (match-string 1) "ID") + (match-string 2)))) + (cons 0 nil))))) + (setq ggtags-global-match-count count) + ;; Clear the start marker in case of zero matches. + (and (zerop count) + (markerp ggtags-global-start-marker) + (setq ggtags-global-start-marker nil)) (cons (if (> exit-status 0) msg - (format "found %d %s" count (if (= count 1) "match" "matches"))) + (format "found %d %s" + count + (funcall (if (= count 1) #'car #'cadr) + (pcase db + ;; ` required for 24.1 and 24.2 + (`"GTAGS" '("definition" "definitions")) + (`"GSYMS" '("symbol" "symbols")) + (`"GRTAGS" '("reference" "references")) + (`"GPATH" '("file" "files")) + (`"ID" '("identifier" "identifiers")) + (_ '("match" "matches")))))) exit-status))) +(defun ggtags-global-column (start) + ;; START is the beginning position of source text. + (let ((mbeg (text-property-any start (line-end-position) 'global-color t))) + (and mbeg (- mbeg start)))) + ;;; NOTE: Must not match the 'Global started at Mon Jun 3 10:24:13' ;;; line or `compilation-auto-jump' will jump there and fail. See ;;; comments before the 'gnu' entry in ;;; `compilation-error-regexp-alist-alist'. (defvar ggtags-global-error-regexp-alist-alist (append - '((path "^\\(?:[^/\n]*/\\)?[^ )\t\n]+$" 0) - ;; ACTIVE_ESCAPE src/dialog.cc 172 + `((path "^\\(?:[^\"'\n]*/\\)?[^ )\t\n]+$" 0) + ;; ACTIVE_ESCAPE src/dialog.cc 172 (ctags "^\\([^ \t\n]+\\)[ \t]+\\(.*?\\)[ \t]+\\([0-9]+\\)$" 2 3 nil nil 2 (1 font-lock-function-name-face)) ;; ACTIVE_ESCAPE 172 src/dialog.cc #undef ACTIVE_ESCAPE (ctags-x "^\\([^ \t\n]+\\)[ \t]+\\([0-9]+\\)[ \t]+\\(\\(?:[^/\n]*/\\)?[^ \t\n]+\\)" - 3 2 nil nil 3 (1 font-lock-function-name-face)) + 3 2 (,(lambda () (ggtags-global-column (1+ (match-end 0))))) + nil 3 (1 font-lock-function-name-face)) ;; src/dialog.cc:172:#undef ACTIVE_ESCAPE - (grep "^\\(.+?\\):\\([0-9]+\\):\\(?:[^0-9\n]\\|[0-9][^0-9\n]\\|[0-9][0-9].\\)" - 1 2 nil nil 1) + (grep "^\\(.+?\\):\\([0-9]+\\):\\(?:$\\|[^0-9\n]\\|[0-9][^0-9\n]\\|[0-9][0-9].\\)" + 1 2 (,(lambda () (ggtags-global-column (1+ (match-end 2))))) nil 1) ;; src/dialog.cc ACTIVE_ESCAPE 172 #undef ACTIVE_ESCAPE (cscope "^\\(.+?\\)[ \t]+\\([^ \t\n]+\\)[ \t]+\\([0-9]+\\).*\\(?:[^0-9\n]\\|[^0-9\n][0-9]\\|[^:\n][0-9][0-9]\\)$" 1 3 nil nil 1 (2 font-lock-function-name-face))) @@ -323,7 +1248,7 @@ When called with prefix, ask the name and kind of tag." (1- (- wend wbeg))))))) (goto-char start) (while (and (> amount 0) (> end (point))) - (decf amount (funcall advance-word))))) + (cl-decf amount (funcall advance-word))))) (defun ggtags-abbreviate-files (start end) (goto-char start) @@ -340,22 +1265,72 @@ When called with prefix, ask the name and kind of tag." (get-text-property (match-beginning sub) 'compilation-message)) (ggtags-abbreviate-file (match-beginning sub) (match-end sub))))))) -(defun ggtags-handle-single-match (buf _how) - (when (and ggtags-auto-jump-to-first-match - ;; If exit abnormally keep the window for inspection. - (zerop ggtags-global-exit-status) - (save-excursion - (goto-char (point-min)) - (not (ignore-errors - (goto-char (compilation-next-single-property-change - (point) 'compilation-message)) - (end-of-line) - (compilation-next-single-property-change - (point) 'compilation-message))))) +(defvar-local ggtags-global-output-lines 0) + +(defun ggtags-global--display-buffer (&optional buffer) + (let ((buffer (or buffer (current-buffer)))) + (unless (get-buffer-window buffer) + (let* ((split-window-preferred-function ggtags-split-window-function) + (w (display-buffer buffer '(nil (allow-no-window . t))))) + (and w (compilation-set-window-height w)))))) + +(defun ggtags-global-filter () + "Called from `compilation-filter-hook' (which see)." + (let ((ansi-color-apply-face-function + (lambda (beg end face) + (when face + (ansi-color-apply-overlay-face beg end face) + (put-text-property beg end 'global-color t))))) + (ansi-color-apply-on-region compilation-filter-start (point))) + ;; Get rid of line "Using config file '/PATH/TO/.globalrc'." or + ;; "Using default configuration." + (when (re-search-backward + "^ *Using \\(?:config file '.*\\|default configuration.\\)\n" + compilation-filter-start t) + (replace-match "")) + (cl-incf ggtags-global-output-lines + (count-lines compilation-filter-start (point))) + (when (and (> ggtags-global-output-lines 5) ggtags-navigation-mode) + (ggtags-global--display-buffer)) + (when (and (eq ggtags-auto-jump-to-match 'history) + (numberp ggtags-auto-jump-to-match-target) + ;; `ggtags-global-output-lines' is imprecise. + (> (line-number-at-pos (point-max)) + ggtags-auto-jump-to-match-target)) + (ggtags-forward-to-line ggtags-auto-jump-to-match-target) + (setq-local ggtags-auto-jump-to-match-target nil) + ;; + ;; Can't call `compile-goto-error' here becuase + ;; `compilation-filter' restores point and as a result commands + ;; dependent on point such as `ggtags-navigation-next-file' and + ;; `ggtags-navigation-previous-file' fail to work. + (setq-local compilation-auto-jump-to-first-error t) + (run-with-idle-timer 0 nil #'compilation-auto-jump (current-buffer) (point))) + (make-local-variable 'ggtags-global-large-output) + (when (> ggtags-global-output-lines ggtags-global-large-output) + (cl-incf ggtags-global-large-output 500) + (let ((message-log-max nil)) + (message "Output %d lines (Type `C-c C-k' to cancel)" + ggtags-global-output-lines)))) + +(defun ggtags-global-handle-exit (buf how) + "A function for `compilation-finish-functions' (which see)." + (cond + ((string-prefix-p "exited abnormally" how) + ;; If exit abnormally display the buffer for inspection. + (ggtags-global--display-buffer)) + ((and ggtags-auto-jump-to-match + (not (pcase (compilation-next-single-property-change + (point-min) 'compilation-message) + ((and pt (guard pt)) + (compilation-next-single-property-change + (save-excursion (goto-char pt) (end-of-line) (point)) + 'compilation-message))))) + ;; For the `compilation-auto-jump' in idle timer to run. + ;; See also: http://debbugs.gnu.org/13829 + (sit-for 0) (ggtags-navigation-mode -1) - ;; 0.5s delay for `ggtags-auto-jump-to-first-match' - (sit-for 0) ; See: http://debbugs.gnu.org/13829 - (ggtags-navigation-mode-cleanup buf 0.5))) + (ggtags-navigation-mode-cleanup buf 0)))) (defvar ggtags-global-mode-font-lock-keywords '(("^Global \\(exited abnormally\\|interrupt\\|killed\\|terminated\\)\\(?:.*with code \\([0-9]+\\)\\)?.*" @@ -363,69 +1338,143 @@ When called with prefix, ask the name and kind of tag." (2 'compilation-error nil t)) ("^Global found \\([0-9]+\\)" (1 compilation-info-face)))) +(defvar compilation-always-kill) ;new in 24.3 + (define-compilation-mode ggtags-global-mode "Global" "A mode for showing outputs from gnu global." + ;; Make it buffer local for `ggtags-abbreviate-files'. + (make-local-variable 'ggtags-global-output-format) (setq-local compilation-error-regexp-alist (list ggtags-global-output-format)) - (setq-local compilation-auto-jump-to-first-error - ggtags-auto-jump-to-first-match) - (setq-local compilation-scroll-output 'first-error) + (pcase ggtags-auto-jump-to-match + (`history (make-local-variable 'ggtags-auto-jump-to-match-target) + (setq-local compilation-auto-jump-to-first-error + (not ggtags-auto-jump-to-match-target))) + (`nil (setq-local compilation-auto-jump-to-first-error nil)) + (_ (setq-local compilation-auto-jump-to-first-error t))) + (setq-local compilation-scroll-output nil) + ;; See `compilation-move-to-column' for details. + (setq-local compilation-first-column 0) + (setq-local compilation-error-screen-columns nil) (setq-local compilation-disable-input t) (setq-local compilation-always-kill t) (setq-local compilation-error-face 'compilation-info) (setq-local compilation-exit-message-function 'ggtags-global-exit-message-function) + ;; See: https://github.com/leoliu/ggtags/issues/26 + (setq-local find-file-suppress-same-file-warnings t) (setq-local truncate-lines t) (jit-lock-register #'ggtags-abbreviate-files) - (add-hook 'compilation-finish-functions 'ggtags-handle-single-match nil t) - (define-key ggtags-global-mode-map "o" 'visible-mode)) - -(defvar ggtags-navigation-mode-map + (add-hook 'compilation-filter-hook 'ggtags-global-filter nil 'local) + (add-hook 'compilation-finish-functions 'ggtags-global-handle-exit nil t) + (setq-local bookmark-make-record-function #'ggtags-make-bookmark-record) + (setq-local ggtags-enable-navigation-keys nil) + (add-hook 'kill-buffer-hook (lambda () (ggtags-navigation-mode -1)) nil t)) + +;; NOTE: Need this to avoid putting menu items in +;; `emulation-mode-map-alists', which creates double entries. See +;; http://i.imgur.com/VJJTzVc.png +(defvar ggtags-navigation-map (let ((map (make-sparse-keymap))) (define-key map "\M-n" 'next-error) (define-key map "\M-p" 'previous-error) (define-key map "\M-}" 'ggtags-navigation-next-file) (define-key map "\M-{" 'ggtags-navigation-previous-file) + (define-key map "\M->" 'ggtags-navigation-last-error) + (define-key map "\M-<" 'ggtags-navigation-first-error) + ;; Note: shadows `isearch-forward-regexp' but it can be invoked + ;; with C-u C-s instead. + (define-key map "\C-\M-s" 'ggtags-navigation-isearch-forward) + (define-key map "\C-c\C-k" + (lambda () (interactive) + (ggtags-ensure-global-buffer (kill-compilation)))) (define-key map "\M-o" 'ggtags-navigation-visible-mode) + (define-key map [return] 'ggtags-navigation-mode-done) (define-key map "\r" 'ggtags-navigation-mode-done) - ;; Intercept M-. and M-* keys (define-key map [remap pop-tag-mark] 'ggtags-navigation-mode-abort) - (define-key map [remap ggtags-find-tag] 'undefined) + map)) + +(defvar ggtags-mode-map-alist + `((ggtags-enable-navigation-keys . ,ggtags-navigation-map))) + +(defvar ggtags-navigation-mode-map + (let ((map (make-sparse-keymap)) + (menu (make-sparse-keymap "GG-Navigation"))) + ;; Menu items: (info "(elisp)Extended Menu Items") + (define-key map [menu-bar ggtags-navigation] (cons "GG-Navigation" menu)) + ;; Ordered backwards + (define-key menu [visible-mode] + '(menu-item "Visible mode" ggtags-navigation-visible-mode + :button (:toggle . (ignore-errors + (ggtags-ensure-global-buffer + visible-mode))))) + (define-key menu [done] + '(menu-item "Finish navigation" ggtags-navigation-mode-done)) + (define-key menu [abort] + '(menu-item "Abort" ggtags-navigation-mode-abort)) + (define-key menu [last-match] + '(menu-item "Last match" ggtags-navigation-last-error)) + (define-key menu [first-match] + '(menu-item "First match" ggtags-navigation-first-error)) + (define-key menu [previous-file] + '(menu-item "Previous file" ggtags-navigation-previous-file)) + (define-key menu [next-file] + '(menu-item "Next file" ggtags-navigation-next-file)) + (define-key menu [isearch-forward] + '(menu-item "Find match with isearch" ggtags-navigation-isearch-forward)) + (define-key menu [previous] + '(menu-item "Previous match" previous-error)) + (define-key menu [next] + '(menu-item "Next match" next-error)) map)) (defun ggtags-move-to-tag (&optional name) "Move to NAME tag in current line." - (let ((orig (point)) - (tag (or name ggtags-current-tag-name))) - (beginning-of-line) - (if (and tag (re-search-forward - (concat "\\_<" (regexp-quote tag) "\\_>") - (line-end-position) - t)) - (goto-char (match-beginning 0)) - (goto-char orig)))) + (let ((tag (or name ggtags-current-tag-name))) + ;; Do nothing if on the tag already i.e. by `ggtags-global-column'. + (unless (or (not tag) (looking-at (concat (regexp-quote tag) "\\_>"))) + (let ((orig (point)) + (regexps (mapcar (lambda (fmtstr) + (format fmtstr (regexp-quote tag))) + '("\\_<%s\\_>" "%s\\_>" "%s")))) + (beginning-of-line) + (if (cl-loop for re in regexps + ;; Note: tag might not agree with current + ;; major-mode's symbol, so try harder. For + ;; example, in `php-mode' $cacheBackend is a + ;; symbol, but cacheBackend is a tag. + thereis (re-search-forward re (line-end-position) t)) + (goto-char (match-beginning 0)) + (goto-char orig)))))) (defun ggtags-navigation-mode-cleanup (&optional buf time) - (let ((buf (or buf compilation-last-buffer))) + (let ((buf (or buf ggtags-global-last-buffer))) (and (buffer-live-p buf) (with-current-buffer buf (when (get-buffer-process (current-buffer)) (kill-compilation)) (when (and (derived-mode-p 'ggtags-global-mode) (get-buffer-window)) - (quit-window nil (get-buffer-window))) - (and time (run-with-idle-timer time nil 'kill-buffer buf)))))) + (quit-windows-on (current-buffer))) + (and time (run-with-idle-timer time nil #'kill-buffer buf)))))) (defun ggtags-navigation-mode-done () (interactive) (ggtags-navigation-mode -1) + (setq tags-loop-scan t + tags-loop-operate '(ggtags-find-tag-continue)) (ggtags-navigation-mode-cleanup)) (defun ggtags-navigation-mode-abort () (interactive) - (pop-tag-mark) (ggtags-navigation-mode -1) - (ggtags-navigation-mode-cleanup nil 0)) + (ggtags-navigation-mode-cleanup nil 0) + ;; Run after (ggtags-navigation-mode -1) or + ;; ggtags-global-start-marker might not have been saved. + (when (and ggtags-global-start-marker + (not (markerp ggtags-global-start-marker))) + (setq ggtags-global-start-marker nil) + (pop-tag-mark))) (defun ggtags-navigation-next-file (n) (interactive "p") @@ -437,159 +1486,435 @@ When called with prefix, ask the name and kind of tag." (interactive "p") (ggtags-navigation-next-file (- n))) +(defun ggtags-navigation-first-error () + (interactive) + (ggtags-ensure-global-buffer + (goto-char (point-min)) + (compilation-next-error 1) + (compile-goto-error))) + +(defun ggtags-navigation-last-error () + (interactive) + (ggtags-ensure-global-buffer + (goto-char (point-max)) + (compilation-previous-error 1) + (compile-goto-error))) + +(defun ggtags-navigation-isearch-forward (&optional regexp-p) + (interactive "P") + (ggtags-ensure-global-buffer + (let ((saved (if visible-mode 1 -1))) + (visible-mode 1) + (with-selected-window (get-buffer-window (current-buffer)) + (isearch-forward regexp-p) + (beginning-of-line) + (visible-mode saved) + (compile-goto-error))))) + (defun ggtags-navigation-visible-mode (&optional arg) (interactive (list (or current-prefix-arg 'toggle))) (ggtags-ensure-global-buffer (visible-mode arg))) +(defvar ggtags-global-line-overlay nil) + +(defun ggtags-global-next-error-function () + (when (eq next-error-last-buffer ggtags-global-last-buffer) + (ggtags-move-to-tag) + (ggtags-global-save-start-marker) + (and (ggtags-project-update-mtime-maybe) + (message "File `%s' is newer than GTAGS" + (file-name-nondirectory buffer-file-name))) + (and ggtags-mode-sticky (ggtags-mode 1)) + (ignore-errors + (ggtags-ensure-global-buffer + (unless (overlayp ggtags-global-line-overlay) + (setq ggtags-global-line-overlay (make-overlay (point) (point))) + (overlay-put ggtags-global-line-overlay 'face 'ggtags-global-line)) + (move-overlay ggtags-global-line-overlay + (line-beginning-position) (line-end-position) + (current-buffer)) + ;; Update search history + (let ((id (ggtags-global-search-id (car compilation-arguments) + default-directory))) + (setq ggtags-global-search-history + (cl-remove id ggtags-global-search-history :test #'equal :key #'car)) + (add-to-history 'ggtags-global-search-history + (cons id (ggtags-global-current-search)) + ggtags-global-history-length)))) + (run-hooks 'ggtags-find-tag-hook))) + (define-minor-mode ggtags-navigation-mode nil - :lighter (" GG[" (:propertize "n" face error) "]") + :lighter + (" GG[" (:eval + (ignore-errors + (ggtags-ensure-global-buffer + (let ((index (when (get-text-property (line-beginning-position) + 'compilation-message) + ;; Assume the first match appears at line 5 + (- (line-number-at-pos) 4)))) + `((:propertize ,(if index + (number-to-string (max index 0)) + "?") face success) "/"))))) + (:propertize (:eval (number-to-string ggtags-global-match-count)) + face success) + (:eval + (unless (zerop ggtags-global-exit-status) + `(":" (:propertize ,(number-to-string ggtags-global-exit-status) + face error)))) + "]") :global t (if ggtags-navigation-mode (progn - (add-hook 'next-error-hook 'ggtags-move-to-tag) + ;; Higher priority for `ggtags-navigation-mode' to avoid being + ;; hijacked by modes such as `view-mode'. + (add-to-list 'emulation-mode-map-alists 'ggtags-mode-map-alist) + (add-hook 'next-error-hook 'ggtags-global-next-error-function) (add-hook 'minibuffer-setup-hook 'ggtags-minibuffer-setup-function)) - (remove-hook 'next-error-hook 'ggtags-move-to-tag) + (setq emulation-mode-map-alists + (delq 'ggtags-mode-map-alist emulation-mode-map-alists)) + (remove-hook 'next-error-hook 'ggtags-global-next-error-function) (remove-hook 'minibuffer-setup-hook 'ggtags-minibuffer-setup-function))) (defun ggtags-minibuffer-setup-function () ;; Disable ggtags-navigation-mode in minibuffer. - (setq-local ggtags-navigation-mode nil)) + (setq-local ggtags-enable-navigation-keys nil)) (defun ggtags-kill-file-buffers (&optional interactive) - "Kill all buffers visiting files in the root directory." + "Kill all buffers visiting files in current project." (interactive "p") - (ggtags-check-root-directory) - (let ((root (ggtags-root-directory)) - (count 0) - (some (lambda (pred list) - (loop for x in list when (funcall pred x) return it)))) + (ggtags-check-project) + (let ((directories (cons (ggtags-current-project-root) (ggtags-get-libpath))) + (count 0)) (dolist (buf (buffer-list)) (let ((file (and (buffer-live-p buf) (not (eq buf (current-buffer))) (buffer-file-name buf)))) - (when (and file (funcall some (apply-partially #'file-in-directory-p - (file-truename file)) - (cons root (ggtags-get-libpath)))) - (and (kill-buffer buf) - (incf count))))) + (when (and file (cl-some (lambda (dir) + ;; Don't use `file-in-directory-p' + ;; to allow symbolic links. + (string-prefix-p dir file)) + directories)) + (and (kill-buffer buf) (cl-incf count))))) (and interactive (message "%d %s killed" count (if (= count 1) "buffer" "buffers"))))) (defun ggtags-after-save-function () - (let ((root (with-demoted-errors (ggtags-root-directory)))) - (and root (ggtags-cache-mark-dirty root t)))) - -(defvar ggtags-tag-overlay nil) -(defvar ggtags-highlight-tag-timer nil) + (when (ggtags-find-project) + (ggtags-project-update-mtime-maybe) + ;; When oversize update on a per-save basis. + (when (and buffer-file-name + (or ggtags-global-always-update (ggtags-project-oversize-p))) + (ggtags-with-current-project + (process-file (ggtags-program-path "global") nil 0 nil "--single-update" + (file-relative-name buffer-file-name)))))) + +(defun ggtags-global-output (buffer cmds callback &optional cutoff) + "Asynchronously pipe the output of running CMDS to BUFFER. +When finished invoke CALLBACK in BUFFER with process exit status." + (or buffer (error "Output buffer required")) + (let* ((program (car cmds)) + (args (cdr cmds)) + (cutoff (and cutoff (+ cutoff (if (get-buffer buffer) + (with-current-buffer buffer + (line-number-at-pos (point-max))) + 0)))) + (proc (apply #'start-file-process program buffer program args)) + (filter (lambda (proc string) + (and (buffer-live-p (process-buffer proc)) + (with-current-buffer (process-buffer proc) + (goto-char (process-mark proc)) + (insert string) + (when (and (> (line-number-at-pos (point-max)) cutoff) + (process-live-p proc)) + (interrupt-process (current-buffer))))))) + (sentinel (lambda (proc _msg) + (when (memq (process-status proc) '(exit signal)) + (with-current-buffer (process-buffer proc) + (set-process-buffer proc nil) + (funcall callback (process-exit-status proc))))))) + (set-process-query-on-exit-flag proc nil) + (and cutoff (set-process-filter proc filter)) + (set-process-sentinel proc sentinel) + proc)) + +(defun ggtags-show-definition-default (defs) + (let (message-log-max) + (message "%s%s" (or (caar defs) "[definition not found]") + (if (cdr defs) " [guess]" "")))) + +(defun ggtags-show-definition (name) + (interactive (list (ggtags-read-tag 'definition current-prefix-arg))) + (ggtags-check-project) + (let* ((re (cadr (assq 'grep ggtags-global-error-regexp-alist-alist))) + (current (current-buffer)) + (buffer (get-buffer-create " *ggtags-definition*")) + (fn ggtags-show-definition-function) + (show (lambda (_status) + (goto-char (point-min)) + (let ((defs (cl-loop while (re-search-forward re nil t) + collect (list (buffer-substring (1+ (match-end 2)) + (line-end-position)) + name + (match-string 1) + (string-to-number (match-string 2)))))) + (kill-buffer buffer) + (with-current-buffer current + (funcall fn defs)))))) + (ggtags-with-current-project + (ggtags-global-output + buffer + (list (ggtags-program-path "global") + "--result=grep" "--path-style=absolute" name) + show 100)))) + +(defvar ggtags-mode-prefix-map + (let ((m (make-sparse-keymap))) + ;; Globally bound to `M-g p'. + ;; (define-key m "\M-'" 'previous-error) + (define-key m (kbd "M-DEL") 'ggtags-delete-tag-files) + (define-key m "\M-p" 'ggtags-prev-mark) + (define-key m "\M-n" 'ggtags-next-mark) + (define-key m "\M-f" 'ggtags-find-file) + (define-key m "\M-o" 'ggtags-find-other-symbol) + (define-key m "\M-g" 'ggtags-grep) + (define-key m "\M-i" 'ggtags-idutils-query) + (define-key m "\M-b" 'ggtags-browse-file-as-hypertext) + (define-key m "\M-k" 'ggtags-kill-file-buffers) + (define-key m "\M-h" 'ggtags-view-tag-history) + (define-key m "\M-j" 'ggtags-visit-project-root) + (define-key m "\M-/" 'ggtags-global-rerun-search) + (define-key m (kbd "M-SPC") 'ggtags-save-to-register) + (define-key m (kbd "M-%") 'ggtags-query-replace) + (define-key m "\M-?" 'ggtags-show-definition) + m)) (defvar ggtags-mode-map + (let ((map (make-sparse-keymap)) + (menu (make-sparse-keymap "Ggtags"))) + (define-key map "\M-." 'ggtags-find-tag-dwim) + (define-key map (kbd "M-]") 'ggtags-find-reference) + (define-key map (kbd "C-M-.") 'ggtags-find-tag-regexp) + (define-key map ggtags-mode-prefix-key ggtags-mode-prefix-map) + ;; Menu items + (define-key map [menu-bar ggtags] (cons "Ggtags" menu)) + ;; Ordered backwards + (define-key menu [report-bugs] + `(menu-item "Report bugs" + (lambda () (interactive) + (browse-url ggtags-bug-url) + (message "Please visit %s" ggtags-bug-url)) + :help ,(format "Visit %s" ggtags-bug-url))) + (define-key menu [custom-ggtags] + '(menu-item "Customize Ggtags" + (lambda () (interactive) (customize-group 'ggtags)))) + (define-key menu [save-project] + '(menu-item "Save project settings" ggtags-save-project-settings)) + (define-key menu [toggle-read-only] + '(menu-item "Toggle project read-only" ggtags-toggle-project-read-only + :button (:toggle . buffer-read-only))) + (define-key menu [visit-project-root] + '(menu-item "Visit project root" ggtags-visit-project-root)) + (define-key menu [sep2] menu-bar-separator) + (define-key menu [browse-hypertext] + '(menu-item "Browse as hypertext" ggtags-browse-file-as-hypertext + :enable (ggtags-find-project))) + (define-key menu [delete-tags] + '(menu-item "Delete tag files" ggtags-delete-tag-files + :enable (ggtags-find-project))) + (define-key menu [kill-buffers] + '(menu-item "Kill project file buffers" ggtags-kill-file-buffers + :enable (ggtags-find-project))) + (define-key menu [view-tag] + '(menu-item "View tag history" ggtags-view-tag-history)) + (define-key menu [pop-mark] + '(menu-item "Pop mark" pop-tag-mark + :help "Pop to previous mark and destroy it")) + (define-key menu [next-mark] + '(menu-item "Next mark" ggtags-next-mark)) + (define-key menu [prev-mark] + '(menu-item "Previous mark" ggtags-prev-mark)) + (define-key menu [sep1] menu-bar-separator) + (define-key menu [rerun-search] + '(menu-item "Rerun past search" ggtags-global-rerun-search)) + (define-key menu [save-to-register] + '(menu-item "Save search session" ggtags-save-to-register)) + (define-key menu [previous-error] + '(menu-item "Previous match" previous-error)) + (define-key menu [next-error] + '(menu-item "Next match" next-error)) + (define-key menu [find-file] + '(menu-item "Find files" ggtags-find-file)) + (define-key menu [query-replace] + '(menu-item "Query replace" ggtags-query-replace)) + (define-key menu [idutils] + '(menu-item "Query idutils DB" ggtags-idutils-query)) + (define-key menu [grep] + '(menu-item "Grep" ggtags-grep)) + (define-key menu [find-symbol] + '(menu-item "Find other symbol" ggtags-find-other-symbol)) + (define-key menu [find-tag-regexp] + '(menu-item "Find tag matching regexp" ggtags-find-tag-regexp)) + (define-key menu [show-definition] + '(menu-item "Show definition" ggtags-show-definition)) + (define-key menu [find-reference] + '(menu-item "Find reference" ggtags-find-reference)) + (define-key menu [find-tag-continue] + '(menu-item "Continue find tag" tags-loop-continue)) + (define-key menu [find-tag] + '(menu-item "Find tag" ggtags-find-tag-dwim)) + (define-key menu [update-tags] + '(menu-item "Update tag files" ggtags-update-tags + :visible (ggtags-find-project))) + (define-key menu [run-gtags] + '(menu-item "Run gtags" ggtags-create-tags + :visible (not (ggtags-find-project)))) + map)) + +(defvar ggtags-mode-line-project-keymap (let ((map (make-sparse-keymap))) - (define-key map "\M-." 'ggtags-find-tag) - (define-key map "\M-," 'ggtags-find-tag-resume) - (define-key map "\C-c\M-k" 'ggtags-kill-file-buffers) + (define-key map [mode-line mouse-1] 'ggtags-visit-project-root) map)) +(put 'ggtags-mode-line-project-name 'risky-local-variable t) +(defvar ggtags-mode-line-project-name + '("[" (:eval (let ((name (if (stringp ggtags-project-root) + (file-name-nondirectory + (directory-file-name ggtags-project-root)) + "?"))) + (propertize + name 'face compilation-info-face + 'help-echo (if (stringp ggtags-project-root) + (concat "mouse-1 to visit " ggtags-project-root) + "mouse-1 to set project") + 'mouse-face 'mode-line-highlight + 'keymap ggtags-mode-line-project-keymap))) + "]") + "Mode line construct for displaying current project name. +The value is the name of the project root directory. Setting it +to nil disables displaying this information.") + ;;;###autoload (define-minor-mode ggtags-mode nil :lighter (:eval (if ggtags-navigation-mode "" " GG")) + (unless (timerp ggtags-highlight-tag-timer) + (setq ggtags-highlight-tag-timer + (run-with-idle-timer + ggtags-highlight-tag-delay t #'ggtags-highlight-tag-at-point))) (if ggtags-mode (progn (add-hook 'after-save-hook 'ggtags-after-save-function nil t) - (or (executable-find "global") - (message "Failed to find GNU Global"))) + ;; Append to serve as a fallback method. + (add-hook 'completion-at-point-functions + #'ggtags-completion-at-point t t) + (unless (memq 'ggtags-mode-line-project-name + mode-line-buffer-identification) + (setq mode-line-buffer-identification + (append mode-line-buffer-identification + '(ggtags-mode-line-project-name))))) (remove-hook 'after-save-hook 'ggtags-after-save-function t) - (and (overlayp ggtags-tag-overlay) - (delete-overlay ggtags-tag-overlay)) - (setq ggtags-tag-overlay nil))) + (remove-hook 'completion-at-point-functions #'ggtags-completion-at-point t) + (setq mode-line-buffer-identification + (delq 'ggtags-mode-line-project-name mode-line-buffer-identification)) + (and (overlayp ggtags-highlight-tag-overlay) + (delete-overlay ggtags-highlight-tag-overlay)) + (setq ggtags-highlight-tag-overlay nil))) + +(defvar ggtags-highlight-tag-map + (let ((map (make-sparse-keymap))) + ;; Bind down- events so that the global keymap won't ``shine + ;; through''. See `mode-line-buffer-identification-keymap' for + ;; similar workaround. + (define-key map [S-mouse-1] 'ggtags-find-tag-dwim) + (define-key map [S-down-mouse-1] 'ignore) + (define-key map [S-mouse-3] 'ggtags-find-reference) + (define-key map [S-down-mouse-3] 'ignore) + map) + "Keymap used for valid tag at point.") + +(put 'ggtags-active-tag 'face 'ggtags-highlight) +(put 'ggtags-active-tag 'keymap ggtags-highlight-tag-map) +;; (put 'ggtags-active-tag 'mouse-face 'match) +(put 'ggtags-active-tag 'help-echo + "S-mouse-1 for definitions\nS-mouse-3 for references") (defun ggtags-highlight-tag-at-point () - (when ggtags-mode - (unless (overlayp ggtags-tag-overlay) - (setq ggtags-tag-overlay (make-overlay (point) (point))) - (overlay-put ggtags-tag-overlay 'ggtags t)) - (let* ((bounds (bounds-of-thing-at-point 'symbol)) - (valid-tag (when bounds - (member (buffer-substring (car bounds) (cdr bounds)) - (ggtags-tag-names)))) - (o ggtags-tag-overlay) - (done-p (lambda () - (and (memq o (overlays-at (car bounds))) - (= (overlay-start o) (car bounds)) - (= (overlay-end o) (cdr bounds)) - (or (and valid-tag (overlay-get o 'face)) - (and (not valid-tag) (not (overlay-get o 'face)))))))) + (when (and ggtags-mode ggtags-project-root (ggtags-find-project)) + (unless (overlayp ggtags-highlight-tag-overlay) + (setq ggtags-highlight-tag-overlay (make-overlay (point) (point) nil t)) + (overlay-put ggtags-highlight-tag-overlay 'modification-hooks + (list (lambda (o after &rest _args) + (and (not after) (delete-overlay o)))))) + (let ((bounds (funcall ggtags-bounds-of-tag-function)) + (o ggtags-highlight-tag-overlay)) (cond - ((not bounds) - (overlay-put ggtags-tag-overlay 'face nil) - (move-overlay ggtags-tag-overlay (point) (point) (current-buffer))) - ((not (funcall done-p)) + ((and bounds + (eq (overlay-buffer o) (current-buffer)) + (= (overlay-start o) (car bounds)) + (= (overlay-end o) (cdr bounds))) + ;; Overlay matches current tag so do nothing. + nil) + ((and bounds (let ((completion-ignore-case nil)) + (test-completion + (buffer-substring (car bounds) (cdr bounds)) + ggtags-completion-table))) (move-overlay o (car bounds) (cdr bounds) (current-buffer)) - (overlay-put o 'face (and valid-tag 'ggtags-highlight))))))) + (overlay-put o 'category 'ggtags-active-tag)) + (t (move-overlay o + (or (car bounds) (point)) + (or (cdr bounds) (point)) + (current-buffer)) + (overlay-put o 'category nil)))))) ;;; imenu (defun ggtags-goto-imenu-index (name line &rest _args) - (save-restriction - (widen) - (goto-char (point-min)) - (forward-line (1- line)) - (ggtags-move-to-tag name))) + (ggtags-forward-to-line line) + (ggtags-move-to-tag name)) ;;;###autoload (defun ggtags-build-imenu-index () "A function suitable for `imenu-create-index-function'." - (when buffer-file-name - (let ((file (file-truename buffer-file-name))) - (with-temp-buffer - (when (with-demoted-errors - (zerop (call-process "global" nil t nil "-f" file))) - (goto-char (point-min)) - (loop while (re-search-forward - "^\\([^ \t]+\\)[ \t]+\\([0-9]+\\)" nil t) - collect (list (match-string 1) - (string-to-number (match-string 2)) - 'ggtags-goto-imenu-index))))))) + (let ((file (and buffer-file-name (file-relative-name buffer-file-name)))) + (and file (with-temp-buffer + (when (with-demoted-errors + (zerop (ggtags-with-current-project + (process-file (ggtags-program-path "global") + nil t nil "-x" "-f" file)))) + (goto-char (point-min)) + (cl-loop while (re-search-forward + "^\\([^ \t]+\\)[ \t]+\\([0-9]+\\)" nil t) + collect (list (match-string 1) + (string-to-number (match-string 2)) + 'ggtags-goto-imenu-index))))))) ;;; hippie-expand ;;;###autoload -(defun try-complete-ggtags-tag (old) +(defun ggtags-try-complete-tag (old) "A function suitable for `hippie-expand-try-functions-list'." - (with-no-warnings ; to avoid loading hippie-exp - (unless old - (he-init-string (if (looking-back "\\_<.*" (line-beginning-position)) - (match-beginning 0) - (point)) - (point)) - (setq he-expand-list - (and (not (equal he-search-string "")) - (with-demoted-errors (ggtags-root-directory)) - (sort (all-completions he-search-string - (ggtags-tag-names)) - 'string-lessp)))) - (if (null he-expand-list) - (progn - (if old (he-reset-string)) - nil) - (he-substitute-string (car he-expand-list)) - (setq he-expand-list (cdr he-expand-list)) - t))) - -;;; Finish up - -(when ggtags-highlight-tag-timer - (cancel-timer ggtags-highlight-tag-timer)) - -(setq ggtags-highlight-tag-timer - (run-with-idle-timer 0.2 t 'ggtags-highlight-tag-at-point)) - -;; Higher priority for `ggtags-navigation-mode' to avoid being -;; hijacked by modes such as `view-mode'. -(defvar ggtags-mode-map-alist - `((ggtags-navigation-mode . ,ggtags-navigation-mode-map))) - -(add-to-list 'emulation-mode-map-alists 'ggtags-mode-map-alist) + (eval-and-compile (require 'hippie-exp)) + (unless old + (he-init-string (or (car (funcall ggtags-bounds-of-tag-function)) (point)) + (point)) + (setq he-expand-list + (and (not (equal he-search-string "")) + (ggtags-find-project) + (sort (all-completions he-search-string + ggtags-completion-table) + #'string-lessp)))) + (if (null he-expand-list) + (progn + (if old (he-reset-string)) + nil) + (he-substitute-string (car he-expand-list)) + (setq he-expand-list (cdr he-expand-list)) + t)) + +(defun ggtags-reload (&optional force) + (interactive "P") + (unload-feature 'ggtags force) + (require 'ggtags)) (provide 'ggtags) ;;; ggtags.el ends here