code.delx.au - gnu-emacs-elpa/blob - ggtags.el

   1 ;;; ggtags.el --- emacs frontend to GNU Global source code tagging system  -*- lexical-binding: t; -*-
   2
   3 ;; Copyright (C) 2013-2014  Free Software Foundation, Inc.
   4
   5 ;; Author: Leo Liu <sdl.web@gmail.com>
   6 ;; Version: 0.7.11
   7 ;; Keywords: tools, convenience
   8 ;; Created: 2013-01-29
   9 ;; URL: https://github.com/leoliu/ggtags
  10 ;; Package-Requires: ((emacs "24"))
  11
  12 ;; This program is free software; you can redistribute it and/or modify
  13 ;; it under the terms of the GNU General Public License as published by
  14 ;; the Free Software Foundation, either version 3 of the License, or
  15 ;; (at your option) any later version.
  16
  17 ;; This program is distributed in the hope that it will be useful,
  18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20 ;; GNU General Public License for more details.
  21
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
  24
  25 ;;; Commentary:
  26
  27 ;; A package to integrate GNU Global source code tagging system
  28 ;; (http://www.gnu.org/software/global) with Emacs.
  29 ;;
  30 ;; Usage:
  31 ;;
  32 ;; Type `M-x ggtags-mode' to enable the minor mode, or as usual enable
  33 ;; it in your desired major mode hooks. When the mode is on the symbol
  34 ;; at point is underlined if it is a valid (definition) tag.
  35 ;;
  36 ;; `M-.' finds definition or references according to the context at
  37 ;; point, i.e. if point is at a definition tag find references and
  38 ;; vice versa. `M-]' finds references.
  39 ;;
  40 ;; If multiple matches are found, navigation mode is entered, the
  41 ;; mode-line lighter changed, and a navigation menu-bar entry
  42 ;; presented. In this mode, `M-n' and `M-p' moves to next and previous
  43 ;; match, `M-}' and `M-{' to next and previous file respectively.
  44 ;; `M-o' toggles between full and abbreviated displays of file names
  45 ;; in the auxiliary popup window. When you locate the right match,
  46 ;; press RET to finish which hides the auxiliary window and exits
  47 ;; navigation mode. You can continue the search using `M-,'. To abort
  48 ;; the search press `M-*'.
  49 ;;
  50 ;; Normally after a few searches a dozen buffers are created visiting
  51 ;; files tracked by GNU Global. `C-c M-k' helps clean them up.
  52 ;;
  53 ;; Check the menu-bar entry `Ggtags' for other useful commands.
  54
  55 ;;; Code:
  56
  57 (eval-when-compile
  58   (require 'cl)
  59   (require 'url-parse))
  60
  61 (require 'compile)
  62 (require 'etags)
  63 (require 'tabulated-list)               ;preloaded since 24.3
  64
  65 (eval-when-compile
  66   (unless (fboundp 'setq-local)
  67     (defmacro setq-local (var val)
  68       (list 'set (list 'make-local-variable (list 'quote var)) val)))
  69
  70   (unless (fboundp 'defvar-local)
  71     (defmacro defvar-local (var val &optional docstring)
  72       (declare (debug defvar) (doc-string 3))
  73       (list 'progn (list 'defvar var val docstring)
  74             (list 'make-variable-buffer-local (list 'quote var)))))
  75
  76   (defmacro* when-let ((var exp) &rest body)
  77     "A macro that combines `let' and `when'."
  78     (declare (indent 1) (debug ((sexp form) body)))
  79     `(let ((,var ,exp)) (when ,var ,@body))))
  80
  81 (eval-and-compile
  82   (or (fboundp 'user-error)
  83       (defalias 'user-error 'error)))
  84
  85 (defgroup ggtags nil
  86   "GNU Global source code tagging system."
  87   :group 'tools)
  88
  89 (defface ggtags-highlight '((t (:underline t)))
  90   "Face used to highlight a valid tag at point."
  91   :group 'ggtags)
  92
  93 (defface ggtags-global-line '((t (:inherit secondary-selection)))
  94   "Face used to highlight matched line in Global buffer."
  95   :group 'ggtags)
  96
  97 (defcustom ggtags-oversize-limit (* 10 1024 1024)
  98   "The over size limit for the  GTAGS file.
  99 For large source trees, running 'global -u' can be expensive.
 100 Thus when GTAGS file is larger than this limit, ggtags
 101 automatically switches to 'global --single-update'."
 102   :safe 'numberp
 103   :type '(choice (const :tag "None" nil)
 104                  (const :tag "Always" t)
 105                  number)
 106   :group 'ggtags)
 107
 108 (defcustom ggtags-project-duration 3600
 109   "Seconds to keep information of a project in memory."
 110   :type 'number
 111   :group 'ggtags)
 112
 113 (defcustom ggtags-process-environment nil
 114   "Similar to `process-environment' with higher precedence.
 115 Elements are run through `substitute-env-vars' before use.
 116 GTAGSROOT will always be expanded to current project root
 117 directory. This is intended for project-wise ggtags-specific
 118 process environment settings. Note on remote hosts (e.g. tramp)
 119 directory local variables is not enabled by default per
 120 `enable-remote-dir-locals' (which see)."
 121   :safe 'ggtags-list-of-string-p
 122   :type '(repeat string)
 123   :group 'ggtags)
 124
 125 (defcustom ggtags-auto-jump-to-first-match t
 126   "Non-nil to automatically jump to the first match."
 127   :type 'boolean
 128   :group 'ggtags)
 129
 130 (defcustom ggtags-global-window-height 8 ; ggtags-global-mode
 131   "Number of lines for the 'global' popup window.
 132 If nil, use Emacs default."
 133   :type '(choice (const :tag "Default" nil) integer)
 134   :group 'ggtags)
 135
 136 (defcustom ggtags-global-abbreviate-filename 35
 137   "Non-nil to display file names abbreviated e.g. \"/u/b/env\".
 138 If an integer abbreviate only names longer than that number."
 139   :type '(choice (const :tag "No" nil)
 140                  (const :tag "Always" t)
 141                  integer)
 142   :group 'ggtags)
 143
 144 (defcustom ggtags-split-window-function split-window-preferred-function
 145   "A function to control how ggtags pops up the auxiliary window."
 146   :type 'function
 147   :group 'ggtags)
 148
 149 (defcustom ggtags-use-idutils (and (executable-find "mkid") t)
 150   "Non-nil to also generate the idutils DB."
 151   :type 'boolean
 152   :group 'ggtags)
 153
 154 (defcustom ggtags-global-output-format 'grep
 155   "The output format for the 'global' command."
 156   :type '(choice (const path)
 157                  (const ctags)
 158                  (const ctags-x)
 159                  (const grep)
 160                  (const cscope))
 161   :group 'ggtags)
 162
 163 (defcustom ggtags-global-ignore-case nil
 164   "Non-nil if Global should ignore case."
 165   :safe 'booleanp
 166   :type 'boolean
 167   :group 'ggtags)
 168
 169 (defcustom ggtags-global-treat-text nil
 170   "Non-nil if Global should include matches from text files."
 171   :safe 'booleanp
 172   :type 'boolean
 173   :group 'ggtags)
 174
 175 (defcustom ggtags-global-large-output 1000
 176   "Number of lines in the Global buffer to indicate large output."
 177   :type 'number
 178   :group 'ggtags)
 179
 180 (defcustom ggtags-mode-prefix-key "\C-c"
 181   "Key binding used for `ggtags-mode-prefix-map'.
 182 Users should change the value using `customize-variable' to
 183 properly update `ggtags-mode-map'."
 184   :set (lambda (sym value)
 185          (when (bound-and-true-p ggtags-mode-map)
 186            (when-let (old (and (boundp sym) (symbol-value sym)))
 187              (define-key ggtags-mode-map old nil))
 188            (and value
 189                 (bound-and-true-p ggtags-mode-prefix-map)
 190                 (define-key ggtags-mode-map value ggtags-mode-prefix-map)))
 191          (set-default sym value))
 192   :type 'key-sequence
 193   :group 'ggtags)
 194
 195 (defcustom ggtags-completing-read-function completing-read-function
 196   "Ggtags specific `completing-read-function' (which see)."
 197   :type 'function
 198   :group 'ggtags)
 199
 200 (defcustom ggtags-highlight-tag-delay 0.25
 201   "Time in seconds before highlighting tag at point."
 202   :set (lambda (sym value)
 203          (when (bound-and-true-p ggtags-highlight-tag-timer)
 204            (timer-set-idle-time ggtags-highlight-tag-timer value t))
 205          (set-default sym value))
 206   :type 'number
 207   :group 'ggtags)
 208
 209 (defcustom ggtags-bounds-of-tag-function (lambda ()
 210                                            (bounds-of-thing-at-point 'symbol))
 211   "Function to get the start and end locations of the tag at point."
 212   :type 'function
 213   :group 'ggtags)
 214
 215 (defvar ggtags-bug-url "https://github.com/leoliu/ggtags/issues")
 216
 217 (defvar ggtags-global-last-buffer nil)
 218
 219 (defvar ggtags-current-tag-name nil)
 220
 221 (defvar ggtags-highlight-tag-overlay nil)
 222
 223 (defvar ggtags-highlight-tag-timer nil)
 224
 225 ;; Used by ggtags-global-mode
 226 (defvar ggtags-global-error "match"
 227   "Stem of message to print when no matches are found.")
 228
 229 (defmacro ggtags-ensure-global-buffer (&rest body)
 230   (declare (indent 0))
 231   `(progn
 232      (or (and (buffer-live-p ggtags-global-last-buffer)
 233               (with-current-buffer ggtags-global-last-buffer
 234                 (derived-mode-p 'ggtags-global-mode)))
 235          (error "No global buffer found"))
 236      (with-current-buffer ggtags-global-last-buffer ,@body)))
 237
 238 (defun ggtags-list-of-string-p (xs)
 239   "Return non-nil if XS is a list of strings."
 240   (if (null xs)
 241       t
 242     (and (stringp (car xs))
 243          (ggtags-list-of-string-p (cdr xs)))))
 244
 245 (defun ggtags-process-string (program &rest args)
 246   (with-temp-buffer
 247     (let ((exit (apply #'process-file program nil t nil args))
 248           (output (progn
 249                     (goto-char (point-max))
 250                     (skip-chars-backward " \t\n")
 251                     (buffer-substring (point-min) (point)))))
 252       (or (zerop exit)
 253           (error "`%s' non-zero exit: %s" program output))
 254       output)))
 255
 256 (defun ggtags-tag-at-point ()
 257   (when-let (bounds (funcall ggtags-bounds-of-tag-function))
 258     (buffer-substring (car bounds) (cdr bounds))))
 259
 260 ;;; Store for project info and settings
 261
 262 (defvar ggtags-projects (make-hash-table :size 7 :test #'equal))
 263
 264 (defstruct (ggtags-project (:constructor ggtags-project--make)
 265                            (:copier nil)
 266                            (:type vector)
 267                            :named)
 268   root tag-size has-refs has-path-style has-color dirty-p timestamp)
 269
 270 (defun ggtags-make-project (root)
 271   (check-type root string)
 272   (when-let (tag-size (nth 7 (file-attributes (expand-file-name "GTAGS" root))))
 273     (let* ((default-directory (file-name-as-directory root))
 274            (rtags-size (nth 7 (file-attributes "GRTAGS")))
 275            (has-refs
 276             (when rtags-size
 277               (and (or (> rtags-size (* 32 1024))
 278                        (with-demoted-errors
 279                          (not (equal "" (ggtags-process-string "global" "-crs")))))
 280                    'has-refs)))
 281            ;; http://thread.gmane.org/gmane.comp.gnu.global.bugs/1518
 282            (has-path-style
 283             (with-demoted-errors        ; in case `global' not found
 284               (and (zerop (process-file "global" nil nil nil
 285                                         "--path-style" "shorter" "--help"))
 286                    'has-path-style)))
 287            ;; http://thread.gmane.org/gmane.comp.gnu.global.bugs/1542
 288            (has-color
 289             (with-demoted-errors
 290               (and (zerop (process-file "global" nil nil nil "--color" "--help"))
 291                    'has-color))))
 292       (puthash default-directory
 293                (ggtags-project--make :root default-directory
 294                                      :tag-size tag-size
 295                                      :has-refs has-refs
 296                                      :has-path-style has-path-style
 297                                      :has-color has-color
 298                                      :timestamp (float-time))
 299                ggtags-projects))))
 300
 301 (defun ggtags-project-expired-p (project)
 302   (or (< (ggtags-project-timestamp project) 0)
 303       (> (- (float-time)
 304             (ggtags-project-timestamp project))
 305          ggtags-project-duration)))
 306
 307 (defun ggtags-project-oversize-p (&optional project)
 308   (pcase ggtags-oversize-limit
 309     (`nil nil)
 310     (`t t)
 311     (size (when-let (project (or project (ggtags-find-project)))
 312             (> (ggtags-project-tag-size project) size)))))
 313
 314 (defvar-local ggtags-project-root 'unset
 315   "Internal variable for project root directory.")
 316
 317 ;;;###autoload
 318 (defun ggtags-find-project ()
 319   (let ((project (gethash ggtags-project-root ggtags-projects)))
 320     (if (ggtags-project-p project)
 321         (if (ggtags-project-expired-p project)
 322             (progn
 323               (remhash ggtags-project-root ggtags-projects)
 324               (ggtags-find-project))
 325           project)
 326       (setq ggtags-project-root
 327             (or (ignore-errors (file-name-as-directory
 328                                 (concat (file-remote-p default-directory)
 329                                         ;; Resolves symbolic links
 330                                         (ggtags-process-string "global" "-pr"))))
 331                 ;; 'global -pr' resolves symlinks before checking
 332                 ;; the GTAGS file which could cause issues such as
 333                 ;; https://github.com/leoliu/ggtags/issues/22, so
 334                 ;; let's help it out.
 335                 (when-let (gtags (locate-dominating-file
 336                                   default-directory
 337                                   (lambda (dir)
 338                                     (file-regular-p (expand-file-name "GTAGS" dir)))))
 339                   ;; `file-truename' may strip the trailing '/' on
 340                   ;; remote hosts, see http://debbugs.gnu.org/16851
 341                   (file-name-as-directory (file-truename gtags)))))
 342       (when ggtags-project-root
 343         (if (gethash ggtags-project-root ggtags-projects)
 344             (ggtags-find-project)
 345           (ggtags-make-project ggtags-project-root))))))
 346
 347 (defun ggtags-current-project-root ()
 348   (and (ggtags-find-project)
 349        (ggtags-project-root (ggtags-find-project))))
 350
 351 (defun ggtags-check-project ()
 352   (or (ggtags-find-project) (error "File GTAGS not found")))
 353
 354 (defun ggtags-ensure-project ()
 355   (or (ggtags-find-project)
 356       (when (or (yes-or-no-p "File GTAGS not found; run gtags? ")
 357                 (user-error "Aborted"))
 358         (call-interactively #'ggtags-create-tags)
 359         ;; Need checking because `ggtags-create-tags' can create tags
 360         ;; in any directory.
 361         (ggtags-check-project))))
 362
 363 (defvar delete-trailing-lines)          ;new in 24.3
 364
 365 (defun ggtags-save-project-settings (&optional noconfirm)
 366   "Save Gnu Global's specific environment variables."
 367   (interactive "P")
 368   (ggtags-check-project)
 369   (let* ((inhibit-read-only t)          ; for `add-dir-local-variable'
 370          (default-directory (ggtags-current-project-root))
 371          ;; Not using `ggtags-with-current-project' to preserve
 372          ;; environment variables that may be present in
 373          ;; `ggtags-process-environment'.
 374          (process-environment
 375           (append ggtags-process-environment
 376                   process-environment
 377                   (and (not (ggtags-project-has-refs (ggtags-find-project)))
 378                        (list "GTAGSLABEL=ctags"))))
 379          (envlist (delete-dups
 380                    (loop for x in process-environment
 381                          when (string-match
 382                                "^\\(GTAGS[^=\n]*\\|MAKEOBJDIRPREFIX\\)=" x)
 383                          ;; May have duplicates thus `delete-dups'.
 384                          collect (concat (match-string 1 x)
 385                                          "="
 386                                          (getenv (match-string 1 x))))))
 387          (help-form (format "y: save\nn: don't save\n=: diff\n?: help\n")))
 388     (add-dir-local-variable nil 'ggtags-process-environment envlist)
 389     ;; Remove trailing newlines by `add-dir-local-variable'.
 390     (let ((delete-trailing-lines t)) (delete-trailing-whitespace))
 391     (or noconfirm
 392         (while (pcase (read-char-choice
 393                        (format "Save `%s'? (y/n/=/?) " buffer-file-name)
 394                        '(?y ?n ?= ??))
 395                  ;; ` required for 24.1 and 24.2
 396                  (`?n (user-error "Aborted"))
 397                  (`?y nil)
 398                  (`?= (diff-buffer-with-file) 'loop)
 399                  (`?? (help-form-show) 'loop))))
 400     (save-buffer)
 401     (kill-buffer)))
 402
 403 (defun ggtags-toggle-project-read-only ()
 404   (interactive)
 405   (ggtags-check-project)
 406   (let ((inhibit-read-only t)           ; for `add-dir-local-variable'
 407         (val (not buffer-read-only))
 408         (default-directory (ggtags-current-project-root)))
 409     (add-dir-local-variable nil 'buffer-read-only val)
 410     (save-buffer)
 411     (kill-buffer)
 412     (when buffer-file-name
 413       (setq buffer-read-only val))
 414     (when (called-interactively-p 'interactive)
 415       (message "Project read-only-mode is %s" (if val "on" "off")))
 416     val))
 417
 418 (defun ggtags-visit-project-root ()
 419   (interactive)
 420   (ggtags-check-project)
 421   (dired (ggtags-current-project-root)))
 422
 423 (defmacro ggtags-with-current-project (&rest body)
 424   "Eval BODY in current project's `process-environment'."
 425   (declare (debug t))
 426   (let ((gtagsroot (make-symbol "-gtagsroot-"))
 427         (root (make-symbol "-ggtags-project-root-")))
 428     `(let* ((,root ggtags-project-root)
 429             (,gtagsroot (when (ggtags-find-project)
 430                           (directory-file-name (ggtags-current-project-root))))
 431             (process-environment
 432              (append (let ((process-environment process-environment))
 433                        (and ,gtagsroot (setenv "GTAGSROOT" ,gtagsroot))
 434                        (mapcar #'substitute-env-vars ggtags-process-environment))
 435                      process-environment
 436                      (and ,gtagsroot (list (concat "GTAGSROOT=" ,gtagsroot)))
 437                      (and (ggtags-find-project)
 438                           (not (ggtags-project-has-refs (ggtags-find-project)))
 439                           (list "GTAGSLABEL=ctags")))))
 440        (unwind-protect (save-current-buffer ,@body)
 441          (setq ggtags-project-root ,root)))))
 442
 443 (defun ggtags-get-libpath ()
 444   (when-let (path (ggtags-with-current-project (getenv "GTAGSLIBPATH")))
 445     (mapcar (apply-partially #'concat (file-remote-p default-directory))
 446             (split-string path (regexp-quote path-separator) t))))
 447
 448 (defun ggtags-create-tags (root)
 449   "Run `gtags' in directory ROOT to create tag files."
 450   (interactive "DRoot directory: ")
 451   (let ((process-environment process-environment))
 452     (when (zerop (length root)) (error "No root directory provided"))
 453     (setenv "GTAGSROOT"
 454             (directory-file-name (file-name-as-directory root)))
 455     (ggtags-with-current-project
 456      (and (not (getenv "GTAGSLABEL"))
 457           (yes-or-no-p "Use `ctags' backend? ")
 458           (setenv "GTAGSLABEL" "ctags"))
 459      (with-temp-message "`gtags' in progress..."
 460        (let ((default-directory (file-name-as-directory root)))
 461          (condition-case err
 462              (apply #'ggtags-process-string
 463                     "gtags" (and ggtags-use-idutils '("--idutils")))
 464            (error (if (and ggtags-use-idutils
 465                            (stringp (cadr err))
 466                            (string-match-p "mkid not found" (cadr err)))
 467                       ;; Retry without mkid
 468                       (ggtags-process-string "gtags")
 469                     (signal (car err) (cdr err))))))))
 470     (message "GTAGS generated in `%s'" root)
 471     root))
 472
 473 (defun ggtags-update-tags (&optional force)
 474   "Update GNU Global tag database.
 475 Do nothing if GTAGS exceeds the oversize limit unless FORCE is
 476 non-nil."
 477   (interactive (progn
 478                  (ggtags-check-project)
 479                  ;; Mark project info expired.
 480                  (setf (ggtags-project-timestamp (ggtags-find-project)) -1)
 481                  (list t)))
 482   (when (or force (and (ggtags-find-project)
 483                        (not (ggtags-project-oversize-p))
 484                        (ggtags-project-dirty-p (ggtags-find-project))))
 485     (ggtags-with-current-project
 486      (with-temp-message "`global -u' in progress..."
 487        (ggtags-process-string "global" "-u")
 488        (setf (ggtags-project-dirty-p (ggtags-find-project)) nil)))))
 489
 490 (defvar-local ggtags-completion-cache nil)
 491
 492 (defvar ggtags-completion-table
 493   (completion-table-dynamic
 494    (lambda (prefix)
 495      (unless (equal prefix (car ggtags-completion-cache))
 496        (setq ggtags-completion-cache
 497              (cons prefix
 498                    (ggtags-with-current-project
 499                     (split-string
 500                      (apply #'ggtags-process-string
 501                             "global"
 502                             ;; Note -c alone returns only definitions
 503                             (if completion-ignore-case
 504                                 (list "--ignore-case" "-Tc" prefix)
 505                               (list "-Tc" prefix)))
 506                      "\n" t)))))
 507      (cdr ggtags-completion-cache))))
 508
 509 (defun ggtags-completion-at-point ()
 510   "A function for `completion-at-point-functions'."
 511   (when-let (bounds (funcall ggtags-bounds-of-tag-function))
 512     (and (< (car bounds) (cdr bounds))
 513          (list (car bounds) (cdr bounds) ggtags-completion-table))))
 514
 515 (defun ggtags-read-tag ()
 516   (ggtags-ensure-project)
 517   (let ((default (ggtags-tag-at-point))
 518         (completing-read-function ggtags-completing-read-function))
 519     (setq ggtags-current-tag-name
 520           (cond (current-prefix-arg
 521                  (ggtags-update-tags)
 522                  (completing-read
 523                   (format (if default "Tag (default %s): " "Tag: ") default)
 524                   ggtags-completion-table nil t nil nil default))
 525                 ((not default)
 526                  (user-error "No tag at point"))
 527                 (t (substring-no-properties default))))))
 528
 529 (defun ggtags-global-build-command (cmd &rest args)
 530   ;; CMD can be definition, reference, symbol, grep, idutils
 531   (let ((xs (append (list "global" "-v"
 532                           (format "--result=%s" ggtags-global-output-format)
 533                           (and ggtags-global-ignore-case "--ignore-case")
 534                           (and (ggtags-find-project)
 535                                (ggtags-project-has-color (ggtags-find-project))
 536                                "--color")
 537                           (and (ggtags-find-project)
 538                                (ggtags-project-has-path-style (ggtags-find-project))
 539                                "--path-style=shorter")
 540                           (and ggtags-global-treat-text "--other")
 541                           (pcase cmd
 542                             ((pred stringp) cmd)
 543                             (`definition "") ;-d not supported by Global 5.7.1
 544                             (`reference "-r")
 545                             (`symbol "-s")
 546                             (`path "--path")
 547                             (`grep "--grep")
 548                             (`idutils "--idutils")))
 549                     args)))
 550     (mapconcat #'identity (delq nil xs) " ")))
 551
 552 ;; takes three values: nil, t and a marker
 553 (defvar ggtags-global-start-marker nil)
 554
 555 (defvar ggtags-global-exit-status 0)
 556 (defvar ggtags-global-match-count 0)
 557
 558 (defvar ggtags-tag-ring-index nil)
 559
 560 (defun ggtags-global-save-start-marker ()
 561   (when (markerp ggtags-global-start-marker)
 562     (setq ggtags-tag-ring-index nil)
 563     (ring-insert find-tag-marker-ring ggtags-global-start-marker)
 564     (setq ggtags-global-start-marker t)))
 565
 566 (defun ggtags-global-start (command &optional root)
 567   (let* ((default-directory (or root (ggtags-current-project-root)))
 568          (split-window-preferred-function ggtags-split-window-function)
 569          ;; See http://debbugs.gnu.org/13594
 570          (display-buffer-overriding-action
 571           (if (and ggtags-auto-jump-to-first-match
 572                    ;; Appeared in emacs 24.4.
 573                    (fboundp 'display-buffer-no-window))
 574               (list #'display-buffer-no-window)
 575             display-buffer-overriding-action)))
 576     (setq ggtags-global-start-marker (point-marker))
 577     (ggtags-navigation-mode +1)
 578     (setq ggtags-global-exit-status 0
 579           ggtags-global-match-count 0)
 580     (ggtags-update-tags)
 581     (ggtags-with-current-project
 582      (setq ggtags-global-last-buffer
 583            (compilation-start command 'ggtags-global-mode)))))
 584
 585 (defun ggtags-find-tag-continue ()
 586   (interactive)
 587   (ggtags-ensure-global-buffer
 588     (ggtags-navigation-mode +1)
 589     (let ((split-window-preferred-function ggtags-split-window-function))
 590       (ignore-errors (compilation-next-error 1))
 591       (compile-goto-error))))
 592
 593 (defun ggtags-find-tag (cmd &rest args)
 594   (ggtags-check-project)
 595   (ggtags-global-start (apply #'ggtags-global-build-command cmd args)))
 596
 597 ;;;###autoload
 598 (defun ggtags-find-tag-dwim (name &optional definition)
 599   "Find definitions or references of tag NAME by context.
 600 If point is at a definition tag, find references, and vice versa.
 601 With a prefix arg (non-nil DEFINITION) always find definitions."
 602   (interactive (list (ggtags-read-tag) current-prefix-arg))
 603   (ggtags-check-project)     ; for `ggtags-current-project-root' below
 604   (if (or definition
 605           (not buffer-file-name)
 606           (and (ggtags-find-project)
 607                (not (ggtags-project-has-refs (ggtags-find-project)))))
 608       (ggtags-find-tag 'definition name)
 609     (ggtags-find-tag
 610      (format "--from-here=%d:%s"
 611              (line-number-at-pos)
 612              (shell-quote-argument
 613               ;; Note `ggtags-global-start' binds default-directory to
 614               ;; project root.
 615               (file-relative-name
 616                buffer-file-name
 617                (if (string-prefix-p (ggtags-current-project-root)
 618                                     buffer-file-name)
 619                    (ggtags-current-project-root)
 620                  (locate-dominating-file buffer-file-name "GTAGS")))))
 621      name)))
 622
 623 (defun ggtags-find-reference (name)
 624   (interactive (list (ggtags-read-tag)))
 625   (ggtags-find-tag 'reference name))
 626
 627 (defun ggtags-find-other-symbol (name)
 628   "Find tag NAME that is a reference without a definition."
 629   (interactive (list (ggtags-read-tag)))
 630   (ggtags-find-tag 'symbol name))
 631
 632 (defun ggtags-read-string (prompt)
 633   "Like `read-string' but handle default automatically."
 634   (ggtags-ensure-project)
 635   (let ((prompt (if (string-match ": *\\'" prompt)
 636                     (substring prompt 0 (match-beginning 0))
 637                   prompt))
 638         (default (ggtags-tag-at-point)))
 639     (read-string (format (if default "%s (default `%s'): " "%s: ")
 640                          prompt default)
 641                  nil nil default)))
 642
 643 (defun ggtags-quote-pattern (pattern)
 644   (prin1-to-string (substring-no-properties pattern)))
 645
 646 (defun ggtags-grep (pattern &optional invert-match)
 647   "Use `global --grep' to search for lines matching PATTERN.
 648 Invert the match when called with a prefix arg \\[universal-argument]."
 649   (interactive (list (ggtags-read-string (if current-prefix-arg
 650                                              "Inverted grep pattern"
 651                                            "Grep pattern"))
 652                      current-prefix-arg))
 653   (ggtags-find-tag 'grep (and invert-match "--invert-match")
 654                    "--" (ggtags-quote-pattern pattern)))
 655
 656 (defun ggtags-idutils-query (pattern)
 657   (interactive (list (ggtags-read-string "ID query pattern")))
 658   (ggtags-find-tag 'idutils "--" (ggtags-quote-pattern pattern)))
 659
 660 (defun ggtags-find-file (pattern &optional invert-match)
 661   (interactive (list (ggtags-read-string (if current-prefix-arg
 662                                              "Inverted path pattern"
 663                                            "Path pattern"))
 664                      current-prefix-arg))
 665   (let ((ggtags-global-output-format 'path))
 666     (ggtags-find-tag 'path (and invert-match "--invert-match")
 667                      "--" (ggtags-quote-pattern pattern))))
 668
 669 ;; NOTE: Coloured output in grep requested: http://goo.gl/Y9IcX
 670 (defun ggtags-find-tag-regexp (regexp directory)
 671   "List tags matching REGEXP in DIRECTORY (default to project root)."
 672   (interactive
 673    (progn
 674      (ggtags-check-project)
 675      (list (ggtags-read-string "POSIX regexp")
 676            (if current-prefix-arg
 677                (read-directory-name "Directory: " nil nil t)
 678              (ggtags-current-project-root)))))
 679   (ggtags-check-project)
 680   (ggtags-global-start
 681    (ggtags-global-build-command nil nil "-l" "--" (ggtags-quote-pattern regexp))
 682    (file-name-as-directory directory)))
 683
 684 (defun ggtags-query-replace (from to &optional delimited)
 685   "Query replace FROM with TO on files in the Global buffer.
 686 If not in navigation mode, do a grep on FROM first.
 687
 688 Note: the regular expression FROM must be supported by both
 689 Global and Emacs."
 690   (interactive
 691    ;; Note: in 24.4 query-replace-read-args returns a list of 4 elements.
 692    (let ((args (query-replace-read-args "Query replace (regexp)" t t)))
 693      (list (nth 0 args) (nth 1 args) (nth 2 args))))
 694   (unless (bound-and-true-p ggtags-navigation-mode)
 695     (let ((ggtags-auto-jump-to-first-match nil))
 696       (ggtags-grep from)))
 697   (let ((file-form
 698          '(let ((files))
 699             (ggtags-ensure-global-buffer
 700               (with-temp-message "Waiting for Grep to finish..."
 701                 (while (get-buffer-process (current-buffer))
 702                   (sit-for 0.2)))
 703               (goto-char (point-min))
 704               (while (ignore-errors (compilation-next-file 1) t)
 705                 (let ((m (get-text-property (point) 'compilation-message)))
 706                   (push (expand-file-name
 707                          (caar (compilation--loc->file-struct
 708                                 (compilation--message->loc m))))
 709                         files))))
 710             (ggtags-navigation-mode -1)
 711             (nreverse files))))
 712     (tags-query-replace from to delimited file-form)))
 713
 714 (defun ggtags-delete-tag-files ()
 715   "Delete the tag files generated by gtags."
 716   (interactive (ignore (ggtags-check-project)))
 717   (when (ggtags-current-project-root)
 718     (let* ((re (concat "\\`" (regexp-opt '("GPATH" "GRTAGS" "GTAGS" "ID")) "\\'"))
 719            (files (loop for file in (directory-files (ggtags-current-project-root) t re)
 720                         ;; Don't trust `directory-files'.
 721                         when (let ((case-fold-search nil))
 722                                (string-match-p re (file-name-nondirectory file)))
 723                         collect file))
 724            (buffer "*GTags File List*"))
 725       (or files (user-error "No tag files found"))
 726       (with-output-to-temp-buffer buffer
 727         (princ (mapconcat #'identity files "\n")))
 728       (let ((win (get-buffer-window buffer)))
 729         (unwind-protect
 730             (progn
 731               (fit-window-to-buffer win)
 732               (when (yes-or-no-p "Remove GNU Global tag files? ")
 733                 (with-demoted-errors (mapc #'delete-file files))
 734                 (remhash (ggtags-current-project-root) ggtags-projects)
 735                 (and (overlayp ggtags-highlight-tag-overlay)
 736                      (delete-overlay ggtags-highlight-tag-overlay))))
 737           (when (window-live-p win)
 738             (quit-window t win)))))))
 739
 740 (defun ggtags-browse-file-as-hypertext (file line)
 741   "Browse FILE in hypertext (HTML) form."
 742   (interactive (if (or current-prefix-arg (not buffer-file-name))
 743                    (list (read-file-name "Browse file: " nil nil t)
 744                          (read-number "Line: " 1))
 745                  (list buffer-file-name (line-number-at-pos))))
 746   (check-type line integer)
 747   (or (and file (file-exists-p file)) (error "File `%s' doesn't exist" file))
 748   (ggtags-check-project)
 749   (or (file-exists-p (expand-file-name "HTML" (ggtags-current-project-root)))
 750       (if (yes-or-no-p "No hypertext form exists; run htags? ")
 751           (let ((default-directory (ggtags-current-project-root)))
 752             (ggtags-with-current-project (ggtags-process-string "htags")))
 753         (user-error "Aborted")))
 754   (let ((url (ggtags-process-string "gozilla" "-p" (format "+%d" line)
 755                                     (file-relative-name file))))
 756     (or (equal (file-name-extension
 757                 (url-filename (url-generic-parse-url url))) "html")
 758         (user-error "No hypertext form for `%s'" file))
 759     (when (called-interactively-p 'interactive)
 760       (message "Browsing %s" url))
 761     (browse-url url)))
 762
 763 (defun ggtags-next-mark (&optional arg)
 764   "Move to the next (newer) mark in the tag marker ring."
 765   (interactive)
 766   (and (ring-empty-p find-tag-marker-ring) (user-error "Tag ring empty"))
 767   (setq ggtags-tag-ring-index
 768         ;; Note `ring-minus1' gets newer item.
 769         (funcall (if arg #'ring-plus1 #'ring-minus1)
 770                  (or ggtags-tag-ring-index
 771                      (progn
 772                        (ring-insert find-tag-marker-ring (point-marker))
 773                        0))
 774                  (ring-length find-tag-marker-ring)))
 775   (let ((m (ring-ref find-tag-marker-ring ggtags-tag-ring-index))
 776         (i (- (ring-length find-tag-marker-ring) ggtags-tag-ring-index))
 777         (message-log-max nil))
 778     (message "%d%s marker%s" i (pcase (mod i 10)
 779                                  ;; ` required for 24.1 and 24.2
 780                                  (`1 "st")
 781                                  (`2 "nd")
 782                                  (`3 "rd")
 783                                  (_ "th"))
 784              (if (marker-buffer m) "" " (dead)"))
 785     (if (not (marker-buffer m))
 786         (ding)
 787       (switch-to-buffer (marker-buffer m))
 788       (goto-char m))))
 789
 790 (defun ggtags-prev-mark ()
 791   "Move to the previous (older) mark in the tag marker ring."
 792   (interactive)
 793   (ggtags-next-mark 'previous))
 794
 795 (defun ggtags-view-tag-history ()
 796   (interactive)
 797   (and (ring-empty-p find-tag-marker-ring)
 798        (user-error "Tag ring empty"))
 799   (let ((split-window-preferred-function ggtags-split-window-function)
 800         (inhibit-read-only t))
 801     (pop-to-buffer "*Tag Ring*")
 802     (erase-buffer)
 803     (tabulated-list-mode)
 804     (setq tabulated-list-entries
 805           ;; Use a function so that revert can work properly.
 806           (lambda ()
 807             (let ((counter (ring-length find-tag-marker-ring))
 808                   (elements (or (ring-elements find-tag-marker-ring)
 809                                 (user-error "Tag ring empty")))
 810                   (action
 811                    (lambda (button) (interactive)
 812                      (let ((m (button-get button 'marker)))
 813                        (or (markerp m) (user-error "Marker dead"))
 814                        (setq ggtags-tag-ring-index
 815                              (ring-member find-tag-marker-ring m))
 816                        (pop-to-buffer (marker-buffer m))
 817                        (goto-char (marker-position m)))))
 818                   (get-line
 819                    (lambda (m)
 820                      (with-current-buffer (marker-buffer m)
 821                        (save-excursion
 822                          (goto-char m)
 823                          (buffer-substring (line-beginning-position)
 824                                            (line-end-position)))))))
 825               (setq tabulated-list-format
 826                     `[("ID" ,(max (1+ (floor (log counter 10))) 2)
 827                        (lambda (x y) (< (car x) (car y))))
 828                       ("Buffer" ,(max (loop for m in elements
 829                                             for b = (marker-buffer m)
 830                                             maximize
 831                                             (length (and b (buffer-name b))))
 832                                       6)
 833                        t :right-align t)
 834                       ("Position" ,(max (loop for m in elements
 835                                               for p = (or (marker-position m) 1)
 836                                               maximize (1+ (floor (log p 10))))
 837                                         8)
 838                        (lambda (x y)
 839                          (< (string-to-number (aref (cadr x) 2))
 840                             (string-to-number (aref (cadr y) 2))))
 841                        :right-align t)
 842                       ("Contents" 100 t)])
 843               (tabulated-list-init-header)
 844               (mapcar (lambda (x)
 845                         (prog1
 846                             (list counter
 847                                   (if (marker-buffer x)
 848                                       (vector (number-to-string counter)
 849                                               `(,(buffer-name (marker-buffer x))
 850                                                 face link
 851                                                 follow-link t
 852                                                 marker ,x
 853                                                 action ,action)
 854                                               (number-to-string (marker-position x))
 855                                               (funcall get-line x))
 856                                     (vector (number-to-string counter)
 857                                             "(dead)" "?" "?")))
 858                           (decf counter)))
 859                       elements))))
 860     (setq tabulated-list-sort-key '("ID" . t))
 861     (tabulated-list-print)
 862     (fit-window-to-buffer)))
 863
 864 (defun ggtags-global-exit-message-function (_process-status exit-status msg)
 865   (setq ggtags-global-exit-status exit-status)
 866   (pcase-let ((`(,count . ,db)
 867                (save-excursion
 868                  (goto-char (point-max))
 869                  (if (re-search-backward
 870                       "^\\w+ \\(not found\\)\\|^\\([0-9]+\\) \\w+ located" nil t)
 871                      (cons (or (and (match-string 1) 0)
 872                                (string-to-number (match-string 2)))
 873                            (when (re-search-forward
 874                                   "using \\(?:\\(idutils\\)\\|'[^']*/\\(\\w+\\)'\\)"
 875                                   (line-end-position)
 876                                   t)
 877                              (or (and (match-string 1) "ID")
 878                                  (match-string 2))))
 879                    (cons 0 nil)))))
 880     (setq ggtags-global-match-count count)
 881     ;; Clear the start marker in case of zero matches.
 882     (and (zerop count)
 883          (markerp ggtags-global-start-marker)
 884          (setq ggtags-global-start-marker nil))
 885     (cons (if (> exit-status 0)
 886               msg
 887             (format "found %d %s"
 888                     count
 889                     (funcall (if (= count 1) #'car #'cadr)
 890                              (pcase db
 891                                ;; ` required for 24.1 and 24.2
 892                                (`"GTAGS"  '("definition" "definitions"))
 893                                (`"GSYMS"  '("symbol"     "symbols"))
 894                                (`"GRTAGS" '("reference"  "references"))
 895                                (`"GPATH"  '("file"  "files"))
 896                                (`"ID"     '("identifier" "identifiers"))
 897                                (_         '("match"      "matches"))))))
 898           exit-status)))
 899
 900 ;;; NOTE: Must not match the 'Global started at Mon Jun 3 10:24:13'
 901 ;;; line or `compilation-auto-jump' will jump there and fail. See
 902 ;;; comments before the 'gnu' entry in
 903 ;;; `compilation-error-regexp-alist-alist'.
 904 (defvar ggtags-global-error-regexp-alist-alist
 905   (append
 906    '((path "^\\(?:[^/\n]*/\\)?[^ )\t\n]+$" 0)
 907      ;; ACTIVE_ESCAPE   src/dialog.cc   172
 908      (ctags "^\\([^ \t\n]+\\)[ \t]+\\(.*?\\)[ \t]+\\([0-9]+\\)$"
 909             2 3 nil nil 2 (1 font-lock-function-name-face))
 910      ;; ACTIVE_ESCAPE     172 src/dialog.cc    #undef ACTIVE_ESCAPE
 911      (ctags-x "^\\([^ \t\n]+\\)[ \t]+\\([0-9]+\\)[ \t]+\\(\\(?:[^/\n]*/\\)?[^ \t\n]+\\)"
 912               3 2 nil nil 3 (1 font-lock-function-name-face))
 913      ;; src/dialog.cc:172:#undef ACTIVE_ESCAPE
 914      (grep "^\\(.+?\\):\\([0-9]+\\):\\(?:$\\|[^0-9\n]\\|[0-9][^0-9\n]\\|[0-9][0-9].\\)"
 915            1 2 nil nil 1)
 916      ;; src/dialog.cc ACTIVE_ESCAPE 172 #undef ACTIVE_ESCAPE
 917      (cscope "^\\(.+?\\)[ \t]+\\([^ \t\n]+\\)[ \t]+\\([0-9]+\\).*\\(?:[^0-9\n]\\|[^0-9\n][0-9]\\|[^:\n][0-9][0-9]\\)$"
 918              1 3 nil nil 1 (2 font-lock-function-name-face)))
 919    compilation-error-regexp-alist-alist))
 920
 921 (defun ggtags-abbreviate-file (start end)
 922   (let ((inhibit-read-only t)
 923         (amount (if (numberp ggtags-global-abbreviate-filename)
 924                     (- (- end start) ggtags-global-abbreviate-filename)
 925                   999))
 926         (advance-word (lambda ()
 927                         "Return the length of the text made invisible."
 928                         (let ((wend (min end (progn (forward-word 1) (point))))
 929                               (wbeg (max start (progn (backward-word 1) (point)))))
 930                           (goto-char wend)
 931                           (if (<= (- wend wbeg) 1)
 932                               0
 933                             (put-text-property (1+ wbeg) wend 'invisible t)
 934                             (1- (- wend wbeg)))))))
 935     (goto-char start)
 936     (while (and (> amount 0) (> end (point)))
 937       (decf amount (funcall advance-word)))))
 938
 939 (defun ggtags-abbreviate-files (start end)
 940   (goto-char start)
 941   (let* ((error-re (cdr (assq ggtags-global-output-format
 942                               ggtags-global-error-regexp-alist-alist)))
 943          (sub (cadr error-re)))
 944     (when (and ggtags-global-abbreviate-filename error-re)
 945       (while (re-search-forward (car error-re) end t)
 946         (when (and (or (not (numberp ggtags-global-abbreviate-filename))
 947                        (> (length (match-string sub))
 948                           ggtags-global-abbreviate-filename))
 949                    ;; Ignore bogus file lines such as:
 950                    ;;     Global found 2 matches at Thu Jan 31 13:45:19
 951                    (get-text-property (match-beginning sub) 'compilation-message))
 952           (ggtags-abbreviate-file (match-beginning sub) (match-end sub)))))))
 953
 954 (defvar-local ggtags-global-output-lines 0)
 955
 956 (defun ggtags-global--display-buffer (&optional buffer)
 957   (let ((buffer (or buffer (current-buffer))))
 958     (unless (get-buffer-window buffer)
 959       (let* ((split-window-preferred-function ggtags-split-window-function)
 960              (w (display-buffer (current-buffer) '(nil (allow-no-window . t)))))
 961         (and w (compilation-set-window-height w))))))
 962
 963 (defun ggtags-global-filter ()
 964   "Called from `compilation-filter-hook' (which see)."
 965   (ansi-color-apply-on-region compilation-filter-start (point))
 966   ;; Get rid of line "Using config file '/PATH/TO/.globalrc'." or
 967   ;; "Using default configuration."
 968   (when (re-search-backward
 969          "^ *Using \\(?:config file '.*\\|default configuration.\\)\n"
 970          compilation-filter-start t)
 971     (replace-match ""))
 972   (incf ggtags-global-output-lines
 973         (count-lines compilation-filter-start (point)))
 974   (when (> ggtags-global-output-lines 5)
 975     (ggtags-global--display-buffer))
 976   (make-local-variable 'ggtags-global-large-output)
 977   (when (> ggtags-global-output-lines ggtags-global-large-output)
 978     (incf ggtags-global-large-output 500)
 979     (let ((message-log-max nil))
 980       (message "Output %d lines (Type `C-c C-k' to cancel)"
 981                ggtags-global-output-lines))))
 982
 983 (defun ggtags-handle-single-match (buf _how)
 984   (if (not (zerop ggtags-global-exit-status))
 985       ;; If exit abnormally display the buffer for inspection.
 986       (ggtags-global--display-buffer)
 987     (when (and ggtags-auto-jump-to-first-match
 988                (save-excursion
 989                  (goto-char (point-min))
 990                  (not (ignore-errors
 991                         (goto-char (compilation-next-single-property-change
 992                                     (point) 'compilation-message))
 993                         (end-of-line)
 994                         (compilation-next-single-property-change
 995                          (point) 'compilation-message)))))
 996       ;; For the `compilation-auto-jump' in idle timer to run. See also:
 997       ;; http://debbugs.gnu.org/13829
 998       (sit-for 0)
 999       (ggtags-navigation-mode -1)
1000       (ggtags-navigation-mode-cleanup buf 0))))
1001
1002 (defvar ggtags-global-mode-font-lock-keywords
1003   '(("^Global \\(exited abnormally\\|interrupt\\|killed\\|terminated\\)\\(?:.*with code \\([0-9]+\\)\\)?.*"
1004      (1 'compilation-error)
1005      (2 'compilation-error nil t))
1006     ("^Global found \\([0-9]+\\)" (1 compilation-info-face))))
1007
1008 (defvar compilation-always-kill)        ;new in 24.3
1009
1010 (define-compilation-mode ggtags-global-mode "Global"
1011   "A mode for showing outputs from gnu global."
1012   ;; Make it buffer local for `ggtags-abbreviate-files'.
1013   (make-local-variable 'ggtags-global-output-format)
1014   (setq-local compilation-error-regexp-alist
1015               (list ggtags-global-output-format))
1016   (setq-local compilation-auto-jump-to-first-error
1017               ggtags-auto-jump-to-first-match)
1018   (setq-local compilation-scroll-output 'first-error)
1019   (setq-local compilation-disable-input t)
1020   (setq-local compilation-always-kill t)
1021   (setq-local compilation-error-face 'compilation-info)
1022   (setq-local compilation-exit-message-function
1023               'ggtags-global-exit-message-function)
1024   ;; See: https://github.com/leoliu/ggtags/issues/26
1025   (setq-local find-file-suppress-same-file-warnings t)
1026   (setq-local truncate-lines t)
1027   (jit-lock-register #'ggtags-abbreviate-files)
1028   (add-hook 'compilation-filter-hook 'ggtags-global-filter nil 'local)
1029   (add-hook 'compilation-finish-functions 'ggtags-handle-single-match nil t)
1030   (add-hook 'kill-buffer-hook (lambda () (ggtags-navigation-mode -1)) nil t))
1031
1032 ;; NOTE: Need this to avoid putting menu items in
1033 ;; `emulation-mode-map-alists', which creates double entries. See
1034 ;; http://i.imgur.com/VJJTzVc.png
1035 (defvar ggtags-navigation-map
1036   (let ((map (make-sparse-keymap)))
1037     (define-key map "\M-n" 'next-error)
1038     (define-key map "\M-p" 'previous-error)
1039     (define-key map "\M-}" 'ggtags-navigation-next-file)
1040     (define-key map "\M-{" 'ggtags-navigation-previous-file)
1041     (define-key map "\M->" 'ggtags-navigation-last-error)
1042     (define-key map "\M-<" 'ggtags-navigation-first-error)
1043     (define-key map "\C-c\C-k"
1044       (lambda () (interactive)
1045         (ggtags-ensure-global-buffer (kill-compilation))))
1046     (define-key map "\M-o" 'ggtags-navigation-visible-mode)
1047     (define-key map [return] 'ggtags-navigation-mode-done)
1048     (define-key map "\r" 'ggtags-navigation-mode-done)
1049     (define-key map [remap pop-tag-mark] 'ggtags-navigation-mode-abort)
1050     map))
1051
1052 (defvar ggtags-mode-map-alist
1053   `((ggtags-navigation-mode . ,ggtags-navigation-map)))
1054
1055 ;; Higher priority for `ggtags-navigation-mode' to avoid being
1056 ;; hijacked by modes such as `view-mode'.
1057 (add-to-list 'emulation-mode-map-alists 'ggtags-mode-map-alist)
1058
1059 (defvar ggtags-navigation-mode-map
1060   (let ((map (make-sparse-keymap))
1061         (menu (make-sparse-keymap "GG-Navigation")))
1062     ;; Menu items: (info "(elisp)Extended Menu Items")
1063     (define-key map [menu-bar ggtags-navigation] (cons "GG-Navigation" menu))
1064     ;; Ordered backwards
1065     (define-key menu [visible-mode]
1066       '(menu-item "Visible mode" ggtags-navigation-visible-mode
1067                   :button (:toggle . (ignore-errors
1068                                        (ggtags-ensure-global-buffer
1069                                          visible-mode)))))
1070     (define-key menu [done]
1071       '(menu-item "Finish navigation" ggtags-navigation-mode-done))
1072     (define-key menu [abort]
1073       '(menu-item "Abort" ggtags-navigation-mode-abort))
1074     (define-key menu [last-error]
1075       '(menu-item "Last error" ggtags-navigation-last-error))
1076     (define-key menu [fist-error]
1077       '(menu-item "Fist error" ggtags-navigation-first-error))
1078     (define-key menu [previous-file]
1079       '(menu-item "Previous file" ggtags-navigation-previous-file))
1080     (define-key menu [next-file]
1081       '(menu-item "Next file" ggtags-navigation-next-file))
1082     (define-key menu [previous]
1083       '(menu-item "Previous match" previous-error))
1084     (define-key menu [next]
1085       '(menu-item "Next match" next-error))
1086     map))
1087
1088 (defun ggtags-move-to-tag (&optional name)
1089   "Move to NAME tag in current line."
1090   (let ((orig (point))
1091         (tag (or name ggtags-current-tag-name)))
1092     (beginning-of-line)
1093     (if (and tag (re-search-forward
1094                   (concat "\\_<" (regexp-quote tag) "\\_>")
1095                   (line-end-position)
1096                   t))
1097         (goto-char (match-beginning 0))
1098       (goto-char orig))))
1099
1100 (defun ggtags-navigation-mode-cleanup (&optional buf time)
1101   (let ((buf (or buf ggtags-global-last-buffer)))
1102     (and (buffer-live-p buf)
1103          (with-current-buffer buf
1104            (when (get-buffer-process (current-buffer))
1105              (kill-compilation))
1106            (when (and (derived-mode-p 'ggtags-global-mode)
1107                       (get-buffer-window))
1108              (quit-window nil (get-buffer-window)))
1109            (and time (run-with-idle-timer time nil #'kill-buffer buf))))))
1110
1111 (defun ggtags-navigation-mode-done ()
1112   (interactive)
1113   (ggtags-navigation-mode -1)
1114   (setq tags-loop-scan t
1115         tags-loop-operate '(ggtags-find-tag-continue))
1116   (ggtags-navigation-mode-cleanup))
1117
1118 (defun ggtags-navigation-mode-abort ()
1119   (interactive)
1120   (ggtags-navigation-mode -1)
1121   ;; Run after (ggtags-navigation-mode -1) or
1122   ;; ggtags-global-start-marker might not have been saved.
1123   (when (and ggtags-global-start-marker
1124              (not (markerp ggtags-global-start-marker)))
1125     (setq ggtags-global-start-marker nil)
1126     (pop-tag-mark))
1127   (ggtags-navigation-mode-cleanup nil 0))
1128
1129 (defun ggtags-navigation-next-file (n)
1130   (interactive "p")
1131   (ggtags-ensure-global-buffer
1132     (compilation-next-file n)
1133     (compile-goto-error)))
1134
1135 (defun ggtags-navigation-previous-file (n)
1136   (interactive "p")
1137   (ggtags-navigation-next-file (- n)))
1138
1139 (defun ggtags-navigation-first-error ()
1140   (interactive)
1141   (ggtags-ensure-global-buffer
1142     (goto-char (point-min))
1143     (compilation-next-error 1)
1144     (compile-goto-error)))
1145
1146 (defun ggtags-navigation-last-error ()
1147   (interactive)
1148   (ggtags-ensure-global-buffer
1149     (goto-char (point-max))
1150     (compilation-previous-error 1)
1151     (compile-goto-error)))
1152
1153 (defun ggtags-navigation-visible-mode (&optional arg)
1154   (interactive (list (or current-prefix-arg 'toggle)))
1155   (ggtags-ensure-global-buffer
1156     (visible-mode arg)))
1157
1158 (defvar ggtags-global-line-overlay nil)
1159
1160 (defun ggtags-global-next-error-hook ()
1161   (ggtags-move-to-tag)
1162   (ggtags-global-save-start-marker)
1163   (ignore-errors
1164     (ggtags-ensure-global-buffer
1165       (unless (overlayp ggtags-global-line-overlay)
1166         (setq ggtags-global-line-overlay (make-overlay (point) (point)))
1167         (overlay-put ggtags-global-line-overlay 'face 'ggtags-global-line))
1168       (move-overlay ggtags-global-line-overlay
1169                     (line-beginning-position) (line-end-position)
1170                     (current-buffer)))))
1171
1172 (define-minor-mode ggtags-navigation-mode nil
1173   :lighter
1174   (" GG[" (:eval
1175            (ignore-errors
1176              (ggtags-ensure-global-buffer
1177               (let ((index (when (get-text-property (line-beginning-position)
1178                                                     'compilation-message)
1179                              ;; Assume the first match appears at line 5
1180                              (- (line-number-at-pos) 4))))
1181                 `((:propertize ,(if index
1182                                     (number-to-string (max index 0))
1183                                   "?") face success) "/")))))
1184    (:propertize (:eval (number-to-string ggtags-global-match-count))
1185                 face success)
1186    (:eval
1187     (unless (zerop ggtags-global-exit-status)
1188       `(":" (:propertize ,(number-to-string ggtags-global-exit-status)
1189                          face error))))
1190    "]")
1191   :global t
1192   (if ggtags-navigation-mode
1193       (progn
1194         (add-hook 'next-error-hook 'ggtags-global-next-error-hook)
1195         (add-hook 'minibuffer-setup-hook 'ggtags-minibuffer-setup-function))
1196     (remove-hook 'next-error-hook 'ggtags-global-next-error-hook)
1197     (remove-hook 'minibuffer-setup-hook 'ggtags-minibuffer-setup-function)))
1198
1199 (defun ggtags-minibuffer-setup-function ()
1200   ;; Disable ggtags-navigation-mode in minibuffer.
1201   (setq-local ggtags-navigation-mode nil))
1202
1203 (defun ggtags-kill-file-buffers (&optional interactive)
1204   "Kill all buffers visiting files in current project."
1205   (interactive "p")
1206   (ggtags-check-project)
1207   (let ((directories (cons (ggtags-current-project-root) (ggtags-get-libpath)))
1208         (count 0)
1209         (some (lambda (pred list)
1210                 (loop for x in list when (funcall pred x) return it))))
1211     (dolist (buf (buffer-list))
1212       (let ((file (and (buffer-live-p buf)
1213                        (not (eq buf (current-buffer)))
1214                        (buffer-file-name buf))))
1215         (when (and file (funcall some
1216                                  (lambda (dir)
1217                                    ;; Don't use `file-in-directory-p'
1218                                    ;; to allow symbolic links.
1219                                    (string-prefix-p dir file))
1220                                  directories))
1221           (and (kill-buffer buf) (incf count)))))
1222     (and interactive
1223          (message "%d %s killed" count (if (= count 1) "buffer" "buffers")))))
1224
1225 (defun ggtags-after-save-function ()
1226   (when (ggtags-find-project)
1227     (setf (ggtags-project-dirty-p (ggtags-find-project)) t)
1228     ;; When oversize update on a per-save basis.
1229     (when (and buffer-file-name (ggtags-project-oversize-p))
1230       (ggtags-with-current-project
1231        (process-file "global" nil 0 nil "--single-update"
1232                      (file-relative-name buffer-file-name))))))
1233
1234 (defvar ggtags-mode-prefix-map
1235   (let ((m (make-sparse-keymap)))
1236     (define-key m "\M-'" 'previous-error)
1237     (define-key m (kbd "M-DEL") 'ggtags-delete-tag-files)
1238     (define-key m "\M-p" 'ggtags-prev-mark)
1239     (define-key m "\M-n" 'ggtags-next-mark)
1240     (define-key m "\M-f" 'ggtags-find-file)
1241     (define-key m "\M-o" 'ggtags-find-other-symbol)
1242     (define-key m "\M-g" 'ggtags-grep)
1243     (define-key m "\M-i" 'ggtags-idutils-query)
1244     (define-key m "\M-b" 'ggtags-browse-file-as-hypertext)
1245     (define-key m "\M-k" 'ggtags-kill-file-buffers)
1246     (define-key m "\M-h" 'ggtags-view-tag-history)
1247     (define-key m "\M-j" 'ggtags-visit-project-root)
1248     (define-key m (kbd "M-%") 'ggtags-query-replace)
1249     m))
1250
1251 (defvar ggtags-mode-map
1252   (let ((map (make-sparse-keymap))
1253         (menu (make-sparse-keymap "Ggtags")))
1254     (define-key map "\M-." 'ggtags-find-tag-dwim)
1255     (define-key map (kbd "M-]") 'ggtags-find-reference)
1256     (define-key map (kbd "C-M-.") 'ggtags-find-tag-regexp)
1257     (define-key map ggtags-mode-prefix-key ggtags-mode-prefix-map)
1258     ;; Menu items
1259     (define-key map [menu-bar ggtags] (cons "Ggtags" menu))
1260     ;; Ordered backwards
1261     (define-key menu [report-bugs]
1262       `(menu-item "Report bugs"
1263                   (lambda () (interactive)
1264                     (browse-url ggtags-bug-url)
1265                     (message "Please visit %s" ggtags-bug-url))
1266                   :help ,(format "Visit %s" ggtags-bug-url)))
1267     (define-key menu [custom-ggtags]
1268       '(menu-item "Customize Ggtags"
1269                   (lambda () (interactive) (customize-group 'ggtags))))
1270     (define-key menu [save-project]
1271       '(menu-item "Save project settings" ggtags-save-project-settings))
1272     (define-key menu [toggle-read-only]
1273       '(menu-item "Toggle project read-only" ggtags-toggle-project-read-only
1274                   :button (:toggle . buffer-read-only)))
1275     (define-key menu [visit-project-root]
1276       '(menu-item "Visit project root" ggtags-visit-project-root))
1277     (define-key menu [sep2] menu-bar-separator)
1278     (define-key menu [browse-hypertext]
1279       '(menu-item "Browse as hypertext" ggtags-browse-file-as-hypertext
1280                   :enable (ggtags-find-project)))
1281     (define-key menu [delete-tags]
1282       '(menu-item "Delete tag files" ggtags-delete-tag-files
1283                   :enable (ggtags-find-project)))
1284     (define-key menu [kill-buffers]
1285       '(menu-item "Kill project file buffers" ggtags-kill-file-buffers
1286                   :enable (ggtags-find-project)))
1287     (define-key menu [view-tag]
1288       '(menu-item "View tag history" ggtags-view-tag-history))
1289     (define-key menu [pop-mark]
1290       '(menu-item "Pop mark" pop-tag-mark
1291                   :help "Pop to previous mark and destroy it"))
1292     (define-key menu [next-mark]
1293       '(menu-item "Next mark" ggtags-next-mark))
1294     (define-key menu [prev-mark]
1295       '(menu-item "Previous mark" ggtags-prev-mark))
1296     (define-key menu [sep1] menu-bar-separator)
1297     (define-key menu [previous-error]
1298       '(menu-item "Previous match" previous-error))
1299     (define-key menu [next-error]
1300       '(menu-item "Next match" next-error))
1301     (define-key menu [find-file]
1302       '(menu-item "Find files" ggtags-find-file))
1303     (define-key menu [query-replace]
1304       '(menu-item "Query replace" ggtags-query-replace))
1305     (define-key menu [idutils]
1306       '(menu-item "Query idutils DB" ggtags-idutils-query))
1307     (define-key menu [grep]
1308       '(menu-item "Grep" ggtags-grep))
1309     (define-key menu [find-symbol]
1310       '(menu-item "Find other symbol" ggtags-find-other-symbol))
1311     (define-key menu [find-tag-regexp]
1312       '(menu-item "Find tag matching regexp" ggtags-find-tag-regexp))
1313     (define-key menu [find-reference]
1314       '(menu-item "Find reference" ggtags-find-reference))
1315     (define-key menu [find-tag-continue]
1316       '(menu-item "Continue find tag" tags-loop-continue))
1317     (define-key menu [find-tag]
1318       '(menu-item "Find tag" ggtags-find-tag-dwim))
1319     (define-key menu [update-tags]
1320       '(menu-item "Update tag files" ggtags-update-tags
1321                   :visible (ggtags-find-project)))
1322     (define-key menu [run-gtags]
1323       '(menu-item "Run gtags" ggtags-create-tags
1324                   :visible (not (ggtags-find-project))))
1325     map))
1326
1327 ;;;###autoload
1328 (define-minor-mode ggtags-mode nil
1329   :lighter (:eval (if ggtags-navigation-mode "" " GG"))
1330   (unless (timerp ggtags-highlight-tag-timer)
1331     (setq ggtags-highlight-tag-timer
1332           (run-with-idle-timer
1333            ggtags-highlight-tag-delay t #'ggtags-highlight-tag-at-point)))
1334   (if ggtags-mode
1335       (progn
1336         (add-hook 'after-save-hook 'ggtags-after-save-function nil t)
1337         ;; Append to serve as a fallback method.
1338         (add-hook 'completion-at-point-functions
1339                   #'ggtags-completion-at-point t t))
1340     (remove-hook 'after-save-hook 'ggtags-after-save-function t)
1341     (remove-hook 'completion-at-point-functions #'ggtags-completion-at-point t)
1342     (and (overlayp ggtags-highlight-tag-overlay)
1343          (delete-overlay ggtags-highlight-tag-overlay))
1344     (setq ggtags-highlight-tag-overlay nil)))
1345
1346 (defvar ggtags-highlight-tag-map
1347   (let ((map (make-sparse-keymap)))
1348     (define-key map [S-down-mouse-1] 'ggtags-find-tag-dwim)
1349     (define-key map [S-down-mouse-3] 'ggtags-find-reference)
1350     map)
1351   "Keymap used for valid tag at point.")
1352
1353 (put 'ggtags-active-tag 'face 'ggtags-highlight)
1354 (put 'ggtags-active-tag 'keymap ggtags-highlight-tag-map)
1355 ;; (put 'ggtags-active-tag 'mouse-face 'match)
1356 (put 'ggtags-active-tag 'help-echo
1357      "S-down-mouse-1 for definitions\nS-down-mouse-3 for references")
1358
1359 (defun ggtags-highlight-tag-at-point ()
1360   (when (and ggtags-mode ggtags-project-root (ggtags-find-project))
1361     (unless (overlayp ggtags-highlight-tag-overlay)
1362       (setq ggtags-highlight-tag-overlay (make-overlay (point) (point) nil t))
1363       (overlay-put ggtags-highlight-tag-overlay 'modification-hooks
1364                    (list (lambda (o after &rest _args)
1365                            (and (not after) (delete-overlay o))))))
1366     (let ((bounds (funcall ggtags-bounds-of-tag-function))
1367           (o ggtags-highlight-tag-overlay))
1368       (cond
1369        ((and bounds
1370              (eq (overlay-buffer o) (current-buffer))
1371              (= (overlay-start o) (car bounds))
1372              (= (overlay-end o) (cdr bounds)))
1373         ;; Overlay matches current tag so do nothing.
1374         nil)
1375        ((and bounds (let ((completion-ignore-case nil))
1376                       (ignore-errors
1377                         ;; May throw: global: only name char is
1378                         ;; allowed with -c option
1379                         (test-completion
1380                          (buffer-substring (car bounds) (cdr bounds))
1381                          ggtags-completion-table))))
1382         (move-overlay o (car bounds) (cdr bounds) (current-buffer))
1383         (overlay-put o 'category 'ggtags-active-tag))
1384        (t (move-overlay o
1385                         (or (car bounds) (point))
1386                         (or (cdr bounds) (point))
1387                         (current-buffer))
1388           (overlay-put o 'category nil))))))
1389
1390 ;;; imenu
1391
1392 (defun ggtags-goto-imenu-index (name line &rest _args)
1393   (save-restriction
1394     (widen)
1395     (goto-char (point-min))
1396     (forward-line (1- line))
1397     (ggtags-move-to-tag name)))
1398
1399 ;;;###autoload
1400 (defun ggtags-build-imenu-index ()
1401   "A function suitable for `imenu-create-index-function'."
1402   (when-let (file (and buffer-file-name (file-relative-name buffer-file-name)))
1403     (with-temp-buffer
1404       (when (with-demoted-errors
1405               (zerop (ggtags-with-current-project
1406                       (process-file "global" nil t nil "-x" "-f" file))))
1407         (goto-char (point-min))
1408         (loop while (re-search-forward
1409                      "^\\([^ \t]+\\)[ \t]+\\([0-9]+\\)" nil t)
1410               collect (list (match-string 1)
1411                             (string-to-number (match-string 2))
1412                             'ggtags-goto-imenu-index))))))
1413
1414 ;;; hippie-expand
1415
1416 ;;;###autoload
1417 (defun try-complete-ggtags-tag (old)
1418   "A function suitable for `hippie-expand-try-functions-list'."
1419   (with-no-warnings                     ; to avoid loading hippie-exp
1420     (unless old
1421       (he-init-string (if (looking-back "\\_<.*" (line-beginning-position))
1422                           (match-beginning 0)
1423                         (point))
1424                       (point))
1425       (setq he-expand-list
1426             (and (not (equal he-search-string ""))
1427                  (ggtags-find-project)
1428                  (sort (all-completions he-search-string
1429                                         ggtags-completion-table)
1430                        #'string-lessp))))
1431     (if (null he-expand-list)
1432         (progn
1433           (if old (he-reset-string))
1434           nil)
1435       (he-substitute-string (car he-expand-list))
1436       (setq he-expand-list (cdr he-expand-list))
1437       t)))
1438
1439 (defun ggtags-reload (&optional force)
1440   (interactive "P")
1441   (unload-feature 'ggtags force)
1442   (require 'ggtags))
1443
1444 (defun ggtags-unload-function ()
1445   (setq emulation-mode-map-alists
1446         (delq 'ggtags-mode-map-alist emulation-mode-map-alists))
1447   nil)
1448
1449 (provide 'ggtags)
1450 ;;; ggtags.el ends here