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