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

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