From: Andreas Gerler Date: Sat, 25 Nov 2023 10:33:54 +0000 (+0100) Subject: update ggtags X-Git-Url: http://git.bundesbrandschatzamt.de/?a=commitdiff_plain;h=be88fcb9e595b101f0c5d33cf3486f0d040e21c1;p=emacsconfig.git update ggtags Signed-off-by: Andreas Gerler --- diff --git a/elpa/ggtags-20211020.354/ggtags-autoloads.el b/elpa/ggtags-20211020.354/ggtags-autoloads.el deleted file mode 100644 index 63cb4c9c..00000000 --- a/elpa/ggtags-20211020.354/ggtags-autoloads.el +++ /dev/null @@ -1,64 +0,0 @@ -;;; ggtags-autoloads.el --- automatically extracted autoloads -*- lexical-binding: t -*- -;; -;;; Code: - -(add-to-list 'load-path (directory-file-name - (or (file-name-directory #$) (car load-path)))) - - -;;;### (autoloads nil "ggtags" "ggtags.el" (0 0 0 0)) -;;; Generated autoloads from ggtags.el - -(autoload 'ggtags-find-project "ggtags" nil nil nil) - -(autoload 'ggtags-find-tag-dwim "ggtags" "\ -Find NAME by context. -If point is at a definition tag, find references, and vice versa. -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. - -\(fn NAME &optional WHAT)" t nil) - -(autoload 'ggtags-mode "ggtags" "\ -Toggle Ggtags mode on or off. - -This is a minor mode. If called interactively, toggle the -`Ggtags mode' mode. If the prefix argument is positive, enable -the mode, and if it is zero or negative, disable the mode. - -If called from Lisp, toggle the mode if ARG is `toggle'. Enable -the mode if ARG is nil, omitted, or is a positive number. -Disable the mode if ARG is a negative number. - -To check whether the minor mode is enabled in the current buffer, -evaluate `ggtags-mode'. - -The mode's hook is called both when the mode is enabled and when -it is disabled. - -\\{ggtags-mode-map} - -\(fn &optional ARG)" t nil) - -(autoload 'ggtags-build-imenu-index "ggtags" "\ -A function suitable for `imenu-create-index-function'." nil nil) - -(autoload 'ggtags-try-complete-tag "ggtags" "\ -A function suitable for `hippie-expand-try-functions-list'. - -\(fn OLD)" nil nil) - -(register-definition-prefixes "ggtags" '("ggtags-")) - -;;;*** - -;; Local Variables: -;; version-control: never -;; no-byte-compile: t -;; no-update-autoloads: t -;; coding: utf-8 -;; End: -;;; ggtags-autoloads.el ends here diff --git a/elpa/ggtags-20211020.354/ggtags-pkg.el b/elpa/ggtags-20211020.354/ggtags-pkg.el deleted file mode 100644 index 61c4f00f..00000000 --- a/elpa/ggtags-20211020.354/ggtags-pkg.el +++ /dev/null @@ -1,2 +0,0 @@ -;;; Generated package description from ggtags.el -*- no-byte-compile: t -*- -(define-package "ggtags" "20211020.354" "emacs frontend to GNU Global source code tagging system" '((emacs "25")) :commit "8e16861392d7499bf3a212db1f5e9e0ef2e4fba9" :authors '(("Leo Liu" . "sdl.web@gmail.com")) :maintainer '("Leo Liu" . "sdl.web@gmail.com") :keywords '("tools" "convenience") :url "https://github.com/leoliu/ggtags") diff --git a/elpa/ggtags-20211020.354/ggtags.el b/elpa/ggtags-20211020.354/ggtags.el deleted file mode 100644 index 4027785b..00000000 --- a/elpa/ggtags-20211020.354/ggtags.el +++ /dev/null @@ -1,2478 +0,0 @@ -;;; ggtags.el --- emacs frontend to GNU Global source code tagging system -*- lexical-binding: t; -*- - -;; Copyright (C) 2013-2019 Free Software Foundation, Inc. - -;; Author: Leo Liu -;; Version: 0.9.0 -;; Package-Version: 20211020.354 -;; Package-Commit: 8e16861392d7499bf3a212db1f5e9e0ef2e4fba9 -;; Keywords: tools, convenience -;; Created: 2013-01-29 -;; URL: https://github.com/leoliu/ggtags -;; Package-Requires: ((emacs "25")) - -;; 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 -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; This program 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 this program. If not, see . - -;;; Commentary: - -;; A package to integrate GNU Global source code tagging system -;; (http://www.gnu.org/software/global) with Emacs. -;; -;; Usage: -;; -;; `ggtags' is similar to the standard `etags' package. These keys -;; `M-.', `M-,' and `C-M-.' should work as expected in `ggtags-mode'. -;; See the README in https://github.com/leoliu/ggtags for more -;; details. -;; -;; All commands are available from the `Ggtags' menu in `ggtags-mode'. - -;;; NEWS 0.8.13 (2018-07-25): - -;; - Don't choke on tag names start with `-'. -;; - `ggtags-show-definition' supports `ggtags-sort-by-nearness'. -;; - New variable `ggtags-extra-args'. -;; - Unbreak `ggtags-sort-by-nearness'. -;; -;; See full NEWS on https://github.com/leoliu/ggtags#news - -;;; Code: - -(eval-when-compile - (require 'url-parse)) - -(require 'cl-lib) -(require 'ewoc) -(require 'compile) -(require 'etags) - -(eval-when-compile - (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))) - - (defmacro with-display-buffer-no-window (&rest body) - (declare (debug t) (indent 0)) - ;; See http://debbugs.gnu.org/13594 - `(let ((display-buffer-overriding-action - (if ggtags-auto-jump-to-match - (list #'display-buffer-no-window) - display-buffer-overriding-action))) - ,@body))) - -(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." - :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-oversize-limit (* 10 1024 1024) - "The over size limit for the GTAGS file. -When the size of the GTAGS file is below this limit, ggtags -always maintains up-to-date tags for the whole source tree by -running `global -u'. For projects with GTAGS larger than this -limit, only files edited in Ggtags mode are updated (via `global ---single-update')." - :safe 'numberp - :type '(choice (const :tag "None" nil) - (const :tag "Always" t) - number) - :group 'ggtags) - -(defcustom ggtags-include-pattern - '("^\\s-*#\\s-*\\(?:include\\|import\\)\\s-*[\"<]\\(?:[./]*\\)?\\(.*?\\)[\">]" . 1) - "Pattern used to detect #include files. -Value can be (REGEXP . SUB) or a function with no arguments. -REGEXP should match from the beginning of line." - :type '(choice (const :tag "Disable" nil) - (cons regexp integer) - function) - :safe 'stringp - :group 'ggtags) - -;; See also: http://article.gmane.org/gmane.comp.gnu.global.bugs/1751 -(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. - -Note: GNU Global v6.2.13 has the feature of using gtags.conf at -project root. Setting this variable to nil doesn't disable this -feature." - :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 'history - "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 *ggtags-global* popup window. -If nil, use Emacs default." - :type '(choice (const :tag "Default" nil) integer) - :group 'ggtags) - -(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) - :group 'ggtags) - -(defcustom ggtags-split-window-function split-window-preferred-function - "A function to control how ggtags pops up the auxiliary window." - :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-use-sqlite3 nil - "Use sqlite3 for storage instead of Berkeley DB. -This feature requires GNU Global 6.3.3+ and is ignored if `gtags' -isn't built with sqlite3 support." - :type 'boolean - :safe 'booleanp - :group 'ggtags) - -(defcustom ggtags-extra-args nil - "Extra arguments to pass to `gtags' in `ggtags-create-tags'." - :type '(repeat string) - :safe #'ggtags-list-of-string-p - :group 'ggtags) - -(defcustom ggtags-sort-by-nearness nil - "Sort tags by nearness to current directory. -GNU Global 6.5+ required." - :type 'boolean - :safe #'booleanp - :group 'ggtags) - -(defcustom ggtags-update-on-save t - "Non-nil to update tags for current buffer on saving." - ;; It is reported that `global --single-update' can be slow in sshfs - ;; directories. See https://github.com/leoliu/ggtags/issues/85. - :safe #'booleanp - :type 'boolean - :group 'ggtags) - -(defcustom ggtags-global-output-format 'grep - "Global output format: path, ctags, ctags-x, grep or cscope." - :type '(choice (const path) - (const ctags) - (const ctags-x) - (const grep) - (const cscope)) - :group 'ggtags) - -(defcustom ggtags-global-use-color t - "Non-nil to use color in output if supported by Global. -Note: processing colored output takes noticeable time -particularly when the output is large." - :type 'boolean - :safe 'booleanp - :group 'ggtags) - -(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) - -;; See also https://github.com/leoliu/ggtags/issues/52 -(defcustom ggtags-global-search-libpath-for-reference t - "If non-nil global will search GTAGSLIBPATH for references. -Search is only continued in GTAGSLIBPATH if it finds no matches -in current project." - :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-get-definition-function #'ggtags-get-definition-default - "Function called by `ggtags-show-definition' to get 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. - -The return value is passed to `ggtags-print-definition-function'." - :type 'function - :group 'ggtags) - -(defcustom ggtags-print-definition-function - (lambda (s) (ggtags-echo "%s" (or s "[definition not found]"))) - "Function used by `ggtags-show-definition' to print 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-completing-read-function nil - "Ggtags specific `completing-read-function' (which see). -Nil means using the value of `completing-read-function'." - :type '(choice (const :tag "Use completing-read-function" nil) - function) - :group 'ggtags) - -(define-obsolete-variable-alias 'ggtags-highlight-tag-delay 'ggtags-highlight-tag - "0.8.11") - -(defcustom ggtags-highlight-tag 0.25 - "If non-nil time in seconds before highlighting tag at point. -Set to nil to disable tag highlighting." - :set (lambda (sym value) - (when (fboundp 'ggtags-setup-highlight-tag-at-point) - (ggtags-setup-highlight-tag-at-point value)) - (set-default sym value)) - :type '(choice (const :tag "Disable" nil) 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.") - -(defconst ggtags-bug-url "https://github.com/leoliu/ggtags/issues") - -(defvar ggtags-global-last-buffer nil) - -(defvar ggtags-global-continuation nil) - -(defvar ggtags-current-tag-name nil) - -(defvar ggtags-highlight-tag-overlay nil) - -(defvar ggtags-highlight-tag-timer nil) - -(defmacro ggtags-with-temp-message (message &rest body) - (declare (debug t) (indent 1)) - (let ((init-time (make-symbol "-init-time-")) - (tmp-msg (make-symbol "-tmp-msg-"))) - `(let ((,init-time (float-time)) - (,tmp-msg ,message)) - (with-temp-message ,tmp-msg - (prog1 (progn ,@body) - (message "%sdone (%.2fs)" ,(or tmp-msg "") - (- (float-time) ,init-time))))))) - -(defmacro ggtags-delay-finish-functions (&rest body) - "Delay running `compilation-finish-functions' until after BODY." - (declare (indent 0) (debug t)) - (let ((saved (make-symbol "-saved-")) - (exit-args (make-symbol "-exit-args-"))) - `(let ((,saved compilation-finish-functions) - ,exit-args) - (setq-local compilation-finish-functions nil) - (add-hook 'compilation-finish-functions - (lambda (&rest args) (setq ,exit-args args)) - nil t) - (unwind-protect (progn ,@body) - (setq-local compilation-finish-functions ,saved) - (and ,exit-args (apply #'run-hook-with-args - 'compilation-finish-functions ,exit-args)))))) - -(defmacro ggtags-ensure-global-buffer (&rest body) - (declare (debug t) (indent 0)) - `(progn - (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 ggtags-global-last-buffer ,@body))) - -(defun ggtags-list-of-string-p (xs) - "Return non-nil if XS is a list of strings." - (cl-every #'stringp xs)) - -(defun ggtags-ensure-localname (file) - (and file (or (file-remote-p file 'localname) file))) - -(defun ggtags-echo (format-string &rest args) - "Print formatted text to echo area." - (let (message-log-max) (apply #'message format-string args))) - -(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-kill-window () - "Quit selected window and kill its buffer." - (interactive) - (quit-window t)) - -(defun ggtags-program-path (name) - (if ggtags-executable-directory - (expand-file-name name ggtags-executable-directory) - name)) - -(defun ggtags-process-succeed-p (program &rest args) - "Return non-nil if successfully running PROGRAM with ARGS." - (let ((program (ggtags-program-path program))) - (condition-case err - (zerop (apply #'process-file program nil nil nil args)) - (error (message "`%s' failed: %s" program (error-message-string err)) - nil)))) - -(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\r") - (buffer-substring-no-properties (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-no-properties 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 tag-size has-refs has-path-style has-color dirty-p mtime timestamp) - -(defun ggtags-make-project (root) - (cl-check-type root string) - (let* ((default-directory (file-name-as-directory root)) - ;; NOTE: use of GTAGSDBPATH is not recommended. -- GLOBAL(1) - ;; ROOT and DB can be different directories due to GTAGSDBPATH. - (dbdir (concat (file-remote-p root) - (ggtags-process-string "global" "-p")))) - (pcase (nthcdr 5 (file-attributes (expand-file-name "GTAGS" dbdir))) - (`(,mtime ,_ ,tag-size . ,_) - (let* ((rtags-size (nth 7 (file-attributes (expand-file-name "GRTAGS" dbdir)))) - (has-refs - (when rtags-size - (and (or (> rtags-size (* 32 1024)) - (with-demoted-errors "ggtags-make-project: %S" - (not (equal "" (ggtags-process-string "global" "-crs"))))) - 'has-refs))) - ;; http://thread.gmane.org/gmane.comp.gnu.global.bugs/1518 - (has-path-style - (and (ggtags-process-succeed-p "global" "--path-style" "shorter" "--help") - 'has-path-style)) - ;; http://thread.gmane.org/gmane.comp.gnu.global.bugs/1542 - (has-color (and (ggtags-process-succeed-p "global" "--color" "--help") - 'has-color))) - (puthash default-directory - (ggtags-project--make :root default-directory - :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-last-default-directory nil) -(defvar-local ggtags-project-root 'unset - "Internal variable for project root directory.") - -;;;###autoload -(defun ggtags-find-project () - ;; See https://github.com/leoliu/ggtags/issues/42 - ;; - ;; It is unsafe to cache `ggtags-project-root' in non-file buffers - ;; whose `default-directory' can often change. - (unless (equal ggtags-last-default-directory default-directory) - (kill-local-variable 'ggtags-project-root)) - (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-last-default-directory default-directory) - (setq ggtags-project-root - (or (ignore-errors - (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. - (let ((dir (locate-dominating-file - default-directory - (lambda (dir) (file-regular-p (expand-file-name "GTAGS" dir)))))) - ;; `file-truename' may strip the trailing '/' on - ;; remote hosts, see http://debbugs.gnu.org/16851 - (and 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) - (progn (call-interactively #'ggtags-create-tags) - ;; Need checking because `ggtags-create-tags' can create - ;; tags in any directory. - (ggtags-check-project)))) - -(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 ?= ??)) - (?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 (&optional project) - "Visit the root directory of (current) PROJECT in dired. -When called with a prefix \\[universal-argument], choose from past projects." - (interactive (list (and current-prefix-arg - (completing-read "Project: " ggtags-projects)))) - (dired (cl-typecase project - (string project) - (ggtags-project (ggtags-project-root project)) - (t (ggtags-ensure-project) (ggtags-current-project-root))))) - -(defmacro ggtags-with-current-project (&rest body) - "Eval BODY in current project's `process-environment'." - (declare (debug t) (indent 0)) - (let ((gtagsroot (make-symbol "-gtagsroot-")) - (root (make-symbol "-ggtags-project-root-"))) - `(let* ((,root ggtags-project-root) - (,gtagsroot (when (ggtags-find-project) - (ggtags-ensure-localname - (directory-file-name (ggtags-current-project-root))))) - (process-environment - (append (let ((process-environment (copy-sequence 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"))))) - (unwind-protect (save-current-buffer ,@body) - (setq ggtags-project-root ,root))))) - -(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-project-relative-file (file) - "Get file name relative to current project root." - (ggtags-check-project) - (if (file-name-absolute-p file) - (file-relative-name file (if (string-prefix-p (ggtags-current-project-root) - file) - (ggtags-current-project-root) - (locate-dominating-file file "GTAGS"))) - file)) - -(defun ggtags-project-file-p (file) - "Return non-nil if FILE is part of current project." - (when (ggtags-find-project) - (with-temp-buffer - (ggtags-with-current-project - ;; NOTE: `process-file' requires all files in ARGS be relative - ;; to `default-directory'; see its doc string for details. - (let ((default-directory (ggtags-current-project-root))) - (process-file (ggtags-program-path "global") nil t nil - "-vP" (concat "^" (ggtags-project-relative-file file) "$")))) - (goto-char (point-min)) - (not (re-search-forward "^file not found" nil t))))) - -(defun ggtags-invalidate-buffer-project-root (root) - (mapc (lambda (buf) - (with-current-buffer buf - (and buffer-file-truename - (string-prefix-p root buffer-file-truename) - (kill-local-variable 'ggtags-project-root)))) - (buffer-list))) - -(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 (copy-sequence process-environment))) - (when (zerop (length root)) (error "No root directory provided")) - (setenv "GTAGSROOT" (ggtags-ensure-localname - (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))))) - (unless (or conf (getenv "GTAGSLABEL") - (not (yes-or-no-p "Use `ctags' backend? "))) - (setenv "GTAGSLABEL" "ctags")) - (ggtags-with-temp-message "`gtags' in progress..." - (let ((default-directory (file-name-as-directory root)) - (args (append (cl-remove-if - #'null - (list (and ggtags-use-idutils "--idutils") - (and ggtags-use-sqlite3 - (ggtags-process-succeed-p "gtags" "--sqlite3" "--help") - "--sqlite3") - (and conf "--gtagsconf") - (and conf (ggtags-ensure-localname conf)))) - ggtags-extra-args))) - (condition-case err - (apply #'ggtags-process-string "gtags" args) - (error (if (and ggtags-use-idutils - (stringp (cadr err)) - (string-match-p "mkid not found" (cadr err))) - ;; Retry without mkid - (apply #'ggtags-process-string - "gtags" (cl-remove "--idutils" args)) - (signal (car err) (cdr err))))))))) - (ggtags-invalidate-buffer-project-root (file-truename root)) - (message "GTAGS generated in `%s'" root) - root)) - -(defun ggtags-explain-tags () - "Explain how each file is indexed in current project." - (interactive (ignore (ggtags-check-project) - (or (ggtags-process-succeed-p "gtags" "--explain" "--help") - (user-error "Global 6.4+ required")))) - (ggtags-check-project) - (ggtags-with-current-project - (let ((default-directory (ggtags-current-project-root))) - (compilation-start (concat (ggtags-program-path "gtags") " --explain"))))) - -(defun ggtags-update-tags (&optional force) - "Update GNU Global tag database. -Do nothing if GTAGS exceeds the oversize limit unless FORCE. - -When called interactively on large (per `ggtags-oversize-limit') -projects, the update process runs in the background without -blocking emacs." - (interactive (progn - (ggtags-check-project) - ;; Mark project info expired. - (setf (ggtags-project-timestamp (ggtags-find-project)) -1) - (list 'interactive))) - (cond ((and (eq force 'interactive) (ggtags-project-oversize-p)) - (ggtags-with-current-project - (with-display-buffer-no-window - (with-current-buffer (compilation-start "global -u") - ;; A hack to fool compilation mode to display `global - ;; -u finished' on finish. - (setq mode-name "global -u") - (add-hook 'compilation-finish-functions - #'ggtags-update-tags-finish nil t))))) - ((or force (and (ggtags-find-project) - (not (ggtags-project-oversize-p)) - (ggtags-project-dirty-p (ggtags-find-project)))) - (ggtags-with-current-project - (ggtags-with-temp-message "`global -u' in progress..." - (ggtags-process-string "global" "-u") - (ggtags-update-tags-finish)))))) - -(defun ggtags-update-tags-finish (&optional buf how) - (if (and how buf (string-prefix-p "exited abnormally" how)) - (display-buffer buf) - (setf (ggtags-project-dirty-p (ggtags-find-project)) nil) - (setf (ggtags-project-mtime (ggtags-find-project)) (float-time)))) - -(defun ggtags-update-tags-single (file &optional nowait) - ;; NOTE: NOWAIT is ignored if file is remote file; see - ;; `tramp-sh-handle-process-file'. - (cl-check-type file string) - (let ((nowait (unless (file-remote-p file) nowait))) - (ggtags-with-current-project - ;; See comment in `ggtags-project-file-p'. - (let ((default-directory (ggtags-current-project-root))) - (process-file (ggtags-program-path "global") nil (and nowait 0) nil - "--single-update" (ggtags-project-relative-file file)))))) - -(defun ggtags-delete-tags () - "Delete file GTAGS, GRTAGS, GPATH, ID etc. 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))))))) - -(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 - (cond (confirm - (ggtags-update-tags) - (let ((completing-read-function - (or ggtags-completing-read-function - completing-read-function))) - (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-sort-by-nearness-p (&optional start-location) - (and ggtags-sort-by-nearness - (ggtags-process-succeed-p "global" "--nearness=." "--help") - (concat "--nearness=" - (or start-location buffer-file-name default-directory)))) - -(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 nil) ;-d not supported by Global 5.7.1 - (`reference "--reference") - (`symbol "--symbol") - (`path "--path") - (`grep "--grep") - (`idutils "--idutils"))) - args))) - (mapconcat #'identity (delq nil xs) " "))) - -;; Can be three values: nil, t and a marker; t means start marker has -;; been saved in the tag ring. -(defvar ggtags-global-start-marker nil) -(defvar ggtags-global-start-file nil) -(defvar ggtags-tag-ring-index nil) -(defvar ggtags-global-search-history nil) - -(defvar ggtags-auto-jump-to-match-target nil) - -(defvar-local ggtags-global-exit-info nil) ; (EXIT-STATUS COUNT DB) - -(defun ggtags-global-save-start-marker () - (when (markerp ggtags-global-start-marker) - (setq ggtags-tag-ring-index nil) - (xref-push-marker-stack 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) - (env ggtags-process-environment)) - (unless (and (markerp ggtags-global-start-marker) - (marker-position ggtags-global-start-marker)) - (setq ggtags-global-start-marker (point-marker))) - ;; Record the file name for `ggtags-navigation-start-file'. - (setq ggtags-global-start-file buffer-file-name) - (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) - (ggtags-update-tags) - (ggtags-with-current-project - (with-current-buffer (with-display-buffer-no-window - (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-find-tag (cmd &rest args) - (ggtags-check-project) - (let ((nearness (ggtags-sort-by-nearness-p - (ggtags-project-relative-file - (or buffer-file-name default-directory))))) - (ggtags-global-start - (apply #'ggtags-global-build-command cmd nearness args)))) - -(defun ggtags-include-file () - "Calculate the include file based on `ggtags-include-pattern'." - (pcase ggtags-include-pattern - (`nil nil) - ((pred functionp) - (funcall ggtags-include-pattern)) - (`(,re . ,sub) - (save-excursion - (beginning-of-line) - (and (looking-at re) (match-string sub)))) - (_ (warn "Invalid value for `ggtags-include-pattern': %s" - ggtags-include-pattern) - nil))) - -;;;###autoload -(defun ggtags-find-tag-dwim (name &optional what) - "Find NAME by context. -If point is at a definition tag, find references, and vice versa. -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-file)))) - (ggtags-ensure-project) - (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) - (not (ggtags-project-has-refs (ggtags-find-project))) - (not (ggtags-project-file-p buffer-file-name))) - (ggtags-find-definition name)) - (t (ggtags-find-tag - (format "--from-here=%d:%s" - (line-number-at-pos) - ;; Note `ggtags-find-tag' binds `default-directory' to - ;; project root. - (shell-quote-argument - (ggtags-project-relative-file buffer-file-name))) - "--" (shell-quote-argument name))))) - -(defun ggtags-find-tag-mouse (event) - (interactive "e") - (with-selected-window (posn-window (event-start event)) - (save-excursion - (goto-char (posn-point (event-start event))) - (call-interactively #'ggtags-find-tag-dwim)))) - -;; Another option for `M-.'. -(defun ggtags-find-definition (name) - (interactive (list (ggtags-read-tag 'definition current-prefix-arg))) - (ggtags-find-tag 'definition "--" (shell-quote-argument name))) - -(defun ggtags-setup-libpath-search (type name) - (pcase (and ggtags-global-search-libpath-for-reference - (ggtags-get-libpath)) - ((and libs (guard libs)) - (cl-labels ((cont (buf how) - (pcase ggtags-global-exit-info - (`(0 0 ,_) - (with-temp-buffer - (setq default-directory - (file-name-as-directory (pop libs))) - (and libs (setq ggtags-global-continuation #'cont)) - (if (ggtags-find-project) - (ggtags-find-tag type (shell-quote-argument name)) - (cont buf how)))) - (_ (ggtags-global-handle-exit buf how))))) - (setq ggtags-global-continuation #'cont))))) - -(defun ggtags-find-reference (name) - (interactive (list (ggtags-read-tag 'reference current-prefix-arg))) - (ggtags-setup-libpath-search 'reference name) - (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-setup-libpath-search 'symbol name) - (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)) - (let ((ggtags-global-output-format 'path)) - (ggtags-find-tag 'path (and invert-match "--invert-match") - "--" (ggtags-quote-pattern pattern)))) - -;; Note: Coloured output requested in http://goo.gl/Y9IcX and appeared -;; in global v6.2.12. -(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-foreach-file (fn) - "Invoke FN with each file found. -FN is invoked while *ggtags-global* buffer is current." - (ggtags-ensure-global-buffer - (save-excursion - (goto-char (point-min)) - (while (with-demoted-errors "compilation-next-error: %S" - (compilation-next-error 1 'file) - t) - (funcall fn (caar - (compilation--loc->file-struct - (compilation--message->loc - (get-text-property (point) 'compilation-message))))))))) - -(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 - (ggtags-with-temp-message "Waiting for Grep to finish..." - (while (get-buffer-process (current-buffer)) - (sit-for 0.2))) - (ggtags-foreach-file - (lambda (file) (push (expand-file-name file) files)))) - (ggtags-navigation-mode -1) - (nreverse files)))) - (tags-query-replace from to delimited file-form))) - -(defun ggtags-global-normalise-command (cmd) - (if (string-match - (concat (regexp-quote (ggtags-global-build-command nil)) "\\s-*") - cmd) - (substring-no-properties cmd (match-end 0)) - cmd)) - -(defun ggtags-global-search-id (cmd directory) - (sha1 (concat directory (make-string 1 0) - (ggtags-global-normalise-command cmd)))) - -(defun ggtags-global-current-search () - ;; CMD DIR ENV LINE TEXT - (ggtags-ensure-global-buffer - (list (ggtags-global-normalise-command (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 (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 - (ggtags-global-build-command 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-view-search-history-last nil) - -(defvar ggtags-view-search-history-mode-map - (let ((m (make-sparse-keymap))) - (define-key m "p" 'ggtags-view-search-history-prev) - (define-key m "\M-p" 'ggtags-view-search-history-prev) - (define-key m "n" 'ggtags-view-search-history-next) - (define-key m "\M-n" 'ggtags-view-search-history-next) - (define-key m "\C-k" 'ggtags-view-search-history-kill) - (define-key m [remap yank] (lambda (&optional arg) (interactive "P") (yank arg))) - (define-key m "\C-c\C-c" 'ggtags-view-search-history-update) - (define-key m "r" 'ggtags-save-to-register) - (define-key m "\r" 'ggtags-view-search-history-action) - (define-key m "q" 'ggtags-kill-window) - m)) - -(defun ggtags-view-search-history-remember () - (setq ggtags-view-search-history-last - (pcase (ewoc-locate ggtags-global-search-ewoc) - (`nil nil) - (node (ewoc-data node))))) - -(defun ggtags-view-search-history-next (&optional arg) - (interactive "p") - (let ((arg (or arg 1))) - (prog1 (funcall (if (cl-minusp arg) #'ewoc-goto-prev #'ewoc-goto-next) - ggtags-global-search-ewoc (abs arg)) - (ggtags-view-search-history-remember)))) - -(defun ggtags-view-search-history-prev (&optional arg) - (interactive "p") - (ggtags-view-search-history-next (- (or arg 1)))) - -(defun ggtags-view-search-history-kill (&optional append) - (interactive "P") - (let* ((node (or (ewoc-locate ggtags-global-search-ewoc) - (user-error "No node at point"))) - (next (ewoc-next ggtags-global-search-ewoc node)) - (text (filter-buffer-substring (ewoc-location node) - (if next (ewoc-location next) - (point-max))))) - (put-text-property - 0 (length text) 'yank-handler - (list (lambda (arg) - (if (not ggtags-global-search-ewoc) - (insert (car arg)) - (let* ((inhibit-read-only t) - (node (unless (looking-at-p "[ \t\n]*\\'") - (ewoc-locate ggtags-global-search-ewoc)))) - (if node - (ewoc-enter-before ggtags-global-search-ewoc - node (cadr arg)) - (ewoc-enter-last ggtags-global-search-ewoc (cadr arg))) - (setq ggtags-view-search-history-last (cadr arg))))) - (list text (ewoc-data node))) - text) - (if append (kill-append text nil) - (kill-new text)) - (let ((inhibit-read-only t)) - (ewoc-delete ggtags-global-search-ewoc node)))) - -(defun ggtags-view-search-history-update (&optional noconfirm) - "Update `ggtags-global-search-history' to current buffer." - (interactive "P") - (when (and (buffer-modified-p) - (or noconfirm - (yes-or-no-p "Modify `ggtags-global-search-history'?"))) - (setq ggtags-global-search-history - (ewoc-collect ggtags-global-search-ewoc #'identity)) - (set-buffer-modified-p nil))) - -(defun ggtags-view-search-history-action () - (interactive) - (let ((data (ewoc-data (or (ewoc-locate ggtags-global-search-ewoc) - (user-error "No search at point"))))) - (ggtags-view-search-history-remember) - (quit-window t) - (ggtags-global-rerun-search (cdr data)))) - -(defvar bookmark-make-record-function) - -(define-derived-mode ggtags-view-search-history-mode special-mode "SearchHist" - "Major mode for viewing search history." - :group 'ggtags - (setq-local ggtags-enable-navigation-keys nil) - (setq-local bookmark-make-record-function #'ggtags-make-bookmark-record) - (setq truncate-lines t) - (add-hook 'kill-buffer-hook #'ggtags-view-search-history-update nil t)) - -(defun ggtags-view-search-history-restore-last () - (when ggtags-view-search-history-last - (cl-loop for n = (ewoc-nth ggtags-global-search-ewoc 0) - then (ewoc-next ggtags-global-search-ewoc n) - while n when (eq (ewoc-data n) - ggtags-view-search-history-last) - do (progn (goto-char (ewoc-location n)) (cl-return t))))) - -(defun ggtags-view-search-history () - "Pop to a buffer to view or re-run past searches. - -\\{ggtags-view-search-history-mode-map}" - (interactive) - (or ggtags-global-search-history (user-error "No search history")) - (let ((split-window-preferred-function ggtags-split-window-function) - (inhibit-read-only t)) - (pop-to-buffer "*Ggtags Search History*") - (erase-buffer) - (ggtags-view-search-history-mode) - (cl-labels ((prop (s) - (propertize s 'face 'minibuffer-prompt)) - (prop-tag (cmd) - (with-temp-buffer - (insert cmd) - (forward-sexp -1) - (if (eobp) - cmd - (put-text-property (point) (point-max) - 'face font-lock-constant-face) - (buffer-string)))) - (pp (data) - (pcase data - (`(,_id ,cmd ,dir ,_env ,line ,text) - (insert (prop " cmd: ") (prop-tag 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)) - (ggtags-view-search-history-restore-last) - (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 - :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 (bookmark-prop-get bmk 'ggtags-search))) - -(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) - (and (ring-empty-p xref--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 (xref-push-marker-stack) - 0)) - (ring-length xref--marker-ring))) - (let ((m (ring-ref xref--marker-ring ggtags-tag-ring-index)) - (i (- (ring-length xref--marker-ring) ggtags-tag-ring-index))) - (ggtags-echo "%d%s marker%s" i (pcase (mod i 10) - (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" 'ggtags-kill-window) - m)) - -(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 xref--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 xref--marker-ring)) - (elements (or (ring-elements xref--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-1 () - "Get the total of matches and db file used." - (save-excursion - (goto-char (point-max)) - (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)))) - -(defun ggtags-global-exit-message-function (_process-status exit-status msg) - "A function for `compilation-exit-message-function'." - (pcase (ggtags-global-exit-message-1) - (`(,count . ,db) - (setq ggtags-global-exit-info (list exit-status count db)) - ;; Clear the start marker in case of zero matches. - (and (zerop count) - (markerp ggtags-global-start-marker) - (not ggtags-global-continuation) - (setq ggtags-global-start-marker nil)) - (cons (if (> exit-status 0) - msg - (format "found %d %s" count - (funcall (if (= count 1) #'car #'cadr) - (pcase db - ("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 - (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 (,(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 (,(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))) - compilation-error-regexp-alist-alist)) - -(defun ggtags-abbreviate-file (start end) - (let ((inhibit-read-only t) - (amount (if (numberp ggtags-global-abbreviate-filename) - (- (- end start) ggtags-global-abbreviate-filename) - 999)) - (advance-word (lambda () - "Return the length of the text made invisible." - (let ((wend (min end (progn (forward-word 1) (point)))) - (wbeg (max start (progn (backward-word 1) (point))))) - (goto-char wend) - (if (<= (- wend wbeg) 1) - 0 - (put-text-property (1+ wbeg) wend 'invisible t) - (1- (- wend wbeg))))))) - (goto-char start) - (while (and (> amount 0) (> end (point))) - (cl-decf amount (funcall advance-word))))) - -(defun ggtags-abbreviate-files (start end) - (goto-char start) - (let* ((error-re (cdr (assq (car compilation-error-regexp-alist) - ggtags-global-error-regexp-alist-alist))) - (sub (cadr error-re))) - (when (and ggtags-global-abbreviate-filename error-re) - (while (re-search-forward (car error-re) end t) - (when (and (or (not (numberp ggtags-global-abbreviate-filename)) - (> (length (match-string sub)) - ggtags-global-abbreviate-filename)) - ;; Ignore bogus file lines such as: - ;; Global found 2 matches at Thu Jan 31 13:45:19 - (get-text-property (match-beginning sub) 'compilation-message)) - (ggtags-abbreviate-file (match-beginning sub) (match-end sub))))))) - -(defvar-local ggtags-global-output-lines 0) - -(defun ggtags-global--display-buffer (&optional buffer desired-point) - (pcase (let ((buffer (or buffer (current-buffer))) - (split-window-preferred-function ggtags-split-window-function)) - (and (not (get-buffer-window buffer)) - (display-buffer buffer '(nil (allow-no-window . t))))) - ((and (pred windowp) w) - (with-selected-window w - (compilation-set-window-height w) - (and desired-point (goto-char desired-point)))))) - -(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))) - ;; If the number of output lines is small - ;; `ggtags-global-handle-exit' takes care of displaying the buffer. - (when (and (> ggtags-global-output-lines 30) ggtags-navigation-mode) - (ggtags-global--display-buffer nil (or compilation-current-error (point-min)))) - (when (and (eq ggtags-auto-jump-to-match 'history) - (numberp ggtags-auto-jump-to-match-target) - (not compilation-current-error) - ;; `ggtags-global-output-lines' is imprecise but use it - ;; as first approximation. - (> (+ 10 ggtags-global-output-lines) ggtags-auto-jump-to-match-target) - (> (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) - (ggtags-delay-finish-functions - (with-display-buffer-no-window - (condition-case nil - (let ((compilation-auto-jump-to-first-error t)) - (compilation-auto-jump (current-buffer) (point))) - (error (message "\ -ggtags: history match invalid, jump to first match instead") - (first-error))))) - ;; `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. - (run-with-idle-timer - 0 nil - (lambda (buf pt) - (and (buffer-live-p buf) - (with-current-buffer buf (goto-char pt)))) - (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) - (ggtags-echo "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 - (ggtags-global-continuation - (let ((cont (prog1 ggtags-global-continuation - (setq ggtags-global-continuation nil)))) - (funcall cont buf how))) - ((string-prefix-p "exited abnormally" how) - ;; If exit abnormally display the buffer for inspection. - (ggtags-global--display-buffer) - (when (save-excursion - (goto-char (point-max)) - (re-search-backward - (eval-when-compile - (format "^global: %s not found.$" - (regexp-opt '("GTAGS" "GRTAGS" "GSYMS" "GPATH")))) - nil t)) - (ggtags-echo "WARNING: Global tag files missing in `%s'" - ggtags-project-root) - (remhash ggtags-project-root ggtags-projects))) - (ggtags-auto-jump-to-match - (if (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))) - ;; There are multiple matches so pop up the buffer. - (and ggtags-navigation-mode (ggtags-global--display-buffer)) - ;; Manually run the `compilation-auto-jump' timer. Hackish but - ;; everything else seems unreliable. See: - ;; - ;; - http://debbugs.gnu.org/13829 - ;; - http://debbugs.gnu.org/23987 - ;; - https://github.com/leoliu/ggtags/issues/89 - ;; - (pcase (cl-find 'compilation-auto-jump timer-list :key #'timer--function) - (`nil ) - (timer (timer-event-handler timer))) - (ggtags-navigation-mode -1) - (ggtags-navigation-mode-cleanup buf t))))) - -(defvar ggtags-global-mode-font-lock-keywords - '(("^Global \\(exited abnormally\\|interrupt\\|killed\\|terminated\\)\\(?:.*with code \\([0-9]+\\)\\)?.*" - (1 'compilation-error) - (2 'compilation-error nil t)) - ("^Global found \\([0-9]+\\)" (1 compilation-info-face)))) - -(define-compilation-mode ggtags-global-mode "Global" - "A mode for showing outputs from gnu global." - ;; Note: Place `ggtags-global-output-format' as first element for - ;; `ggtags-abbreviate-files'. - (setq-local compilation-error-regexp-alist (list ggtags-global-output-format)) - (when (markerp ggtags-global-start-marker) - (setq ggtags-project-root - (buffer-local-value 'ggtags-project-root - (marker-buffer ggtags-global-start-marker)))) - (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-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-start-file) - (define-key map "\M->" 'ggtags-navigation-last-error) - (define-key map "\M-<" 'first-error) - ;; Note: shadows `isearch-forward-regexp' but it can still be - ;; invoked with `C-u C-s'. - (define-key map "\C-\M-s" 'ggtags-navigation-isearch-forward) - ;; Add an alternative binding because C-M-s is reported not - ;; working on some systems. - (define-key map "\M-ss" '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) - (define-key map [remap xref-pop-marker-stack] 'ggtags-navigation-mode-abort) - 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" 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 ((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 kill) - (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-windows-on (current-buffer))) - (and kill (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 () - "Abort navigation and return to where the search was started." - (interactive) - (ggtags-navigation-mode -1) - (ggtags-navigation-mode-cleanup nil t) - ;; 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) - (xref-pop-marker-stack))) - -(defun ggtags-navigation-next-file (n) - (interactive "p") - (ggtags-ensure-global-buffer - (compilation-next-file n) - (compile-goto-error))) - -(defun ggtags-navigation-previous-file (n) - (interactive "p") - (ggtags-navigation-next-file (- n))) - -(defun ggtags-navigation-start-file () - "Move to the file where navigation session starts." - (interactive) - (let ((start-file (or ggtags-global-start-file - (user-error "Cannot decide start file")))) - (ggtags-ensure-global-buffer - (pcase (cl-block nil - (ggtags-foreach-file - (lambda (file) - (when (file-equal-p file start-file) - (cl-return (point)))))) - (`nil (user-error "No matches for `%s'" start-file)) - (n (goto-char n) (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))) - -(put 'ggtags-navigation-mode-lighter 'risky-local-variable t) - -(defvar ggtags-navigation-mode-lighter - '(" GG[" - (:eval - (if (not (buffer-live-p ggtags-global-last-buffer)) - '(:propertize "??" face error help-echo "No Global buffer") - (with-current-buffer ggtags-global-last-buffer - (pcase (or ggtags-global-exit-info '(0 0 "")) - (`(,exit ,count ,db) - `((:propertize ,(pcase db - (`"GTAGS" "D") - (`"GRTAGS" "R") - (`"GSYMS" "S") - (`"GPATH" "F") - (`"ID" "I")) - face success) - (:propertize - ,(pcase (get-text-property (line-beginning-position) - 'compilation-message) - (`nil "?") - ;; Assume the first match appears at line 5 - (_ (number-to-string (- (line-number-at-pos) 4)))) - face success) - "/" - (:propertize ,(number-to-string count) face success) - ,(unless (zerop exit) - `(":" (:propertize ,(number-to-string exit) face error))))))))) - "]") - "Ligher for `ggtags-navigation-mode'; set to nil to disable it.") - -(define-minor-mode ggtags-navigation-mode nil - ;; If `ggtags-enable-navigation-keys' is set to nil only display the - ;; lighter in `ggtags-mode' buffers. - ;; See https://github.com/leoliu/ggtags/issues/124 - :lighter (:eval (and (or ggtags-enable-navigation-keys - ggtags-mode) - ggtags-navigation-mode-lighter)) - :global t - (if ggtags-navigation-mode - (progn - ;; 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)) - (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-enable-navigation-keys nil)) - -(defun ggtags-kill-file-buffers (&optional interactive) - "Kill all buffers visiting files in current project." - (interactive "p") - (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 (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 () - (when (ggtags-find-project) - (ggtags-project-update-mtime-maybe) - (and buffer-file-name ggtags-update-on-save - (ggtags-update-tags-single buffer-file-name 'nowait)))) - -(defun ggtags-global-output (buffer cmds callback &optional cutoff sync) - "Asynchronously pipe the output of running CMDS to BUFFER. -When finished invoke CALLBACK in BUFFER with process exit status. -If SYNC is non-nil, synchronously run CMDS and call CALLBACK." - (or buffer (error "Output buffer required")) - (when (get-buffer-process (get-buffer buffer)) - ;; Notice running multiple processes in the same buffer so that we - ;; can fix the caller. See for example `ggtags-eldoc-function'. - (message "Warning: detected %S already running in %S; interrupting..." - (get-buffer-process buffer) buffer) - (interrupt-process (get-buffer-process buffer))) - (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) - (cl-incf (process-get proc :nlines) - (count-lines (process-mark proc) (point))) - (set-marker (process-mark proc) (point)) - (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) - (unwind-protect - (funcall callback (process-exit-status proc)) - (process-put proc :callback-done t))))))) - (set-process-query-on-exit-flag proc nil) - (and cutoff (set-process-filter proc filter)) - (set-process-sentinel proc sentinel) - (process-put proc :callback-done nil) - (process-put proc :nlines 0) - (if sync (while (not (process-get proc :callback-done)) - (accept-process-output proc 1)) - proc))) - -(cl-defun ggtags-fontify-code (code &optional (mode major-mode)) - (cl-check-type mode function) - (if (stringp code) - (with-temp-buffer - (insert code) - (funcall mode) - (font-lock-ensure) - (buffer-string)) - code)) - -(defun ggtags-get-definition-default (defs) - (and (caar defs) - (concat (ggtags-fontify-code (caar defs)) - (and (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*")) - ;; `.' works here because ggtags-global-output doesn't set - ;; default-directory to project root. - (args (delq nil (list (ggtags-sort-by-nearness-p ".") - "--result=grep" "--path-style=absolute" name))) - ;; Need these bindings so that let-binding - ;; `ggtags-print-definition-function' can work see - ;; `ggtags-eldoc-function'. - (get-fn ggtags-get-definition-function) - (print-fn ggtags-print-definition-function) - (show (lambda (_status) - (goto-char (point-min)) - (let ((defs (cl-loop while (re-search-forward re nil t) - collect (list (buffer-substring-no-properties - (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 print-fn (funcall get-fn defs))))))) - (ggtags-with-current-project - (ggtags-global-output buffer (cons (ggtags-program-path "global") args) - 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-tags) - (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-view-search-history) - (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 [eldoc-mode] - '(menu-item "Toggle eldoc mode" eldoc-mode :button (:toggle . eldoc-mode))) - (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 tags" ggtags-delete-tags - :enable (ggtags-find-project) - :help "Delete file GTAGS, GRTAGS, GPATH, ID etc.")) - (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" xref-pop-marker-stack - :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 [previous-error] - '(menu-item "Previous match" previous-error)) - (define-key menu [next-error] - '(menu-item "Next match" next-error)) - (define-key menu [rerun-search] - '(menu-item "View past searches" ggtags-view-search-history)) - (define-key menu [save-to-register] - '(menu-item "Save search to register" ggtags-save-to-register)) - (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 - :help "Find references without definition")) - (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)) - ;; TODO: bind `find-tag-continue' to `M-*' after dropping support - ;; for emacs < 25. - (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 [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")) - (ggtags-setup-highlight-tag-at-point ggtags-highlight-tag) - (if ggtags-mode - (progn - (add-hook 'after-save-hook 'ggtags-after-save-function nil t) - (add-hook 'xref-backend-functions 'ggtags--xref-backend nil t) - ;; Append to serve as a fallback method. - (add-hook 'completion-at-point-functions - #'ggtags-completion-at-point t t) - ;; Work around http://debbugs.gnu.org/19324 - (or eldoc-documentation-function - (setq-local eldoc-documentation-function #'ignore)) - (add-function :after-until (local 'eldoc-documentation-function) - #'ggtags-eldoc-function '((name . ggtags-eldoc-function) - (depth . -100))) - (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) - (remove-hook 'xref-backend-functions 'ggtags--xref-backend t) - (remove-hook 'completion-at-point-functions #'ggtags-completion-at-point t) - (remove-function (local 'eldoc-documentation-function) 'ggtags-eldoc-function) - (setq mode-line-buffer-identification - (delq 'ggtags-mode-line-project-name mode-line-buffer-identification)) - (ggtags-cancel-highlight-tag-at-point 'keep-timer))) - -(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-setup-highlight-tag-at-point (flag) - (cond ((null flag) (ggtags-cancel-highlight-tag-at-point)) - ((not (timerp ggtags-highlight-tag-timer)) - (setq ggtags-highlight-tag-timer - (run-with-idle-timer flag t #'ggtags-highlight-tag-at-point))) - (t (timer-set-idle-time ggtags-highlight-tag-timer flag t)))) - -(defun ggtags-cancel-highlight-tag-at-point (&optional keep-timer) - (when (and (not keep-timer) - (timerp ggtags-highlight-tag-timer)) - (cancel-timer ggtags-highlight-tag-timer) - (setq ggtags-highlight-tag-timer nil)) - (when ggtags-highlight-tag-overlay - (delete-overlay ggtags-highlight-tag-overlay) - (setq ggtags-highlight-tag-overlay nil))) - -(defun ggtags-highlight-tag-at-point () - (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 - ((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-no-properties - (car bounds) (cdr bounds)) - ggtags-completion-table))) - (move-overlay o (car bounds) (cdr bounds) (current-buffer)) - (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)))))) - -;;; eldoc - -(defvar-local ggtags-eldoc-cache nil) - -(declare-function eldoc-message "eldoc") -(defun ggtags-eldoc-function () - "A function suitable for `eldoc-documentation-function' (which see)." - (pcase (ggtags-tag-at-point) - (`nil nil) - (tag (if (equal tag (car ggtags-eldoc-cache)) - (cadr ggtags-eldoc-cache) - (and ggtags-project-root (ggtags-find-project) - (let* ((ggtags-print-definition-function - (lambda (s) - (setq ggtags-eldoc-cache (list tag s)) - (eldoc-message s)))) - ;; Prevent multiple runs of ggtags-show-definition - ;; for the same tag. - (setq ggtags-eldoc-cache (list tag)) - (condition-case err - (ggtags-show-definition tag) - (file-error - (remove-function (local 'eldoc-documentation-function) - 'ggtags-eldoc-function) - (message "\ -Function `ggtags-eldoc-function' disabled for eldoc in current buffer: %S" err))) - nil)))))) - -;;; imenu - -(defun ggtags-goto-imenu-index (name line &rest _args) - (ggtags-forward-to-line line) - (ggtags-move-to-tag name)) - -;;;###autoload -(defun ggtags-build-imenu-index () - "A function suitable for `imenu-create-index-function'." - (let ((file (and buffer-file-name (file-relative-name buffer-file-name)))) - (and file (with-temp-buffer - (when (with-demoted-errors "ggtags-build-imenu-index: %S" - (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 ggtags-try-complete-tag (old) - "A function suitable for `hippie-expand-try-functions-list'." - (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)) - -;;; Xref - -(defconst ggtags--xref-limit 1000) - -(cl-defstruct (ggtags-xref-location - (:constructor ggtags-make-xref-location (file line column project-root))) - file line column project-root) - -(cl-defmethod xref-location-group ((l ggtags-xref-location)) - (file-relative-name (ggtags-xref-location-file l) (ggtags-xref-location-project-root l))) - -(cl-defmethod xref-location-marker ((l ggtags-xref-location)) - (let ((buffer (find-file-noselect (ggtags-xref-location-file l)))) - (with-current-buffer buffer - (save-excursion - (goto-char (point-min)) - (forward-line (1- (ggtags-xref-location-line l))) - (move-to-column (1- (ggtags-xref-location-column l))) - (point-marker))))) - -(cl-defmethod xref-location-line ((l ggtags-xref-location)) - (ggtags-xref-location-line l)) - -(defun ggtags--xref-backend () - (and (ggtags-find-project) - (let ((tag (ggtags-tag-at-point))) - ;; Try to use this backend if there is no tag at - ;; point, since we may still want to when asking - ;; the user for a tag. - (or (null tag) - (test-completion tag ggtags-completion-table))) - 'ggtags)) - -(cl-defmethod xref-backend-identifier-at-point ((_backend (eql ggtags))) - (ggtags-tag-at-point)) - -(cl-defmethod xref-backend-identifier-completion-table ((_backend (eql ggtags))) - ggtags-completion-table) - -(defun ggtags--xref-collect-tags (tag root colored) - "Collect xrefs for TAG from Global output in the `current-buffer'. -Return the list of xrefs for TAG. Global output is assumed to -have grep format. - -ROOT is the project root directory to associate with the xrefs. - -If COLORED is non-nil, convert ANSI color codes to font lock text -properties in the summary text of each xref." - (cl-loop - with re = (cadr (assq 'grep ggtags-global-error-regexp-alist-alist)) - while (re-search-forward re nil t) - for summary = (buffer-substring (1+ (match-end 2)) (line-end-position)) - for file = (expand-file-name (match-string 1)) - for line = (string-to-number (match-string 2)) - for column = (string-match-p tag summary) - if colored do (setq summary (ansi-color-apply summary)) end - ;; Sometimes there are false positives, depending on the - ;; parser used so only collect lines that actually - ;; contain TAG. - and when column - collect (xref-make - summary - (ggtags-make-xref-location - file - line - column - root)))) - -(defun ggtags--xref-find-tags (tag cmd) - "Find xrefs of TAG using Global CMD. -CMD has the same meaning as in `ggtags-global-build-command'. -Return the list of xrefs for TAG." - (let* ((ggtags-global-output-format 'grep) - (project (ggtags-find-project)) - (xrefs nil) - (collect - (lambda (_status) - (goto-char (point-min)) - (setq xrefs (ggtags--xref-collect-tags - tag - (ggtags-project-root project) - (and ggtags-global-use-color - (ggtags-project-has-color project)))) - (kill-buffer (current-buffer))))) - (ggtags-with-current-project - (ggtags-global-output - (get-buffer-create " *ggtags-xref*") - (append - (split-string (ggtags-global-build-command cmd)) - (list "--" (shell-quote-argument tag))) - collect ggtags--xref-limit 'sync) - xrefs))) - -(cl-defmethod xref-backend-definitions ((_backend (eql ggtags)) tag) - (ggtags--xref-find-tags tag 'definition)) - -(cl-defmethod xref-backend-references ((_backend (eql ggtags)) tag) - (ggtags--xref-find-tags tag 'reference)) - -(cl-defmethod xref-backend-apropos ((_backend (eql ggtags)) tag) - (ggtags--xref-find-tags tag 'grep)) - -(defun ggtags-reload (&optional force) - (interactive "P") - (unload-feature 'ggtags force) - (require 'ggtags)) - -(provide 'ggtags) -;;; ggtags.el ends here diff --git a/elpa/ggtags-20230602.133/ggtags-autoloads.el b/elpa/ggtags-20230602.133/ggtags-autoloads.el new file mode 100644 index 00000000..17a1da0d --- /dev/null +++ b/elpa/ggtags-20230602.133/ggtags-autoloads.el @@ -0,0 +1,68 @@ +;;; ggtags-autoloads.el --- automatically extracted autoloads -*- lexical-binding: t -*- +;; +;;; Code: + +(add-to-list 'load-path (directory-file-name + (or (file-name-directory #$) (car load-path)))) + + +;;;### (autoloads nil "ggtags" "ggtags.el" (0 0 0 0)) +;;; Generated autoloads from ggtags.el + +(autoload 'ggtags-find-project "ggtags" nil nil nil) + +(autoload 'ggtags-find-tag-dwim "ggtags" "\ +Find NAME by context. +If point is at a definition tag, find references, and vice versa. +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. + +\(fn NAME &optional WHAT)" t nil) + +(autoload 'ggtags-mode "ggtags" "\ +Toggle Ggtags mode on or off. + +This is a minor mode. If called interactively, toggle the +`Ggtags mode' mode. If the prefix argument is positive, enable +the mode, and if it is zero or negative, disable the mode. + +If called from Lisp, toggle the mode if ARG is `toggle'. Enable +the mode if ARG is nil, omitted, or is a positive number. +Disable the mode if ARG is a negative number. + +To check whether the minor mode is enabled in the current buffer, +evaluate `ggtags-mode'. + +The mode's hook is called both when the mode is enabled and when +it is disabled. + +\\{ggtags-mode-map} + +\(fn &optional ARG)" t nil) + +(autoload 'ggtags-build-imenu-index "ggtags" "\ +A function suitable for `imenu-create-index-function'." nil nil) + +(autoload 'ggtags-try-complete-tag "ggtags" "\ +A function suitable for `hippie-expand-try-functions-list'. + +\(fn OLD)" nil nil) + +(register-definition-prefixes "ggtags" '("ggtags-")) + +;;;*** + +;;;### (autoloads nil nil ("ggtags-pkg.el") (0 0 0 0)) + +;;;*** + +;; Local Variables: +;; version-control: never +;; no-byte-compile: t +;; no-update-autoloads: t +;; coding: utf-8 +;; End: +;;; ggtags-autoloads.el ends here diff --git a/elpa/ggtags-20230602.133/ggtags-pkg.el b/elpa/ggtags-20230602.133/ggtags-pkg.el new file mode 100644 index 00000000..4e7d00b3 --- /dev/null +++ b/elpa/ggtags-20230602.133/ggtags-pkg.el @@ -0,0 +1,14 @@ +(define-package "ggtags" "20230602.133" "emacs frontend to GNU Global source code tagging system" + '((emacs "25")) + :commit "4e3630c30fb836872b5d8f2ae3e5d5ae003365d8" :authors + '(("Leo Liu" . "sdl.web@gmail.com")) + :maintainers + '(("Leo Liu" . "sdl.web@gmail.com")) + :maintainer + '("Leo Liu" . "sdl.web@gmail.com") + :keywords + '("tools" "convenience") + :url "https://github.com/leoliu/ggtags") +;; Local Variables: +;; no-byte-compile: t +;; End: diff --git a/elpa/ggtags-20230602.133/ggtags.el b/elpa/ggtags-20230602.133/ggtags.el new file mode 100644 index 00000000..25b0bb4d --- /dev/null +++ b/elpa/ggtags-20230602.133/ggtags.el @@ -0,0 +1,2488 @@ +;;; ggtags.el --- emacs frontend to GNU Global source code tagging system -*- lexical-binding: t; -*- + +;; Copyright (C) 2013-2019 Free Software Foundation, Inc. + +;; Author: Leo Liu +;; Version: 0.9.0 +;; Keywords: tools, convenience +;; Created: 2013-01-29 +;; URL: https://github.com/leoliu/ggtags +;; Package-Requires: ((emacs "25")) + +;; 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 +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program 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 this program. If not, see . + +;;; Commentary: + +;; A package to integrate GNU Global source code tagging system +;; (http://www.gnu.org/software/global) with Emacs. +;; +;; Usage: +;; +;; `ggtags' is similar to the standard `etags' package. These keys +;; `M-.', `M-,' and `C-M-.' should work as expected in `ggtags-mode'. +;; See the README in https://github.com/leoliu/ggtags for more +;; details. +;; +;; All commands are available from the `Ggtags' menu in `ggtags-mode'. + +;;; NEWS 0.8.13 (2018-07-25): + +;; - Don't choke on tag names start with `-'. +;; - `ggtags-show-definition' supports `ggtags-sort-by-nearness'. +;; - New variable `ggtags-extra-args'. +;; - Unbreak `ggtags-sort-by-nearness'. +;; +;; See full NEWS on https://github.com/leoliu/ggtags#news + +;;; Code: + +(eval-when-compile + (require 'url-parse)) + +(require 'cl-lib) +(require 'ewoc) +(require 'compile) +(require 'etags) + +(eval-when-compile + (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))) + + (defmacro with-display-buffer-no-window (&rest body) + (declare (debug t) (indent 0)) + ;; See http://debbugs.gnu.org/13594 + `(let ((display-buffer-overriding-action + (if ggtags-auto-jump-to-match + (list #'display-buffer-no-window) + display-buffer-overriding-action))) + ,@body))) + +(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." + :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-oversize-limit (* 10 1024 1024) + "The over size limit for the GTAGS file. +When the size of the GTAGS file is below this limit, ggtags +always maintains up-to-date tags for the whole source tree by +running `global -u'. For projects with GTAGS larger than this +limit, only files edited in Ggtags mode are updated (via `global +--single-update')." + :safe 'numberp + :type '(choice (const :tag "None" nil) + (const :tag "Always" t) + number) + :group 'ggtags) + +(defcustom ggtags-include-pattern + '("^\\s-*#\\s-*\\(?:include\\|import\\)\\s-*[\"<]\\(?:[./]*\\)?\\(.*?\\)[\">]" . 1) + "Pattern used to detect #include files. +Value can be (REGEXP . SUB) or a function with no arguments. +REGEXP should match from the beginning of line." + :type '(choice (const :tag "Disable" nil) + (cons regexp integer) + function) + :safe 'stringp + :group 'ggtags) + +;; See also: http://article.gmane.org/gmane.comp.gnu.global.bugs/1751 +(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. + +Note: GNU Global v6.2.13 has the feature of using gtags.conf at +project root. Setting this variable to nil doesn't disable this +feature." + :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 'history + "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 *ggtags-global* popup window. +If nil, use Emacs default." + :type '(choice (const :tag "Default" nil) integer) + :group 'ggtags) + +(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) + :group 'ggtags) + +(defcustom ggtags-split-window-function split-window-preferred-function + "A function to control how ggtags pops up the auxiliary window." + :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-use-sqlite3 nil + "Use sqlite3 for storage instead of Berkeley DB. +This feature requires GNU Global 6.3.3+ and is ignored if `gtags' +isn't built with sqlite3 support." + :type 'boolean + :safe 'booleanp + :group 'ggtags) + +(defcustom ggtags-extra-args nil + "Extra arguments to pass to `gtags' in `ggtags-create-tags'." + :type '(repeat string) + :safe #'ggtags-list-of-string-p + :group 'ggtags) + +(defcustom ggtags-sort-by-nearness nil + "Sort tags by nearness to current directory. +GNU Global 6.5+ required." + :type 'boolean + :safe #'booleanp + :group 'ggtags) + +(defcustom ggtags-update-on-save t + "Non-nil to update tags for current buffer on saving." + ;; It is reported that `global --single-update' can be slow in sshfs + ;; directories. See https://github.com/leoliu/ggtags/issues/85. + :safe #'booleanp + :type 'boolean + :group 'ggtags) + +(defcustom ggtags-global-output-format 'grep + "Global output format: path, ctags, ctags-x, grep or cscope." + :type '(choice (const path) + (const ctags) + (const ctags-x) + (const grep) + (const cscope)) + :group 'ggtags) + +(defcustom ggtags-global-use-color t + "Non-nil to use color in output if supported by Global. +Note: processing colored output takes noticeable time +particularly when the output is large." + :type 'boolean + :safe 'booleanp + :group 'ggtags) + +(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) + +;; See also https://github.com/leoliu/ggtags/issues/52 +(defcustom ggtags-global-search-libpath-for-reference t + "If non-nil global will search GTAGSLIBPATH for references. +Search is only continued in GTAGSLIBPATH if it finds no matches +in current project." + :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-get-definition-function #'ggtags-get-definition-default + "Function called by `ggtags-show-definition' to get 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. + +The return value is passed to `ggtags-print-definition-function'." + :type 'function + :group 'ggtags) + +(defcustom ggtags-print-definition-function + (lambda (s) (ggtags-echo "%s" (or s "[definition not found]"))) + "Function used by `ggtags-show-definition' to print 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-completing-read-function nil + "Ggtags specific `completing-read-function' (which see). +Nil means using the value of `completing-read-function'." + :type '(choice (const :tag "Use completing-read-function" nil) + function) + :group 'ggtags) + +(define-obsolete-variable-alias 'ggtags-highlight-tag-delay 'ggtags-highlight-tag + "0.8.11") + +(defcustom ggtags-highlight-tag 0.25 + "If non-nil time in seconds before highlighting tag at point. +Set to nil to disable tag highlighting." + :set (lambda (sym value) + (when (fboundp 'ggtags-setup-highlight-tag-at-point) + (ggtags-setup-highlight-tag-at-point value)) + (set-default sym value)) + :type '(choice (const :tag "Disable" nil) 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.") + +(defconst ggtags-bug-url "https://github.com/leoliu/ggtags/issues") + +(defvar ggtags-global-last-buffer nil) + +(defvar ggtags-global-continuation nil) + +(defvar ggtags-current-tag-name nil) + +(defvar ggtags-highlight-tag-overlay nil) + +(defvar ggtags-highlight-tag-timer nil) + +(defmacro ggtags-with-temp-message (message &rest body) + (declare (debug t) (indent 1)) + (let ((init-time (make-symbol "-init-time-")) + (tmp-msg (make-symbol "-tmp-msg-"))) + `(let ((,init-time (float-time)) + (,tmp-msg ,message)) + (with-temp-message ,tmp-msg + (prog1 (progn ,@body) + (message "%sdone (%.2fs)" ,(or tmp-msg "") + (- (float-time) ,init-time))))))) + +(defmacro ggtags-delay-finish-functions (&rest body) + "Delay running `compilation-finish-functions' until after BODY." + (declare (indent 0) (debug t)) + (let ((saved (make-symbol "-saved-")) + (exit-args (make-symbol "-exit-args-"))) + `(let ((,saved compilation-finish-functions) + ,exit-args) + (setq-local compilation-finish-functions nil) + (add-hook 'compilation-finish-functions + (lambda (&rest args) (setq ,exit-args args)) + nil t) + (unwind-protect (progn ,@body) + (setq-local compilation-finish-functions ,saved) + (and ,exit-args (apply #'run-hook-with-args + 'compilation-finish-functions ,exit-args)))))) + +(defmacro ggtags-ensure-global-buffer (&rest body) + (declare (debug t) (indent 0)) + `(progn + (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 ggtags-global-last-buffer ,@body))) + +(defun ggtags-list-of-string-p (xs) + "Return non-nil if XS is a list of strings." + (cl-every #'stringp xs)) + +(defun ggtags-ensure-localname (file) + (and file (or (file-remote-p file 'localname) file))) + +(defun ggtags-echo (format-string &rest args) + "Print formatted text to echo area." + (let (message-log-max) (apply #'message format-string args))) + +(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-kill-window () + "Quit selected window and kill its buffer." + (interactive) + (quit-window t)) + +(defun ggtags-program-path (name) + (if ggtags-executable-directory + (expand-file-name name ggtags-executable-directory) + name)) + +(defun ggtags-process-succeed-p (program &rest args) + "Return non-nil if successfully running PROGRAM with ARGS." + (let ((program (ggtags-program-path program))) + (condition-case err + (zerop (apply #'process-file program nil nil nil args)) + (error (message "`%s' failed: %s" program (error-message-string err)) + nil)))) + +(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\r") + (buffer-substring-no-properties (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-no-properties 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 tag-size has-refs has-path-style has-color dirty-p mtime timestamp) + +(defun ggtags-make-project (root) + (cl-check-type root string) + (let* ((default-directory (file-name-as-directory root)) + ;; NOTE: use of GTAGSDBPATH is not recommended. -- GLOBAL(1) + ;; ROOT and DB can be different directories due to GTAGSDBPATH. + (dbdir (concat (file-remote-p root) + (ggtags-process-string "global" "-p")))) + (pcase (nthcdr 5 (file-attributes (expand-file-name "GTAGS" dbdir))) + (`(,mtime ,_ ,tag-size . ,_) + (let* ((rtags-size (nth 7 (file-attributes (expand-file-name "GRTAGS" dbdir)))) + (has-refs + (when rtags-size + (and (or (> rtags-size (* 32 1024)) + (with-demoted-errors "ggtags-make-project: %S" + (not (equal "" (ggtags-process-string "global" "-crs"))))) + 'has-refs))) + ;; http://thread.gmane.org/gmane.comp.gnu.global.bugs/1518 + (has-path-style + (and (ggtags-process-succeed-p "global" "--path-style" "shorter" "--help") + 'has-path-style)) + ;; http://thread.gmane.org/gmane.comp.gnu.global.bugs/1542 + (has-color (and (ggtags-process-succeed-p "global" "--color" "--help") + 'has-color))) + (puthash default-directory + (ggtags-project--make :root default-directory + :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-last-default-directory nil) +(defvar-local ggtags-project-root 'unset + "Internal variable for project root directory.") + +;;;###autoload +(defun ggtags-find-project () + ;; See https://github.com/leoliu/ggtags/issues/42 + ;; + ;; It is unsafe to cache `ggtags-project-root' in non-file buffers + ;; whose `default-directory' can often change. + (unless (equal ggtags-last-default-directory default-directory) + (kill-local-variable 'ggtags-project-root)) + (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-last-default-directory default-directory) + (setq ggtags-project-root + (or (ignore-errors + (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. + (let ((dir (locate-dominating-file + default-directory + (lambda (dir) (file-regular-p (expand-file-name "GTAGS" dir)))))) + ;; `file-truename' may strip the trailing '/' on + ;; remote hosts, see http://debbugs.gnu.org/16851 + (and 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) + (progn (call-interactively #'ggtags-create-tags) + ;; Need checking because `ggtags-create-tags' can create + ;; tags in any directory. + (ggtags-check-project)))) + +(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 ?= ??)) + (?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 (&optional project) + "Visit the root directory of (current) PROJECT in dired. +When called with a prefix \\[universal-argument], choose from past projects." + (interactive (list (and current-prefix-arg + (completing-read "Project: " ggtags-projects)))) + (dired (cl-typecase project + (string project) + (ggtags-project (ggtags-project-root project)) + (t (ggtags-ensure-project) (ggtags-current-project-root))))) + +(defmacro ggtags-with-current-project (&rest body) + "Eval BODY in current project's `process-environment'." + (declare (debug t) (indent 0)) + (let ((gtagsroot (make-symbol "-gtagsroot-")) + (root (make-symbol "-ggtags-project-root-"))) + `(let* ((,root ggtags-project-root) + (,gtagsroot (when (ggtags-find-project) + (ggtags-ensure-localname + (directory-file-name (ggtags-current-project-root))))) + (process-environment + (append (let ((process-environment (copy-sequence 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"))))) + (unwind-protect (save-current-buffer ,@body) + (setq ggtags-project-root ,root))))) + +(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-project-relative-file (file) + "Get file name relative to current project root." + (ggtags-check-project) + (if (file-name-absolute-p file) + (file-relative-name file (if (string-prefix-p (ggtags-current-project-root) + file) + (ggtags-current-project-root) + (locate-dominating-file file "GTAGS"))) + file)) + +(defun ggtags-project-file-p (file) + "Return non-nil if FILE is part of current project." + (when (ggtags-find-project) + (with-temp-buffer + (ggtags-with-current-project + ;; NOTE: `process-file' requires all files in ARGS be relative + ;; to `default-directory'; see its doc string for details. + (let ((default-directory (ggtags-current-project-root))) + (process-file (ggtags-program-path "global") nil t nil + "-vP" (concat "^" (ggtags-project-relative-file file) "$")))) + (goto-char (point-min)) + (not (re-search-forward "^file not found" nil t))))) + +(defun ggtags-invalidate-buffer-project-root (root) + (mapc (lambda (buf) + (with-current-buffer buf + (and buffer-file-truename + (string-prefix-p root buffer-file-truename) + (kill-local-variable 'ggtags-project-root)))) + (buffer-list))) + +(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 (copy-sequence process-environment))) + (when (zerop (length root)) (error "No root directory provided")) + (setenv "GTAGSROOT" (ggtags-ensure-localname + (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))))) + (unless (or conf (getenv "GTAGSLABEL") + (not (yes-or-no-p "Use `ctags' backend? "))) + (setenv "GTAGSLABEL" "ctags")) + (ggtags-with-temp-message "`gtags' in progress..." + (let ((default-directory (file-name-as-directory root)) + (args (append (cl-remove-if + #'null + (list (and ggtags-use-idutils "--idutils") + (and ggtags-use-sqlite3 + (ggtags-process-succeed-p "gtags" "--sqlite3" "--help") + "--sqlite3") + (and conf "--gtagsconf") + (and conf (ggtags-ensure-localname conf)))) + ggtags-extra-args))) + (condition-case err + (apply #'ggtags-process-string "gtags" args) + (error (if (and ggtags-use-idutils + (stringp (cadr err)) + (string-match-p "mkid not found" (cadr err))) + ;; Retry without mkid + (apply #'ggtags-process-string + "gtags" (cl-remove "--idutils" args)) + (signal (car err) (cdr err))))))))) + (ggtags-invalidate-buffer-project-root (file-truename root)) + (message "GTAGS generated in `%s'" root) + root)) + +(defun ggtags-explain-tags () + "Explain how each file is indexed in current project." + (interactive (ignore (ggtags-check-project) + (or (ggtags-process-succeed-p "gtags" "--explain" "--help") + (user-error "Global 6.4+ required")))) + (ggtags-check-project) + (ggtags-with-current-project + (let ((default-directory (ggtags-current-project-root))) + (compilation-start (concat (ggtags-program-path "gtags") " --explain"))))) + +(defun ggtags-update-tags (&optional force) + "Update GNU Global tag database. +Do nothing if GTAGS exceeds the oversize limit unless FORCE. + +When called interactively on large (per `ggtags-oversize-limit') +projects, the update process runs in the background without +blocking emacs." + (interactive (progn + (ggtags-check-project) + ;; Mark project info expired. + (setf (ggtags-project-timestamp (ggtags-find-project)) -1) + (list 'interactive))) + (cond ((and (eq force 'interactive) (ggtags-project-oversize-p)) + (ggtags-with-current-project + (with-display-buffer-no-window + (with-current-buffer (compilation-start "global -u") + ;; A hack to fool compilation mode to display `global + ;; -u finished' on finish. + (setq mode-name "global -u") + (add-hook 'compilation-finish-functions + #'ggtags-update-tags-finish nil t))))) + ((or force (and (ggtags-find-project) + (not (ggtags-project-oversize-p)) + (ggtags-project-dirty-p (ggtags-find-project)))) + (ggtags-with-current-project + (ggtags-with-temp-message "`global -u' in progress..." + (ggtags-process-string "global" "-u") + (ggtags-update-tags-finish)))))) + +(defun ggtags-update-tags-finish (&optional buf how) + (if (and how buf (string-prefix-p "exited abnormally" how)) + (display-buffer buf) + (setf (ggtags-project-dirty-p (ggtags-find-project)) nil) + (setf (ggtags-project-mtime (ggtags-find-project)) (float-time)))) + +(defun ggtags-update-tags-single (file &optional nowait) + ;; NOTE: NOWAIT is ignored if file is remote file; see + ;; `tramp-sh-handle-process-file'. + (cl-check-type file string) + (let ((nowait (unless (file-remote-p file) nowait))) + (ggtags-with-current-project + ;; See comment in `ggtags-project-file-p'. + (let ((default-directory (ggtags-current-project-root))) + (process-file (ggtags-program-path "global") nil (and nowait 0) nil + "--single-update" (ggtags-project-relative-file file)))))) + +(defun ggtags-delete-tags () + "Delete file GTAGS, GRTAGS, GPATH, ID etc. 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))))))) + +(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 + (cond (confirm + (ggtags-update-tags) + (let ((completing-read-function + (or ggtags-completing-read-function + completing-read-function))) + (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-sort-by-nearness-p (&optional start-location) + (and ggtags-sort-by-nearness + (ggtags-process-succeed-p "global" "--nearness=." "--help") + (concat "--nearness=" + (or start-location buffer-file-name default-directory)))) + +(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 nil) ;-d not supported by Global 5.7.1 + (`reference "--reference") + (`symbol "--symbol") + (`path "--path") + (`grep "--grep") + (`idutils "--idutils"))) + args))) + (mapconcat #'identity (delq nil xs) " "))) + +;; Can be three values: nil, t and a marker; t means start marker has +;; been saved in the tag ring. +(defvar ggtags-global-start-marker nil) +(defvar ggtags-global-start-file nil) +(defvar ggtags-tag-ring-index nil) +(defvar ggtags-global-search-history nil) + +(defvar ggtags-auto-jump-to-match-target nil) + +(defvar-local ggtags-global-exit-info nil) ; (EXIT-STATUS COUNT DB) + +(defun ggtags-global-save-start-marker () + (when (markerp ggtags-global-start-marker) + (setq ggtags-tag-ring-index nil) + (xref-push-marker-stack 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) + (env ggtags-process-environment)) + (unless (and (markerp ggtags-global-start-marker) + (marker-position ggtags-global-start-marker)) + (setq ggtags-global-start-marker (point-marker))) + ;; Record the file name for `ggtags-navigation-start-file'. + (setq ggtags-global-start-file buffer-file-name) + (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) + (ggtags-update-tags) + (ggtags-with-current-project + (with-current-buffer (with-display-buffer-no-window + (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-find-tag (cmd &rest args) + (ggtags-check-project) + (let ((nearness (ggtags-sort-by-nearness-p + (ggtags-project-relative-file + (or buffer-file-name default-directory))))) + (ggtags-global-start + (apply #'ggtags-global-build-command cmd nearness args)))) + +(defun ggtags-include-file () + "Calculate the include file based on `ggtags-include-pattern'." + (pcase ggtags-include-pattern + (`nil nil) + ((pred functionp) + (funcall ggtags-include-pattern)) + (`(,re . ,sub) + (save-excursion + (beginning-of-line) + (and (looking-at re) (match-string sub)))) + (_ (warn "Invalid value for `ggtags-include-pattern': %s" + ggtags-include-pattern) + nil))) + +;;;###autoload +(defun ggtags-find-tag-dwim (name &optional what) + "Find NAME by context. +If point is at a definition tag, find references, and vice versa. +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-file)))) + (ggtags-ensure-project) + (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) + (not (ggtags-project-has-refs (ggtags-find-project))) + (not (ggtags-project-file-p buffer-file-name))) + (ggtags-find-definition name)) + (t (ggtags-find-tag + (format "--from-here=%d:%s" + (line-number-at-pos) + ;; Note `ggtags-find-tag' binds `default-directory' to + ;; project root. + (shell-quote-argument + (ggtags-project-relative-file buffer-file-name))) + "--" (shell-quote-argument name))))) + +(defun ggtags-find-tag-mouse (event) + (interactive "e") + (with-selected-window (posn-window (event-start event)) + (save-excursion + (goto-char (posn-point (event-start event))) + (call-interactively #'ggtags-find-tag-dwim)))) + +;; Another option for `M-.'. +(defun ggtags-find-definition (name) + (interactive (list (ggtags-read-tag 'definition current-prefix-arg))) + (ggtags-find-tag 'definition "--" (shell-quote-argument name))) + +(defun ggtags-setup-libpath-search (type name) + (pcase (and ggtags-global-search-libpath-for-reference + (ggtags-get-libpath)) + ((and libs (guard libs)) + (cl-labels ((cont (buf how) + (pcase ggtags-global-exit-info + (`(0 0 ,_) + (with-temp-buffer + (setq default-directory + (file-name-as-directory (pop libs))) + (and libs (setq ggtags-global-continuation #'cont)) + (if (ggtags-find-project) + (ggtags-find-tag type (shell-quote-argument name)) + (cont buf how)))) + (_ (ggtags-global-handle-exit buf how))))) + (setq ggtags-global-continuation #'cont))))) + +(defun ggtags-find-reference (name) + (interactive (list (ggtags-read-tag 'reference current-prefix-arg))) + (ggtags-setup-libpath-search 'reference name) + (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-setup-libpath-search 'symbol name) + (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)) + (let ((ggtags-global-output-format 'path)) + (ggtags-find-tag 'path (and invert-match "--invert-match") + "--" (ggtags-quote-pattern pattern)))) + +;; Note: Coloured output requested in http://goo.gl/Y9IcX and appeared +;; in global v6.2.12. +(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-foreach-file (fn) + "Invoke FN with each file found. +FN is invoked while *ggtags-global* buffer is current." + (ggtags-ensure-global-buffer + (save-excursion + (goto-char (point-min)) + (while (with-demoted-errors "compilation-next-error: %S" + (compilation-next-error 1 'file) + t) + (funcall fn (caar + (compilation--loc->file-struct + (compilation--message->loc + (get-text-property (point) 'compilation-message))))))))) + +(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 + (ggtags-with-temp-message "Waiting for Grep to finish..." + (while (get-buffer-process (current-buffer)) + (sit-for 0.2))) + (ggtags-foreach-file + (lambda (file) (push (expand-file-name file) files)))) + (ggtags-navigation-mode -1) + (nreverse files)))) + (tags-query-replace from to delimited file-form))) + +(defun ggtags-global-normalise-command (cmd) + (if (string-match + (concat (regexp-quote (ggtags-global-build-command nil)) "\\s-*") + cmd) + (substring-no-properties cmd (match-end 0)) + cmd)) + +(defun ggtags-global-search-id (cmd directory) + (sha1 (concat directory (make-string 1 0) + (ggtags-global-normalise-command cmd)))) + +(defun ggtags-global-current-search () + ;; CMD DIR ENV LINE TEXT + (ggtags-ensure-global-buffer + (list (ggtags-global-normalise-command (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 (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 + (ggtags-global-build-command 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-view-search-history-last nil) + +(defvar ggtags-view-search-history-mode-map + (let ((m (make-sparse-keymap))) + (define-key m "p" 'ggtags-view-search-history-prev) + (define-key m "\M-p" 'ggtags-view-search-history-prev) + (define-key m "n" 'ggtags-view-search-history-next) + (define-key m "\M-n" 'ggtags-view-search-history-next) + (define-key m "\C-k" 'ggtags-view-search-history-kill) + (define-key m [remap yank] (lambda (&optional arg) (interactive "P") (yank arg))) + (define-key m "\C-c\C-c" 'ggtags-view-search-history-update) + (define-key m "r" 'ggtags-save-to-register) + (define-key m "\r" 'ggtags-view-search-history-action) + (define-key m "q" 'ggtags-kill-window) + m)) + +(defun ggtags-view-search-history-remember () + (setq ggtags-view-search-history-last + (pcase (ewoc-locate ggtags-global-search-ewoc) + (`nil nil) + (node (ewoc-data node))))) + +(defun ggtags-view-search-history-next (&optional arg) + (interactive "p") + (let ((arg (or arg 1))) + (prog1 (funcall (if (cl-minusp arg) #'ewoc-goto-prev #'ewoc-goto-next) + ggtags-global-search-ewoc (abs arg)) + (ggtags-view-search-history-remember)))) + +(defun ggtags-view-search-history-prev (&optional arg) + (interactive "p") + (ggtags-view-search-history-next (- (or arg 1)))) + +(defun ggtags-view-search-history-kill (&optional append) + (interactive "P") + (let* ((node (or (ewoc-locate ggtags-global-search-ewoc) + (user-error "No node at point"))) + (next (ewoc-next ggtags-global-search-ewoc node)) + (text (filter-buffer-substring (ewoc-location node) + (if next (ewoc-location next) + (point-max))))) + (put-text-property + 0 (length text) 'yank-handler + (list (lambda (arg) + (if (not ggtags-global-search-ewoc) + (insert (car arg)) + (let* ((inhibit-read-only t) + (node (unless (looking-at-p "[ \t\n]*\\'") + (ewoc-locate ggtags-global-search-ewoc)))) + (if node + (ewoc-enter-before ggtags-global-search-ewoc + node (cadr arg)) + (ewoc-enter-last ggtags-global-search-ewoc (cadr arg))) + (setq ggtags-view-search-history-last (cadr arg))))) + (list text (ewoc-data node))) + text) + (if append (kill-append text nil) + (kill-new text)) + (let ((inhibit-read-only t)) + (ewoc-delete ggtags-global-search-ewoc node)))) + +(defun ggtags-view-search-history-update (&optional noconfirm) + "Update `ggtags-global-search-history' to current buffer." + (interactive "P") + (when (and (buffer-modified-p) + (or noconfirm + (yes-or-no-p "Modify `ggtags-global-search-history'?"))) + (setq ggtags-global-search-history + (ewoc-collect ggtags-global-search-ewoc #'identity)) + (set-buffer-modified-p nil))) + +(defun ggtags-view-search-history-action () + (interactive) + (let ((data (ewoc-data (or (ewoc-locate ggtags-global-search-ewoc) + (user-error "No search at point"))))) + (ggtags-view-search-history-remember) + (quit-window t) + (ggtags-global-rerun-search (cdr data)))) + +(defvar bookmark-make-record-function) + +(define-derived-mode ggtags-view-search-history-mode special-mode "SearchHist" + "Major mode for viewing search history." + :group 'ggtags + (setq-local ggtags-enable-navigation-keys nil) + (setq-local bookmark-make-record-function #'ggtags-make-bookmark-record) + (setq truncate-lines t) + (add-hook 'kill-buffer-hook #'ggtags-view-search-history-update nil t)) + +(defun ggtags-view-search-history-restore-last () + (when ggtags-view-search-history-last + (cl-loop for n = (ewoc-nth ggtags-global-search-ewoc 0) + then (ewoc-next ggtags-global-search-ewoc n) + while n when (eq (ewoc-data n) + ggtags-view-search-history-last) + do (progn (goto-char (ewoc-location n)) (cl-return t))))) + +(defun ggtags-view-search-history () + "Pop to a buffer to view or re-run past searches. + +\\{ggtags-view-search-history-mode-map}" + (interactive) + (or ggtags-global-search-history (user-error "No search history")) + (let ((split-window-preferred-function ggtags-split-window-function) + (inhibit-read-only t)) + (pop-to-buffer "*Ggtags Search History*") + (erase-buffer) + (ggtags-view-search-history-mode) + (cl-labels ((prop (s) + (propertize s 'face 'minibuffer-prompt)) + (prop-tag (cmd) + (with-temp-buffer + (insert cmd) + (forward-sexp -1) + (if (eobp) + cmd + (put-text-property (point) (point-max) + 'face font-lock-constant-face) + (buffer-string)))) + (pp (data) + (pcase data + (`(,_id ,cmd ,dir ,_env ,line ,text) + (insert (prop " cmd: ") (prop-tag 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)) + (ggtags-view-search-history-restore-last) + (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 + :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 (bookmark-prop-get bmk 'ggtags-search))) + +(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) + (and (ring-empty-p xref--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 (xref-push-marker-stack) + 0)) + (ring-length xref--marker-ring))) + (let ((m (ring-ref xref--marker-ring ggtags-tag-ring-index)) + (i (- (ring-length xref--marker-ring) ggtags-tag-ring-index))) + (ggtags-echo "%d%s marker%s" i (pcase (mod i 10) + (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" 'ggtags-kill-window) + m)) + +(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 xref--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 xref--marker-ring)) + (elements (or (ring-elements xref--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-1 () + "Get the total of matches and db file used." + (save-excursion + (goto-char (point-max)) + (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)))) + +(defun ggtags-global-exit-message-function (_process-status exit-status msg) + "A function for `compilation-exit-message-function'." + (pcase (ggtags-global-exit-message-1) + (`(,count . ,db) + (setq ggtags-global-exit-info (list exit-status count db)) + ;; Clear the start marker in case of zero matches. + (and (zerop count) + (markerp ggtags-global-start-marker) + (not ggtags-global-continuation) + (setq ggtags-global-start-marker nil)) + (cons (if (> exit-status 0) + msg + (format "found %d %s" count + (funcall (if (= count 1) #'car #'cadr) + (pcase db + ("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 + (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 (,(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 (,(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))) + compilation-error-regexp-alist-alist)) + +(defun ggtags-abbreviate-file (start end) + (let ((inhibit-read-only t) + (amount (if (numberp ggtags-global-abbreviate-filename) + (- (- end start) ggtags-global-abbreviate-filename) + 999)) + (advance-word (lambda () + "Return the length of the text made invisible." + (let ((wend (min end (progn (forward-word 1) (point)))) + (wbeg (max start (progn (backward-word 1) (point))))) + (goto-char wend) + (if (<= (- wend wbeg) 1) + 0 + (put-text-property (1+ wbeg) wend 'invisible t) + (1- (- wend wbeg))))))) + (goto-char start) + (while (and (> amount 0) (> end (point))) + (cl-decf amount (funcall advance-word))))) + +(defun ggtags-abbreviate-files (start end) + (goto-char start) + (let* ((error-re (cdr (assq (car compilation-error-regexp-alist) + ggtags-global-error-regexp-alist-alist))) + (sub (cadr error-re))) + (when (and ggtags-global-abbreviate-filename error-re) + (while (re-search-forward (car error-re) end t) + (when (and (or (not (numberp ggtags-global-abbreviate-filename)) + (> (length (match-string sub)) + ggtags-global-abbreviate-filename)) + ;; Ignore bogus file lines such as: + ;; Global found 2 matches at Thu Jan 31 13:45:19 + (get-text-property (match-beginning sub) 'compilation-message)) + (ggtags-abbreviate-file (match-beginning sub) (match-end sub))))))) + +(defvar-local ggtags-global-output-lines 0) + +(defun ggtags-global--display-buffer (&optional buffer desired-point) + (pcase (let ((buffer (or buffer (current-buffer))) + (split-window-preferred-function ggtags-split-window-function)) + (and (not (get-buffer-window buffer)) + (display-buffer buffer '(nil (allow-no-window . t))))) + ((and (pred windowp) w) + (with-selected-window w + (compilation-set-window-height w) + (and desired-point (goto-char desired-point)))))) + +(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))) + ;; If the number of output lines is small + ;; `ggtags-global-handle-exit' takes care of displaying the buffer. + (when (and (> ggtags-global-output-lines 30) ggtags-navigation-mode) + (ggtags-global--display-buffer nil (or compilation-current-error (point-min)))) + (when (and (eq ggtags-auto-jump-to-match 'history) + (numberp ggtags-auto-jump-to-match-target) + (not compilation-current-error) + ;; `ggtags-global-output-lines' is imprecise but use it + ;; as first approximation. + (> (+ 10 ggtags-global-output-lines) ggtags-auto-jump-to-match-target) + (> (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) + (ggtags-delay-finish-functions + (with-display-buffer-no-window + (condition-case nil + (let ((compilation-auto-jump-to-first-error t)) + (compilation-auto-jump (current-buffer) (point))) + (error (message "\ +ggtags: history match invalid, jump to first match instead") + (first-error))))) + ;; `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. + (run-with-idle-timer + 0 nil + (lambda (buf pt) + (and (buffer-live-p buf) + (with-current-buffer buf (goto-char pt)))) + (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) + (ggtags-echo "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 + (ggtags-global-continuation + (let ((cont (prog1 ggtags-global-continuation + (setq ggtags-global-continuation nil)))) + (funcall cont buf how))) + ((string-prefix-p "exited abnormally" how) + ;; If exit abnormally display the buffer for inspection. + (ggtags-global--display-buffer) + (when (save-excursion + (goto-char (point-max)) + (re-search-backward + (eval-when-compile + (format "^global: %s not found.$" + (regexp-opt '("GTAGS" "GRTAGS" "GSYMS" "GPATH")))) + nil t)) + (ggtags-echo "WARNING: Global tag files missing in `%s'" + ggtags-project-root) + (remhash ggtags-project-root ggtags-projects))) + (ggtags-auto-jump-to-match + (if (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))) + ;; There are multiple matches so pop up the buffer. + (and ggtags-navigation-mode (ggtags-global--display-buffer)) + ;; Manually run the `compilation-auto-jump' timer. Hackish but + ;; everything else seems unreliable. See: + ;; + ;; - http://debbugs.gnu.org/13829 + ;; - http://debbugs.gnu.org/23987 + ;; - https://github.com/leoliu/ggtags/issues/89 + ;; + (pcase (cl-find 'compilation-auto-jump timer-list :key #'timer--function) + (`nil ) + (timer (timer-event-handler timer))) + (ggtags-navigation-mode -1) + (ggtags-navigation-mode-cleanup buf t))))) + +(defvar ggtags-global-mode-font-lock-keywords + '(("^Global \\(exited abnormally\\|interrupt\\|killed\\|terminated\\)\\(?:.*with code \\([0-9]+\\)\\)?.*" + (1 'compilation-error) + (2 'compilation-error nil t)) + ("^Global found \\([0-9]+\\)" (1 compilation-info-face)))) + +(define-compilation-mode ggtags-global-mode "Global" + "A mode for showing outputs from gnu global." + ;; Note: Place `ggtags-global-output-format' as first element for + ;; `ggtags-abbreviate-files'. + (setq-local compilation-error-regexp-alist (list ggtags-global-output-format)) + (when (markerp ggtags-global-start-marker) + (setq ggtags-project-root + (buffer-local-value 'ggtags-project-root + (marker-buffer ggtags-global-start-marker)))) + (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-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-start-file) + (define-key map "\M->" 'ggtags-navigation-last-error) + (define-key map "\M-<" 'first-error) + ;; Note: shadows `isearch-forward-regexp' but it can still be + ;; invoked with `C-u C-s'. + (define-key map "\C-\M-s" 'ggtags-navigation-isearch-forward) + ;; Add an alternative binding because C-M-s is reported not + ;; working on some systems. + (define-key map "\M-ss" '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) + (define-key map [remap xref-pop-marker-stack] 'ggtags-navigation-mode-abort) + 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" 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 ((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 kill) + (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-windows-on (current-buffer))) + (and kill (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 () + "Abort navigation and return to where the search was started." + (interactive) + (ggtags-navigation-mode -1) + (ggtags-navigation-mode-cleanup nil t) + ;; 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) + (xref-pop-marker-stack))) + +(defun ggtags-navigation-next-file (n) + (interactive "p") + (ggtags-ensure-global-buffer + (compilation-next-file n) + (compile-goto-error))) + +(defun ggtags-navigation-previous-file (n) + (interactive "p") + (ggtags-navigation-next-file (- n))) + +(defun ggtags-navigation-start-file () + "Move to the file where navigation session starts." + (interactive) + (let ((start-file (or ggtags-global-start-file + (user-error "Cannot decide start file")))) + (ggtags-ensure-global-buffer + (pcase (cl-block nil + (ggtags-foreach-file + (lambda (file) + (when (file-equal-p file start-file) + (cl-return (point)))))) + (`nil (user-error "No matches for `%s'" start-file)) + (n (goto-char n) (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))) + +(put 'ggtags-navigation-mode-lighter 'risky-local-variable t) + +(defvar ggtags-navigation-mode-lighter + '(" GG[" + (:eval + (if (not (buffer-live-p ggtags-global-last-buffer)) + '(:propertize "??" face error help-echo "No Global buffer") + (with-current-buffer ggtags-global-last-buffer + (pcase (or ggtags-global-exit-info '(0 0 "")) + (`(,exit ,count ,db) + `((:propertize ,(pcase db + (`"GTAGS" "D") + (`"GRTAGS" "R") + (`"GSYMS" "S") + (`"GPATH" "F") + (`"ID" "I")) + face success) + (:propertize + ,(pcase (get-text-property (line-beginning-position) + 'compilation-message) + (`nil "?") + ;; Assume the first match appears at line 5 + (_ (number-to-string (- (line-number-at-pos) 4)))) + face success) + "/" + (:propertize ,(number-to-string count) face success) + ,(unless (zerop exit) + `(":" (:propertize ,(number-to-string exit) face error))))))))) + "]") + "Ligher for `ggtags-navigation-mode'; set to nil to disable it.") + +(define-minor-mode ggtags-navigation-mode nil + ;; If `ggtags-enable-navigation-keys' is set to nil only display the + ;; lighter in `ggtags-mode' buffers. + ;; See https://github.com/leoliu/ggtags/issues/124 + :lighter (:eval (and (or ggtags-enable-navigation-keys + ggtags-mode) + ggtags-navigation-mode-lighter)) + :global t + (if ggtags-navigation-mode + (progn + ;; 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)) + (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-enable-navigation-keys nil)) + +(defun ggtags-kill-file-buffers (&optional interactive) + "Kill all buffers visiting files in current project." + (interactive "p") + (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 (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 () + (when (ggtags-find-project) + (ggtags-project-update-mtime-maybe) + (and buffer-file-name ggtags-update-on-save + (ggtags-update-tags-single buffer-file-name 'nowait)))) + +(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")) + (when (get-buffer-process (get-buffer buffer)) + ;; Notice running multiple processes in the same buffer so that we + ;; can fix the caller. See for example `ggtags-eldoc-function'. + (message "Warning: detected %S already running in %S; interrupting..." + (get-buffer-process buffer) buffer) + (interrupt-process (get-buffer-process buffer))) + (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)))) + (filter (lambda (proc string) + (and (buffer-live-p (process-buffer proc)) + (with-current-buffer (process-buffer proc) + (goto-char (process-mark proc)) + (insert string) + (cl-incf (process-get proc :nlines) + (count-lines (process-mark proc) (point))) + (set-marker (process-mark proc) (point)) + (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)))))) + (proc (apply #'start-file-process program buffer program args))) + (set-process-sentinel proc sentinel) + (set-process-query-on-exit-flag proc nil) + (and cutoff (set-process-filter proc filter)) + (process-put proc :nlines 0) + proc)) + +(defun ggtags-global-output-sync (buffer cmds callback) + "Synchronously run CMDS and show output in BUFFER. +When finished invoke CALLBACK in BUFFER with process exit status." + ;; Same as `ggtags-global-output' + (or buffer (error "Output buffer required")) + (when (get-buffer-process (get-buffer buffer)) + ;; Notice running multiple processes in the same buffer so that we + ;; can fix the caller. See for example `ggtags-eldoc-function'. + (message "Warning: detected %S already running in %S; interrupting..." + (get-buffer-process buffer) buffer) + (interrupt-process (get-buffer-process buffer))) + (let* ((program (car cmds)) + (args (cdr cmds)) + (status (apply #'call-process program nil buffer nil args))) + (with-current-buffer buffer + (funcall callback status)))) + +(cl-defun ggtags-fontify-code (code &optional (mode major-mode)) + (cl-check-type mode function) + (if (stringp code) + (with-temp-buffer + (insert code) + (funcall mode) + (font-lock-ensure) + (buffer-string)) + code)) + +(defun ggtags-get-definition-default (defs) + (and (caar defs) + (concat (ggtags-fontify-code (caar defs)) + (and (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*")) + ;; `.' works here because ggtags-global-output doesn't set + ;; default-directory to project root. + (args (delq nil (list (ggtags-sort-by-nearness-p ".") + "--result=grep" "--path-style=absolute" name))) + ;; Need these bindings so that let-binding + ;; `ggtags-print-definition-function' can work see + ;; `ggtags-eldoc-function'. + (get-fn ggtags-get-definition-function) + (print-fn ggtags-print-definition-function) + (show (lambda (_status) + (goto-char (point-min)) + (let ((defs (cl-loop while (re-search-forward re nil t) + collect (list (buffer-substring-no-properties + (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 print-fn (funcall get-fn defs))))))) + (ggtags-with-current-project + (ggtags-global-output buffer (cons (ggtags-program-path "global") args) + 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-tags) + (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-view-search-history) + (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 [eldoc-mode] + '(menu-item "Toggle eldoc mode" eldoc-mode :button (:toggle . eldoc-mode))) + (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 tags" ggtags-delete-tags + :enable (ggtags-find-project) + :help "Delete file GTAGS, GRTAGS, GPATH, ID etc.")) + (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" xref-pop-marker-stack + :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 [previous-error] + '(menu-item "Previous match" previous-error)) + (define-key menu [next-error] + '(menu-item "Next match" next-error)) + (define-key menu [rerun-search] + '(menu-item "View past searches" ggtags-view-search-history)) + (define-key menu [save-to-register] + '(menu-item "Save search to register" ggtags-save-to-register)) + (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 + :help "Find references without definition")) + (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)) + ;; TODO: bind `find-tag-continue' to `M-*' after dropping support + ;; for emacs < 25. + (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 [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")) + (ggtags-setup-highlight-tag-at-point ggtags-highlight-tag) + (if ggtags-mode + (progn + (add-hook 'after-save-hook 'ggtags-after-save-function nil t) + (add-hook 'xref-backend-functions 'ggtags--xref-backend nil t) + ;; Append to serve as a fallback method. + (add-hook 'completion-at-point-functions + #'ggtags-completion-at-point t t) + ;; Work around http://debbugs.gnu.org/19324 + (or eldoc-documentation-function + (setq-local eldoc-documentation-function #'ignore)) + (add-function :after-until (local 'eldoc-documentation-function) + #'ggtags-eldoc-function '((name . ggtags-eldoc-function) + (depth . -100))) + (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) + (remove-hook 'xref-backend-functions 'ggtags--xref-backend t) + (remove-hook 'completion-at-point-functions #'ggtags-completion-at-point t) + (remove-function (local 'eldoc-documentation-function) 'ggtags-eldoc-function) + (setq mode-line-buffer-identification + (delq 'ggtags-mode-line-project-name mode-line-buffer-identification)) + (ggtags-cancel-highlight-tag-at-point 'keep-timer))) + +(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-setup-highlight-tag-at-point (flag) + (cond ((null flag) (ggtags-cancel-highlight-tag-at-point)) + ((not (timerp ggtags-highlight-tag-timer)) + (setq ggtags-highlight-tag-timer + (run-with-idle-timer flag t #'ggtags-highlight-tag-at-point))) + (t (timer-set-idle-time ggtags-highlight-tag-timer flag t)))) + +(defun ggtags-cancel-highlight-tag-at-point (&optional keep-timer) + (when (and (not keep-timer) + (timerp ggtags-highlight-tag-timer)) + (cancel-timer ggtags-highlight-tag-timer) + (setq ggtags-highlight-tag-timer nil)) + (when ggtags-highlight-tag-overlay + (delete-overlay ggtags-highlight-tag-overlay) + (setq ggtags-highlight-tag-overlay nil))) + +(defun ggtags-highlight-tag-at-point () + (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 + ((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-no-properties + (car bounds) (cdr bounds)) + ggtags-completion-table))) + (move-overlay o (car bounds) (cdr bounds) (current-buffer)) + (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)))))) + +;;; eldoc + +(defvar-local ggtags-eldoc-cache nil) + +(declare-function eldoc-message "eldoc") +(defun ggtags-eldoc-function () + "A function suitable for `eldoc-documentation-function' (which see)." + (pcase (ggtags-tag-at-point) + (`nil nil) + (tag (if (equal tag (car ggtags-eldoc-cache)) + (cadr ggtags-eldoc-cache) + (and ggtags-project-root (ggtags-find-project) + (let* ((ggtags-print-definition-function + (lambda (s) + (setq ggtags-eldoc-cache (list tag s)) + (eldoc-message s)))) + ;; Prevent multiple runs of ggtags-show-definition + ;; for the same tag. + (setq ggtags-eldoc-cache (list tag)) + (condition-case err + (ggtags-show-definition tag) + (file-error + (remove-function (local 'eldoc-documentation-function) + 'ggtags-eldoc-function) + (message "\ +Function `ggtags-eldoc-function' disabled for eldoc in current buffer: %S" err))) + nil)))))) + +;;; imenu + +(defun ggtags-goto-imenu-index (name line &rest _args) + (ggtags-forward-to-line line) + (ggtags-move-to-tag name)) + +;;;###autoload +(defun ggtags-build-imenu-index () + "A function suitable for `imenu-create-index-function'." + (let ((file (and buffer-file-name (file-relative-name buffer-file-name)))) + (and file (with-temp-buffer + (when (with-demoted-errors "ggtags-build-imenu-index: %S" + (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 ggtags-try-complete-tag (old) + "A function suitable for `hippie-expand-try-functions-list'." + (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)) + +;;; Xref + +(defconst ggtags--xref-limit 1000) + +(cl-defstruct (ggtags-xref-location + (:constructor ggtags-make-xref-location (file line column project-root))) + file line column project-root) + +(cl-defmethod xref-location-group ((l ggtags-xref-location)) + (file-relative-name (ggtags-xref-location-file l) (ggtags-xref-location-project-root l))) + +(cl-defmethod xref-location-marker ((l ggtags-xref-location)) + (let ((buffer (find-file-noselect (ggtags-xref-location-file l)))) + (with-current-buffer buffer + (save-excursion + (goto-char (point-min)) + (forward-line (1- (ggtags-xref-location-line l))) + (move-to-column (1- (ggtags-xref-location-column l))) + (point-marker))))) + +(cl-defmethod xref-location-line ((l ggtags-xref-location)) + (ggtags-xref-location-line l)) + +(defun ggtags--xref-backend () + (and (ggtags-find-project) + (let ((tag (ggtags-tag-at-point))) + ;; Try to use this backend if there is no tag at + ;; point, since we may still want to when asking + ;; the user for a tag. + (or (null tag) + (test-completion tag ggtags-completion-table))) + 'ggtags)) + +(cl-defmethod xref-backend-identifier-at-point ((_backend (eql ggtags))) + (ggtags-tag-at-point)) + +(cl-defmethod xref-backend-identifier-completion-table ((_backend (eql ggtags))) + ggtags-completion-table) + +(defun ggtags--xref-collect-tags (tag root colored) + "Collect xrefs for TAG from Global output in the `current-buffer'. +Return the list of xrefs for TAG. Global output is assumed to +have grep format. + +ROOT is the project root directory to associate with the xrefs. + +If COLORED is non-nil, convert ANSI color codes to font lock text +properties in the summary text of each xref." + (cl-loop + with re = (cadr (assq 'grep ggtags-global-error-regexp-alist-alist)) + while (re-search-forward re nil t) + for summary = (buffer-substring (1+ (match-end 2)) (line-end-position)) + for file = (expand-file-name (match-string 1)) + for line = (string-to-number (match-string 2)) + for column = (string-match-p tag summary) + if colored do (setq summary (ansi-color-apply summary)) end + ;; Sometimes there are false positives, depending on the + ;; parser used so only collect lines that actually + ;; contain TAG. + and when column + collect (xref-make + summary + (ggtags-make-xref-location + file + line + column + root)))) + +(defun ggtags--xref-find-tags (tag cmd) + "Find xrefs of TAG using Global CMD. +CMD has the same meaning as in `ggtags-global-build-command'. +Return the list of xrefs for TAG." + (let* ((ggtags-global-output-format 'grep) + (project (ggtags-find-project)) + (xrefs nil) + (collect + (lambda (_status) + (goto-char (point-min)) + (setq xrefs (ggtags--xref-collect-tags + tag + (ggtags-project-root project) + (and ggtags-global-use-color + (ggtags-project-has-color project)))) + (kill-buffer (current-buffer))))) + (ggtags-with-current-project + (let ((default-directory (ggtags-current-project-root))) + (ggtags-global-output-sync + (get-buffer-create " *ggtags-xref*") + (append + (split-string (ggtags-global-build-command cmd)) + (list "--" (shell-quote-argument tag))) + collect)) + xrefs))) + +(cl-defmethod xref-backend-definitions ((_backend (eql ggtags)) tag) + (ggtags--xref-find-tags tag 'definition)) + +(cl-defmethod xref-backend-references ((_backend (eql ggtags)) tag) + (ggtags--xref-find-tags tag 'reference)) + +(cl-defmethod xref-backend-apropos ((_backend (eql ggtags)) tag) + (ggtags--xref-find-tags tag 'grep)) + +(defun ggtags-reload (&optional force) + (interactive "P") + (unload-feature 'ggtags force) + (require 'ggtags)) + +(provide 'ggtags) +;;; ggtags.el ends here