code.delx.au - gnu-emacs-elpa/blob - packages/ggtags/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.6.7
   7 ;; Keywords: tools, convenience
   8 ;; Created: 2013-01-29
   9 ;; URL: https://github.com/leoliu/ggtags
  10
  11 ;; This program is free software; you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation, either version 3 of the License, or
  14 ;; (at your option) any later version.
  15
  16 ;; This program is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
  23
  24 ;;; Commentary:
  25
  26 ;; A package to integrate GNU Global source code tagging system
  27 ;; (http://www.gnu.org/software/global) with Emacs.
  28 ;;
  29 ;; Usage:
  30 ;;
  31 ;; Type `M-x ggtags-mode' to enable the minor mode, or as usual enable
  32 ;; it in your desired major mode hooks. When the mode is on the symbol
  33 ;; at point is underlined if it is a valid (definition) tag.
  34 ;;
  35 ;; `M-.' finds definition or references according to the context at
  36 ;; point, i.e. if point is at a definition tag find references and
  37 ;; vice versa. `C-u M-.' is verbose and will ask you the name - with
  38 ;; completion - and the type of tag to search.
  39 ;;
  40 ;; If multiple matches are found, navigation mode is entered. In this
  41 ;; mode, `M-n' and `M-p' moves to next and previous match, `M-}' and
  42 ;; `M-{' to next and previous file respectively. `M-o' toggles between
  43 ;; full and abbreviated displays of file names in the auxiliary popup
  44 ;; window. When you locate the right match, press RET to finish which
  45 ;; hides the auxiliary window and exits navigation mode. You can
  46 ;; resume the search using `M-,'. To abort the search press `M-*'.
  47 ;;
  48 ;; Normally after a few searches a dozen buffers are created visiting
  49 ;; files tracked by GNU Global. `C-c M-k' helps clean them up.
  50
  51 ;;; Code:
  52
  53 (eval-when-compile (require 'cl))
  54 (require 'compile)
  55
  56 (if (not (fboundp 'comment-string-strip))
  57     (autoload 'comment-string-strip "newcomment"))
  58
  59 (eval-when-compile
  60   (unless (fboundp 'setq-local)
  61     (defmacro setq-local (var val)
  62       (list 'set (list 'make-local-variable (list 'quote var)) val)))
  63
  64   (unless (fboundp 'defvar-local)
  65     (defmacro defvar-local (var val &optional docstring)
  66       (declare (debug defvar) (doc-string 3))
  67       (list 'progn (list 'defvar var val docstring)
  68             (list 'make-variable-buffer-local (list 'quote var))))))
  69
  70 (eval-and-compile
  71   (unless (fboundp 'user-error)
  72     (defalias 'user-error 'error)))
  73
  74 (defgroup ggtags nil
  75   "GNU Global source code tagging system."
  76   :group 'tools)
  77
  78 (defface ggtags-highlight '((t (:underline t)))
  79   "Face used to highlight a valid tag at point.")
  80
  81 (defcustom ggtags-auto-jump-to-first-match t
  82   "Non-nil to automatically jump to the first match."
  83   :type 'boolean
  84   :group 'ggtags)
  85
  86 (defcustom ggtags-global-window-height 8 ; ggtags-global-mode
  87   "Number of lines for the 'global' popup window.
  88 If nil, use Emacs default."
  89   :type '(choice (const :tag "Default" nil) integer)
  90   :group 'ggtags)
  91
  92 (defcustom ggtags-global-abbreviate-filename 35
  93   "Non-nil to display file names abbreviated such as '/u/b/env'."
  94   :type '(choice (const :tag "No" nil)
  95                  (const :tag "Always" t)
  96                  integer)
  97   :group 'ggtags)
  98
  99 (defcustom ggtags-oversize-limit (* 50 1024 1024)
 100   "The over size limit for the  GTAGS file."
 101   :type '(choice (const :tag "None" nil)
 102                  (const :tag "Always" t)
 103                  number)
 104   :group 'ggtags)
 105
 106 (defcustom ggtags-split-window-function split-window-preferred-function
 107   "A function to control how ggtags pops up the auxiliary window."
 108   :type 'function
 109   :group 'ggtags)
 110
 111 (defcustom ggtags-global-output-format 'grep
 112   "The output format for the 'global' command."
 113   :type '(choice (const path)
 114                  (const ctags)
 115                  (const ctags-x)
 116                  (const grep)
 117                  (const cscope))
 118   :group 'ggtags)
 119
 120 (defcustom ggtags-completing-read-function completing-read-function
 121   "Ggtags specific `completing-read-function' (which see)."
 122   :type 'function
 123   :group 'ggtags)
 124
 125 (defvar ggtags-cache nil)               ; (ROOT TABLE DIRTY TIMESTAMP)
 126
 127 (defvar ggtags-current-tag-name nil)
 128
 129 ;; Used by ggtags-global-mode
 130 (defvar ggtags-global-error "match"
 131   "Stem of message to print when no matches are found.")
 132
 133 ;; http://thread.gmane.org/gmane.comp.gnu.global.bugs/1518
 134 (defvar ggtags-global-has-path-style    ; introduced in global 6.2.8
 135   (with-demoted-errors                  ; in case `global' not found
 136     (zerop (call-process "global" nil nil nil
 137                          "--path-style" "shorter" "--help")))
 138   "Non-nil if `global' supports --path-style switch.")
 139
 140 ;; http://thread.gmane.org/gmane.comp.gnu.global.bugs/1542
 141 (defvar ggtags-global-has-color         ; introduced in global 6.2.9
 142   (with-demoted-errors
 143     (zerop (call-process "global" nil nil nil "--color" "--help"))))
 144
 145 (defmacro ggtags-ensure-global-buffer (&rest body)
 146   (declare (indent 0))
 147   `(progn
 148      (or (and (buffer-live-p compilation-last-buffer)
 149               (with-current-buffer compilation-last-buffer
 150                 (derived-mode-p 'ggtags-global-mode)))
 151          (error "No global buffer found"))
 152      (with-current-buffer compilation-last-buffer ,@body)))
 153
 154 (defun ggtags-oversize-p ()
 155   (pcase ggtags-oversize-limit
 156     (`nil nil)
 157     (`t t)
 158     (t (when (ggtags-root-directory)
 159          (> (or (nth 7 (file-attributes
 160                         (expand-file-name "GTAGS" (ggtags-root-directory))))
 161                 0)
 162             ggtags-oversize-limit)))))
 163
 164 (defun ggtags-get-timestamp (root)
 165   "Get the timestamp (float) of file GTAGS in ROOT directory.
 166 Return -1 if it does not exist."
 167   (let ((file (expand-file-name "GTAGS" root)))
 168     (if (file-exists-p file)
 169         (float-time (nth 5 (file-attributes file)))
 170       -1)))
 171
 172 (defun ggtags-get-libpath ()
 173   (split-string (or (getenv "GTAGSLIBPATH") "")
 174                 (regexp-quote path-separator) t))
 175
 176 (defun ggtags-cache-get (key)
 177   (assoc key ggtags-cache))
 178
 179 (defun ggtags-cache-set (key val &optional dirty)
 180   (let ((c (ggtags-cache-get key)))
 181     (if c
 182         (setcdr c (list val dirty (float-time)))
 183       (push (list key val dirty (float-time)) ggtags-cache))))
 184
 185 (defun ggtags-cache-mark-dirty (key flag)
 186   "Return non-nil if operation is successful."
 187   (let ((cache (ggtags-cache-get key)))
 188     (when cache
 189       (setcar (cddr cache) flag))))
 190
 191 (defun ggtags-cache-dirty-p (key)
 192   "Value is non-nil if 'global -u' is needed."
 193   (third (ggtags-cache-get key)))
 194
 195 (defun ggtags-cache-stale-p (key)
 196   "Value is non-nil if tags in cache needs to be rebuilt."
 197   (> (ggtags-get-timestamp key)
 198      (or (fourth (ggtags-cache-get key)) 0)))
 199
 200 (defvar-local ggtags-root-directory nil
 201   "Internal; use function `ggtags-root-directory' instead.")
 202
 203 ;;;###autoload
 204 (defun ggtags-root-directory ()
 205   (or ggtags-root-directory
 206       (setq ggtags-root-directory
 207             (with-temp-buffer
 208               (when (zerop (call-process "global" nil (list t nil) nil "-pr"))
 209                 (file-name-as-directory
 210                  (comment-string-strip (buffer-string) t t)))))))
 211
 212 (defun ggtags-check-root-directory ()
 213   (or (ggtags-root-directory) (error "File GTAGS not found")))
 214
 215 (defun ggtags-ensure-root-directory ()
 216   (or (ggtags-root-directory)
 217       (when (or (yes-or-no-p "File GTAGS not found; run gtags? ")
 218                 (error "Aborted"))
 219         (let ((root (read-directory-name "Directory: " nil nil t)))
 220           (and (= (length root) 0) (error "No directory chosen"))
 221           (when (with-temp-buffer
 222                   (let ((default-directory
 223                           (file-name-as-directory root)))
 224                     (or (zerop (call-process "gtags" nil t))
 225                         (error "%s" (comment-string-strip
 226                                      (buffer-string) t t)))))
 227             (message "File GTAGS generated in `%s'"
 228                      (ggtags-root-directory)))))))
 229
 230 (defun ggtags-tag-names-1 (root &optional from-cache)
 231   (when root
 232     (if (and (not from-cache) (ggtags-cache-stale-p root))
 233         (let* ((default-directory (file-name-as-directory root))
 234                (tags (with-demoted-errors
 235                        (process-lines "global" "-c" ""))))
 236           (and tags (ggtags-cache-set root tags))
 237           tags)
 238       (cadr (ggtags-cache-get root)))))
 239
 240 ;;;###autoload
 241 (defun ggtags-tag-names (&optional from-cache)
 242   "Get a list of tag names."
 243   (let ((root (ggtags-root-directory)))
 244     (when (and root
 245                (not (ggtags-oversize-p))
 246                (not from-cache)
 247                (ggtags-cache-dirty-p root))
 248       (if (zerop (call-process "global" nil nil nil "-u"))
 249           (ggtags-cache-mark-dirty root nil)
 250         (message "ggtags: error running 'global -u'")))
 251     (apply 'append (mapcar (lambda (r)
 252                              (ggtags-tag-names-1 r from-cache))
 253                            (cons root (ggtags-get-libpath))))))
 254
 255 (defun ggtags-read-tag (quick)
 256   (ggtags-ensure-root-directory)
 257   (let ((default (thing-at-point 'symbol))
 258         (completing-read-function ggtags-completing-read-function))
 259     (setq ggtags-current-tag-name
 260           (if quick (or default (user-error "No tag at point"))
 261             (completing-read
 262              (format (if default "Tag (default %s): " "Tag: ") default)
 263              ;; XXX: build tag names more lazily such as using
 264              ;; `completion-table-dynamic'.
 265              (ggtags-tag-names)
 266              nil t nil nil default)))))
 267
 268 (defun ggtags-global-options ()
 269   (concat "-v --result="
 270           (symbol-name ggtags-global-output-format)
 271           (and ggtags-global-has-color " --color")
 272           (and ggtags-global-has-path-style " --path-style=shorter")))
 273
 274 ;;;###autoload
 275 (defun ggtags-find-tag (name &optional verbose)
 276   "Find definitions or references to tag NAME by context.
 277 If point is at a definition tag, find references, and vice versa.
 278 When called with prefix, ask the name and kind of tag."
 279   (interactive (list (ggtags-read-tag (not current-prefix-arg))
 280                      current-prefix-arg))
 281   (ggtags-check-root-directory)
 282   (let ((split-window-preferred-function ggtags-split-window-function)
 283         (default-directory (ggtags-root-directory))
 284         (help-char ??)
 285         (help-form "\
 286 d: definitions          (-d)
 287 r: references           (-r)
 288 s: symbols              (-s)
 289 ?: show this help\n"))
 290     (compilation-start
 291      (if (or verbose (not buffer-file-name))
 292          (format "global %s -%s \"%s\""
 293                  (ggtags-global-options)
 294                  (char-to-string
 295                   (read-char-choice "Tag type? (d/r/s/?) " '(?d ?r ?s)))
 296                  name)
 297        (format "global %s --from-here=%d:%s \"%s\""
 298                (ggtags-global-options)
 299                (line-number-at-pos)
 300                (shell-quote-argument
 301                 (expand-file-name (file-truename buffer-file-name)))
 302                name))
 303      'ggtags-global-mode))
 304   (eval-and-compile (require 'etags))
 305   (ring-insert find-tag-marker-ring (point-marker))
 306   (ggtags-navigation-mode +1))
 307
 308 (defun ggtags-find-tag-resume ()
 309   (interactive)
 310   (ggtags-ensure-global-buffer
 311     (ggtags-navigation-mode +1)
 312     (let ((split-window-preferred-function ggtags-split-window-function))
 313       (compile-goto-error))))
 314
 315 ;; NOTE: Coloured output in grep requested: http://goo.gl/Y9IcX
 316 (defun ggtags-list-tags (regexp file-or-directory)
 317   "List all tags matching REGEXP in FILE-OR-DIRECTORY."
 318   (interactive (list (read-string "POSIX regexp: ")
 319                      (read-file-name "Directory: "
 320                                      (if current-prefix-arg
 321                                          (ggtags-root-directory)
 322                                        default-directory)
 323                                      buffer-file-name t)))
 324   (let ((split-window-preferred-function ggtags-split-window-function)
 325         (default-directory (if (file-directory-p file-or-directory)
 326                                (file-name-as-directory file-or-directory)
 327                              (file-name-directory file-or-directory))))
 328     (ggtags-check-root-directory)
 329     (eval-and-compile (require 'etags))
 330     (ggtags-navigation-mode +1)
 331     (ring-insert find-tag-marker-ring (point-marker))
 332     (with-current-buffer
 333         (compilation-start (format "global %s -e %s %s"
 334                                    (ggtags-global-options)
 335                                    regexp
 336                                    (if (file-directory-p file-or-directory)
 337                                        "-l ."
 338                                      (concat "-f " (shell-quote-argument
 339                                                     (file-name-nondirectory
 340                                                      file-or-directory)))))
 341                            'ggtags-global-mode)
 342       (setq-local compilation-auto-jump-to-first-error nil)
 343       (remove-hook 'compilation-finish-functions 'ggtags-handle-single-match t))))
 344
 345 (defun ggtags-query-replace (from to &optional delimited directory)
 346   "Query replace FROM with TO on all files in DIRECTORY."
 347   (interactive
 348    (append (query-replace-read-args "Query replace (regexp)" t t)
 349            (list (read-directory-name "In directory: " nil nil t))))
 350   (let ((default-directory (file-name-as-directory directory)))
 351     (ggtags-check-root-directory)
 352     (dolist (file (process-lines "global" "-P" "-l" "."))
 353       (let ((file (expand-file-name file directory)))
 354         (when (file-exists-p file)
 355           (let* ((message-log-max nil)
 356                  (visited (get-file-buffer file))
 357                  (buffer (or visited
 358                              (with-demoted-errors
 359                                (find-file-noselect file)))))
 360             (when buffer
 361               (set-buffer buffer)
 362               (if (save-excursion
 363                     (goto-char (point))
 364                     (re-search-forward from nil t))
 365                   (progn
 366                     (switch-to-buffer (current-buffer))
 367                     (perform-replace from to t t delimited
 368                                      nil multi-query-replace-map))
 369                 (message "Nothing to do for `%s'" file)
 370                 (or visited (kill-buffer))))))))))
 371
 372 (defun ggtags-delete-tag-files ()
 373   "Delete the tag files generated by gtags."
 374   (interactive)
 375   (when (ggtags-root-directory)
 376     (let ((files (directory-files (ggtags-root-directory) t
 377                                   (regexp-opt '("GPATH" "GRTAGS" "GTAGS" "ID"))))
 378           (buffer "*GTags File List*"))
 379       (or files (user-error "No tag files found"))
 380       (with-output-to-temp-buffer buffer
 381         (dolist (file files)
 382           (princ file)
 383           (princ "\n")))
 384       (let ((win (get-buffer-window buffer)))
 385         (unwind-protect
 386             (progn
 387               (fit-window-to-buffer win)
 388               (when (yes-or-no-p "Remove GNU Global tag files? ")
 389                 (mapc 'delete-file files)))
 390           (when (window-live-p win)
 391             (quit-window t win)))))))
 392
 393 (defvar ggtags-current-mark nil)
 394
 395 (defun ggtags-next-mark (&optional arg)
 396   "Move to the next mark in the tag marker ring."
 397   (interactive)
 398   (or (> (ring-length find-tag-marker-ring) 1)
 399       (user-error "No %s mark" (if arg "previous" "next")))
 400   (let ((mark (or (and ggtags-current-mark
 401                        (marker-buffer ggtags-current-mark)
 402                        (funcall (if arg #'ring-previous #'ring-next)
 403                                 find-tag-marker-ring ggtags-current-mark))
 404                   (progn
 405                     (ring-insert find-tag-marker-ring (point-marker))
 406                     (ring-ref find-tag-marker-ring 0)))))
 407     (switch-to-buffer (marker-buffer mark))
 408     (goto-char mark)
 409     (setq ggtags-current-mark mark)))
 410
 411 (defun ggtags-prev-mark ()
 412   (interactive)
 413   (ggtags-next-mark 'previous))
 414
 415 (defvar-local ggtags-global-exit-status nil)
 416
 417 (defun ggtags-global-exit-message-function (_process-status exit-status msg)
 418   (setq ggtags-global-exit-status exit-status)
 419   (let ((count (save-excursion
 420                  (goto-char (point-max))
 421                  (if (re-search-backward "^\\([0-9]+\\) \\w+ located" nil t)
 422                      (string-to-number (match-string 1))
 423                    0))))
 424     (cons (if (> exit-status 0)
 425               msg
 426             (format "found %d %s" count (if (= count 1) "match" "matches")))
 427           exit-status)))
 428
 429 ;;; NOTE: Must not match the 'Global started at Mon Jun 3 10:24:13'
 430 ;;; line or `compilation-auto-jump' will jump there and fail. See
 431 ;;; comments before the 'gnu' entry in
 432 ;;; `compilation-error-regexp-alist-alist'.
 433 (defvar ggtags-global-error-regexp-alist-alist
 434   (append
 435    '((path "^\\(?:[^/\n]*/\\)?[^ )\t\n]+$" 0)
 436      ;; ACTIVE_ESCAPE   src/dialog.cc   172
 437      (ctags "^\\([^ \t\n]+\\)[ \t]+\\(.*?\\)[ \t]+\\([0-9]+\\)$"
 438             2 3 nil nil 2 (1 font-lock-function-name-face))
 439      ;; ACTIVE_ESCAPE     172 src/dialog.cc    #undef ACTIVE_ESCAPE
 440      (ctags-x "^\\([^ \t\n]+\\)[ \t]+\\([0-9]+\\)[ \t]+\\(\\(?:[^/\n]*/\\)?[^ \t\n]+\\)"
 441               3 2 nil nil 3 (1 font-lock-function-name-face))
 442      ;; src/dialog.cc:172:#undef ACTIVE_ESCAPE
 443      (grep "^\\(.+?\\):\\([0-9]+\\):\\(?:[^0-9\n]\\|[0-9][^0-9\n]\\|[0-9][0-9].\\)"
 444            1 2 nil nil 1)
 445      ;; src/dialog.cc ACTIVE_ESCAPE 172 #undef ACTIVE_ESCAPE
 446      (cscope "^\\(.+?\\)[ \t]+\\([^ \t\n]+\\)[ \t]+\\([0-9]+\\).*\\(?:[^0-9\n]\\|[^0-9\n][0-9]\\|[^:\n][0-9][0-9]\\)$"
 447              1 3 nil nil 1 (2 font-lock-function-name-face)))
 448    compilation-error-regexp-alist-alist))
 449
 450 (defun ggtags-abbreviate-file (start end)
 451   (let ((inhibit-read-only t)
 452         (amount (if (numberp ggtags-global-abbreviate-filename)
 453                     (- (- end start) ggtags-global-abbreviate-filename)
 454                   999))
 455         (advance-word (lambda ()
 456                         "Return the length of the text made invisible."
 457                         (let ((wend (min end (progn (forward-word 1) (point))))
 458                               (wbeg (max start (progn (backward-word 1) (point)))))
 459                           (goto-char wend)
 460                           (if (<= (- wend wbeg) 1)
 461                               0
 462                             (put-text-property (1+ wbeg) wend 'invisible t)
 463                             (1- (- wend wbeg)))))))
 464     (goto-char start)
 465     (while (and (> amount 0) (> end (point)))
 466       (decf amount (funcall advance-word)))))
 467
 468 (defun ggtags-abbreviate-files (start end)
 469   (goto-char start)
 470   (let* ((error-re (cdr (assq ggtags-global-output-format
 471                               ggtags-global-error-regexp-alist-alist)))
 472          (sub (cadr error-re)))
 473     (when (and ggtags-global-abbreviate-filename error-re)
 474       (while (re-search-forward (car error-re) end t)
 475         (when (and (or (not (numberp ggtags-global-abbreviate-filename))
 476                        (> (length (match-string sub))
 477                           ggtags-global-abbreviate-filename))
 478                    ;; Ignore bogus file lines such as:
 479                    ;;     Global found 2 matches at Thu Jan 31 13:45:19
 480                    (get-text-property (match-beginning sub) 'compilation-message))
 481           (ggtags-abbreviate-file (match-beginning sub) (match-end sub)))))))
 482
 483 (defun ggtags-global-filter ()
 484   "Called from `compilation-filter-hook' (which see)."
 485   (ansi-color-apply-on-region compilation-filter-start (point)))
 486
 487 (defun ggtags-handle-single-match (buf _how)
 488   (when (and ggtags-auto-jump-to-first-match
 489              ;; If exit abnormally keep the window for inspection.
 490              (zerop ggtags-global-exit-status)
 491              (save-excursion
 492                (goto-char (point-min))
 493                (not (ignore-errors
 494                       (goto-char (compilation-next-single-property-change
 495                                   (point) 'compilation-message))
 496                       (end-of-line)
 497                       (compilation-next-single-property-change
 498                        (point) 'compilation-message)))))
 499     (ggtags-navigation-mode -1)
 500     ;; 0.5s delay for `ggtags-auto-jump-to-first-match'
 501     (sit-for 0)                    ; See: http://debbugs.gnu.org/13829
 502     (ggtags-navigation-mode-cleanup buf 0.5)))
 503
 504 (defvar ggtags-global-mode-font-lock-keywords
 505   '(("^Global \\(exited abnormally\\|interrupt\\|killed\\|terminated\\)\\(?:.*with code \\([0-9]+\\)\\)?.*"
 506      (1 'compilation-error)
 507      (2 'compilation-error nil t))
 508     ("^Global found \\([0-9]+\\)" (1 compilation-info-face))))
 509
 510 (define-compilation-mode ggtags-global-mode "Global"
 511   "A mode for showing outputs from gnu global."
 512   (setq-local compilation-error-regexp-alist
 513               (list ggtags-global-output-format))
 514   (setq-local compilation-auto-jump-to-first-error
 515               ggtags-auto-jump-to-first-match)
 516   (setq-local compilation-scroll-output 'first-error)
 517   (setq-local compilation-disable-input t)
 518   (setq-local compilation-always-kill t)
 519   (setq-local compilation-error-face 'compilation-info)
 520   (setq-local compilation-exit-message-function
 521               'ggtags-global-exit-message-function)
 522   (setq-local truncate-lines t)
 523   (jit-lock-register #'ggtags-abbreviate-files)
 524   (add-hook 'compilation-filter-hook 'ggtags-global-filter nil 'local)
 525   (add-hook 'compilation-finish-functions 'ggtags-handle-single-match nil t)
 526   (define-key ggtags-global-mode-map "o" 'visible-mode))
 527
 528 (defvar ggtags-navigation-mode-map
 529   (let ((map (make-sparse-keymap)))
 530     (define-key map "\M-n" 'next-error)
 531     (define-key map "\M-p" 'previous-error)
 532     (define-key map "\M-}" 'ggtags-navigation-next-file)
 533     (define-key map "\M-{" 'ggtags-navigation-previous-file)
 534     (define-key map "\M-o" 'ggtags-navigation-visible-mode)
 535     (define-key map [return] 'ggtags-navigation-mode-done)
 536     (define-key map "\r" 'ggtags-navigation-mode-done)
 537     ;; Intercept M-. and M-* keys
 538     (define-key map [remap pop-tag-mark] 'ggtags-navigation-mode-abort)
 539     (define-key map [remap ggtags-find-tag] 'undefined)
 540     map))
 541
 542 (defun ggtags-move-to-tag (&optional name)
 543   "Move to NAME tag in current line."
 544   (let ((orig (point))
 545         (tag (or name ggtags-current-tag-name)))
 546     (beginning-of-line)
 547     (if (and tag (re-search-forward
 548                   (concat "\\_<" (regexp-quote tag) "\\_>")
 549                   (line-end-position)
 550                   t))
 551         (goto-char (match-beginning 0))
 552       (goto-char orig))))
 553
 554 (defun ggtags-navigation-mode-cleanup (&optional buf time)
 555   (let ((buf (or buf compilation-last-buffer)))
 556     (and (buffer-live-p buf)
 557          (with-current-buffer buf
 558            (when (get-buffer-process (current-buffer))
 559              (kill-compilation))
 560            (when (and (derived-mode-p 'ggtags-global-mode)
 561                       (get-buffer-window))
 562              (quit-window nil (get-buffer-window)))
 563            (and time (run-with-idle-timer time nil 'kill-buffer buf))))))
 564
 565 (defun ggtags-navigation-mode-done ()
 566   (interactive)
 567   (ggtags-navigation-mode -1)
 568   (ggtags-navigation-mode-cleanup))
 569
 570 (defun ggtags-navigation-mode-abort ()
 571   (interactive)
 572   (pop-tag-mark)
 573   (ggtags-navigation-mode -1)
 574   (ggtags-navigation-mode-cleanup nil 0))
 575
 576 (defun ggtags-navigation-next-file (n)
 577   (interactive "p")
 578   (ggtags-ensure-global-buffer
 579     (compilation-next-file n)
 580     (compile-goto-error)))
 581
 582 (defun ggtags-navigation-previous-file (n)
 583   (interactive "p")
 584   (ggtags-navigation-next-file (- n)))
 585
 586 (defun ggtags-navigation-visible-mode (&optional arg)
 587   (interactive (list (or current-prefix-arg 'toggle)))
 588   (ggtags-ensure-global-buffer
 589     (visible-mode arg)))
 590
 591 (define-minor-mode ggtags-navigation-mode nil
 592   :lighter (" GG[" (:propertize "n" face error) "]")
 593   :global t
 594   (if ggtags-navigation-mode
 595       (progn
 596         (add-hook 'next-error-hook 'ggtags-move-to-tag)
 597         (add-hook 'minibuffer-setup-hook 'ggtags-minibuffer-setup-function))
 598     (remove-hook 'next-error-hook 'ggtags-move-to-tag)
 599     (remove-hook 'minibuffer-setup-hook 'ggtags-minibuffer-setup-function)))
 600
 601 (defun ggtags-minibuffer-setup-function ()
 602   ;; Disable ggtags-navigation-mode in minibuffer.
 603   (setq-local ggtags-navigation-mode nil))
 604
 605 (defun ggtags-kill-file-buffers (&optional interactive)
 606   "Kill all buffers visiting files in the root directory."
 607   (interactive "p")
 608   (ggtags-check-root-directory)
 609   (let ((root (ggtags-root-directory))
 610         (count 0)
 611         (some (lambda (pred list)
 612                 (loop for x in list when (funcall pred x) return it))))
 613     (dolist (buf (buffer-list))
 614       (let ((file (and (buffer-live-p buf)
 615                        (not (eq buf (current-buffer)))
 616                        (buffer-file-name buf))))
 617         (when (and file (funcall some (apply-partially #'file-in-directory-p
 618                                                        (file-truename file))
 619                                  (cons root (ggtags-get-libpath))))
 620           (and (kill-buffer buf)
 621                (incf count)))))
 622     (and interactive
 623          (message "%d %s killed" count (if (= count 1) "buffer" "buffers")))))
 624
 625 (defun ggtags-after-save-function ()
 626   (let ((root (with-demoted-errors (ggtags-root-directory))))
 627     (when root
 628       (ggtags-cache-mark-dirty root t)
 629       ;; When oversize update on a per-save basis.
 630       (when (and buffer-file-name (ggtags-oversize-p))
 631         (with-demoted-errors
 632           (call-process "global" nil 0 nil
 633                         "--single-update"
 634                         (file-truename buffer-file-name)))))))
 635
 636 (defvar ggtags-tag-overlay nil)
 637 (defvar ggtags-highlight-tag-timer nil)
 638
 639 (defvar ggtags-mode-map
 640   (let ((map (make-sparse-keymap)))
 641     (define-key map "\M-." 'ggtags-find-tag)
 642     (define-key map "\M-," 'ggtags-find-tag-resume)
 643     (define-key map "\C-c\M-k" 'ggtags-kill-file-buffers)
 644     map))
 645
 646 ;;;###autoload
 647 (define-minor-mode ggtags-mode nil
 648   :lighter (:eval (if ggtags-navigation-mode "" " GG"))
 649   (if ggtags-mode
 650       (progn
 651         (add-hook 'after-save-hook 'ggtags-after-save-function nil t)
 652         (or (executable-find "global")
 653             (message "Failed to find GNU Global")))
 654     (remove-hook 'after-save-hook 'ggtags-after-save-function t)
 655     (and (overlayp ggtags-tag-overlay)
 656          (delete-overlay ggtags-tag-overlay))
 657     (setq ggtags-tag-overlay nil)))
 658
 659 (defun ggtags-highlight-tag-at-point ()
 660   (when ggtags-mode
 661     (unless (overlayp ggtags-tag-overlay)
 662       (setq ggtags-tag-overlay (make-overlay (point) (point)))
 663       (overlay-put ggtags-tag-overlay 'ggtags t))
 664     (let* ((bounds (bounds-of-thing-at-point 'symbol))
 665            (valid-tag (when bounds
 666                         (member (buffer-substring (car bounds) (cdr bounds))
 667                                 (ggtags-tag-names (ggtags-oversize-p)))))
 668            (o ggtags-tag-overlay)
 669            (done-p (lambda ()
 670                      (and (memq o (overlays-at (car bounds)))
 671                           (= (overlay-start o) (car bounds))
 672                           (= (overlay-end o) (cdr bounds))
 673                           (or (and valid-tag (overlay-get o 'face))
 674                               (and (not valid-tag) (not (overlay-get o 'face))))))))
 675       (cond
 676        ((not bounds)
 677         (overlay-put ggtags-tag-overlay 'face nil)
 678         (move-overlay ggtags-tag-overlay (point) (point) (current-buffer)))
 679        ((not (funcall done-p))
 680         (move-overlay o (car bounds) (cdr bounds) (current-buffer))
 681         (overlay-put o 'face (and valid-tag 'ggtags-highlight)))))))
 682
 683 ;;; imenu
 684
 685 (defun ggtags-goto-imenu-index (name line &rest _args)
 686   (save-restriction
 687     (widen)
 688     (goto-char (point-min))
 689     (forward-line (1- line))
 690     (ggtags-move-to-tag name)))
 691
 692 ;;;###autoload
 693 (defun ggtags-build-imenu-index ()
 694   "A function suitable for `imenu-create-index-function'."
 695   (when buffer-file-name
 696     (let ((file (file-truename buffer-file-name)))
 697       (with-temp-buffer
 698         (when (with-demoted-errors
 699                 (zerop (call-process "global" nil t nil "-f" file)))
 700           (goto-char (point-min))
 701           (loop while (re-search-forward
 702                        "^\\([^ \t]+\\)[ \t]+\\([0-9]+\\)" nil t)
 703                 collect (list (match-string 1)
 704                               (string-to-number (match-string 2))
 705                               'ggtags-goto-imenu-index)))))))
 706
 707 ;;; hippie-expand
 708
 709 ;;;###autoload
 710 (defun try-complete-ggtags-tag (old)
 711   "A function suitable for `hippie-expand-try-functions-list'."
 712   (with-no-warnings                     ; to avoid loading hippie-exp
 713     (unless old
 714       (he-init-string (if (looking-back "\\_<.*" (line-beginning-position))
 715                           (match-beginning 0)
 716                         (point))
 717                       (point))
 718       (setq he-expand-list
 719             (and (not (equal he-search-string ""))
 720                  (with-demoted-errors (ggtags-root-directory))
 721                  (sort (all-completions he-search-string
 722                                         (ggtags-tag-names))
 723                        'string-lessp))))
 724     (if (null he-expand-list)
 725         (progn
 726           (if old (he-reset-string))
 727           nil)
 728       (he-substitute-string (car he-expand-list))
 729       (setq he-expand-list (cdr he-expand-list))
 730       t)))
 731
 732 ;;; Finish up
 733
 734 (when ggtags-highlight-tag-timer
 735   (cancel-timer ggtags-highlight-tag-timer))
 736
 737 (setq ggtags-highlight-tag-timer
 738       (run-with-idle-timer 0.2 t 'ggtags-highlight-tag-at-point))
 739
 740 ;; Higher priority for `ggtags-navigation-mode' to avoid being
 741 ;; hijacked by modes such as `view-mode'.
 742 (defvar ggtags-mode-map-alist
 743   `((ggtags-navigation-mode . ,ggtags-navigation-mode-map)))
 744
 745 (add-to-list 'emulation-mode-map-alists 'ggtags-mode-map-alist)
 746
 747 (provide 'ggtags)
 748 ;;; ggtags.el ends here