mirror of https://github.com/Chizi123/.emacs.d.git

Chizi123
2018-11-17 c4001ccd1864293b64aa37d83a9d9457eb875e70
commit | author | age
5cb5f7 1 ;;; ggtags.el --- emacs frontend to GNU Global source code tagging system  -*- lexical-binding: t; -*-
C 2
3 ;; Copyright (C) 2013-2018  Free Software Foundation, Inc.
4
5 ;; Author: Leo Liu <sdl.web@gmail.com>
6 ;; Version: 0.9.0
7 ;; Package-Version: 20181031.1803
8 ;; Keywords: tools, convenience
9 ;; Created: 2013-01-29
10 ;; URL: https://github.com/leoliu/ggtags
11 ;; Package-Requires: ((emacs "25"))
12
13 ;; This program is free software; you can redistribute it and/or modify
14 ;; it under the terms of the GNU General Public License as published by
15 ;; the Free Software Foundation, either version 3 of the License, or
16 ;; (at your option) any later version.
17
18 ;; This program is distributed in the hope that it will be useful,
19 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
21 ;; GNU General Public License for more details.
22
23 ;; You should have received a copy of the GNU General Public License
24 ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
25
26 ;;; Commentary:
27
28 ;; A package to integrate GNU Global source code tagging system
29 ;; (http://www.gnu.org/software/global) with Emacs.
30 ;;
31 ;; Usage:
32 ;;
33 ;; `ggtags' is similar to the standard `etags' package. These keys
34 ;; `M-.', `M-,' and `C-M-.' should work as expected in `ggtags-mode'.
35 ;; See the README in https://github.com/leoliu/ggtags for more
36 ;; details.
37 ;;
38 ;; All commands are available from the `Ggtags' menu in `ggtags-mode'.
39
40 ;;; NEWS 0.8.13 (2018-07-25):
41
42 ;; - Don't choke on tag names start with `-'.
43 ;; - `ggtags-show-definition' supports `ggtags-sort-by-nearness'.
44 ;; - New variable `ggtags-extra-args'.
45 ;; - Unbreak `ggtags-sort-by-nearness'.
46 ;;
47 ;; See full NEWS on https://github.com/leoliu/ggtags#news
48
49 ;;; Code:
50
51 (eval-when-compile
52   (require 'url-parse))
53
54 (require 'cl-lib)
55 (require 'ewoc)
56 (require 'compile)
57 (require 'etags)
58
59 (eval-when-compile
60   (defmacro ignore-errors-unless-debug (&rest body)
61     "Ignore all errors while executing BODY unless debug is on."
62     (declare (debug t) (indent 0))
63     `(condition-case-unless-debug nil (progn ,@body) (error nil)))
64
65   (defmacro with-display-buffer-no-window (&rest body)
66     (declare (debug t) (indent 0))
67     ;; See http://debbugs.gnu.org/13594
68     `(let ((display-buffer-overriding-action
69             (if ggtags-auto-jump-to-match
70                 (list #'display-buffer-no-window)
71               display-buffer-overriding-action)))
72        ,@body)))
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   :group 'ggtags)
81
82 (defface ggtags-global-line '((t (:inherit secondary-selection)))
83   "Face used to highlight matched line in Global buffer."
84   :group 'ggtags)
85
86 (defcustom ggtags-executable-directory nil
87   "If non-nil the directory to search global executables."
88   :type '(choice (const :tag "Unset" nil) directory)
89   :risky t
90   :group 'ggtags)
91
92 (defcustom ggtags-oversize-limit (* 10 1024 1024)
93   "The over size limit for the  GTAGS file.
94 When the size of the GTAGS file is below this limit, ggtags
95 always maintains up-to-date tags for the whole source tree by
96 running `global -u'. For projects with GTAGS larger than this
97 limit, only files edited in Ggtags mode are updated (via `global
98 --single-update')."
99   :safe 'numberp
100   :type '(choice (const :tag "None" nil)
101                  (const :tag "Always" t)
102                  number)
103   :group 'ggtags)
104
105 (defcustom ggtags-include-pattern
106   '("^\\s-*#\\s-*\\(?:include\\|import\\)\\s-*[\"<]\\(?:[./]*\\)?\\(.*?\\)[\">]" . 1)
107   "Pattern used to detect #include files.
108 Value can be (REGEXP . SUB) or a function with no arguments.
109 REGEXP should match from the beginning of line."
110   :type '(choice (const :tag "Disable" nil)
111                  (cons regexp integer)
112                  function)
113   :safe 'stringp
114   :group 'ggtags)
115
116 ;; See also: http://article.gmane.org/gmane.comp.gnu.global.bugs/1751
117 (defcustom ggtags-use-project-gtagsconf t
118   "Non-nil to use GTAGSCONF file found at project root.
119 File .globalrc and gtags.conf are checked in order.
120
121 Note: GNU Global v6.2.13 has the feature of using gtags.conf at
122 project root. Setting this variable to nil doesn't disable this
123 feature."
124   :safe 'booleanp
125   :type 'boolean
126   :group 'ggtags)
127
128 (defcustom ggtags-project-duration 600
129   "Seconds to keep information of a project in memory."
130   :type 'number
131   :group 'ggtags)
132
133 (defcustom ggtags-process-environment nil
134   "Similar to `process-environment' with higher precedence.
135 Elements are run through `substitute-env-vars' before use.
136 GTAGSROOT will always be expanded to current project root
137 directory. This is intended for project-wise ggtags-specific
138 process environment settings. Note on remote hosts (e.g. tramp)
139 directory local variables is not enabled by default per
140 `enable-remote-dir-locals' (which see)."
141   :safe 'ggtags-list-of-string-p
142   :type '(repeat string)
143   :group 'ggtags)
144
145 (defcustom ggtags-auto-jump-to-match 'history
146   "Strategy on how to jump to match: nil, first or history.
147
148     nil: never automatically jump to any match;
149   first: jump to the first match;
150 history: jump to the match stored in search history."
151   :type '(choice (const :tag "First match" first)
152                  (const :tag "Search History" history)
153                  (const :tag "Never" nil))
154   :group 'ggtags)
155
156 (defcustom ggtags-global-window-height 8 ; ggtags-global-mode
157   "Number of lines for the *ggtags-global* popup window.
158 If nil, use Emacs default."
159   :type '(choice (const :tag "Default" nil) integer)
160   :group 'ggtags)
161
162 (defcustom ggtags-global-abbreviate-filename 40
163   "Non-nil to display file names abbreviated e.g. \"/u/b/env\".
164 If an integer abbreviate only names longer than that number."
165   :type '(choice (const :tag "No" nil)
166                  (const :tag "Always" t)
167                  integer)
168   :group 'ggtags)
169
170 (defcustom ggtags-split-window-function split-window-preferred-function
171   "A function to control how ggtags pops up the auxiliary window."
172   :type 'function
173   :group 'ggtags)
174
175 (defcustom ggtags-use-idutils (and (executable-find "mkid") t)
176   "Non-nil to also generate the idutils DB."
177   :type 'boolean
178   :group 'ggtags)
179
180 (defcustom ggtags-use-sqlite3 nil
181   "Use sqlite3 for storage instead of Berkeley DB.
182 This feature requires GNU Global 6.3.3+ and is ignored if `gtags'
183 isn't built with sqlite3 support."
184   :type 'boolean
185   :safe 'booleanp
186   :group 'ggtags)
187
188 (defcustom ggtags-extra-args nil
189   "Extra arguments to pass to `gtags' in `ggtags-create-tags'."
190   :type '(repeat string)
191   :safe #'ggtags-list-of-string-p
192   :group 'ggtags)
193
194 (defcustom ggtags-sort-by-nearness nil
195   "Sort tags by nearness to current directory.
196 GNU Global 6.5+ required."
197   :type 'boolean
198   :safe #'booleanp
199   :group 'ggtags)
200
201 (defcustom ggtags-update-on-save t
202   "Non-nil to update tags for current buffer on saving."
203   ;; It is reported that `global --single-update' can be slow in sshfs
204   ;; directories. See https://github.com/leoliu/ggtags/issues/85.
205   :safe #'booleanp
206   :type 'boolean
207   :group 'ggtags)
208
209 (defcustom ggtags-global-output-format 'grep
210   "Global output format: path, ctags, ctags-x, grep or cscope."
211   :type '(choice (const path)
212                  (const ctags)
213                  (const ctags-x)
214                  (const grep)
215                  (const cscope))
216   :group 'ggtags)
217
218 (defcustom ggtags-global-use-color t
219   "Non-nil to use color in output if supported by Global.
220 Note: processing colored output takes noticeable time
221 particularly when the output is large."
222   :type 'boolean
223   :safe 'booleanp
224   :group 'ggtags)
225
226 (defcustom ggtags-global-ignore-case nil
227   "Non-nil if Global should ignore case in the search pattern."
228   :safe 'booleanp
229   :type 'boolean
230   :group 'ggtags)
231
232 (defcustom ggtags-global-treat-text nil
233   "Non-nil if Global should include matches from text files.
234 This affects `ggtags-find-file' and `ggtags-grep'."
235   :safe 'booleanp
236   :type 'boolean
237   :group 'ggtags)
238
239 ;; See also https://github.com/leoliu/ggtags/issues/52
240 (defcustom ggtags-global-search-libpath-for-reference t
241   "If non-nil global will search GTAGSLIBPATH for references.
242 Search is only continued in GTAGSLIBPATH if it finds no matches
243 in current project."
244   :safe 'booleanp
245   :type 'boolean
246   :group 'ggtags)
247
248 (defcustom ggtags-global-large-output 1000
249   "Number of lines in the Global buffer to indicate large output."
250   :type 'number
251   :group 'ggtags)
252
253 (defcustom ggtags-global-history-length history-length
254   "Maximum number of items to keep in `ggtags-global-search-history'."
255   :type 'integer
256   :group 'ggtags)
257
258 (defcustom ggtags-enable-navigation-keys t
259   "If non-nil key bindings in `ggtags-navigation-map' are enabled."
260   :safe 'booleanp
261   :type 'boolean
262   :group 'ggtags)
263
264 (defcustom ggtags-find-tag-hook nil
265   "Hook run immediately after finding a tag."
266   :options '(recenter reposition-window)
267   :type 'hook
268   :group 'ggtags)
269
270 (defcustom ggtags-get-definition-function #'ggtags-get-definition-default
271   "Function called by `ggtags-show-definition' to get definition.
272 It is passed a list of definition candidates of the form:
273
274  (TEXT NAME FILE LINE)
275
276 where TEXT is usually the source line of the definition.
277
278 The return value is passed to `ggtags-print-definition-function'."
279   :type 'function
280   :group 'ggtags)
281
282 (defcustom ggtags-print-definition-function
283   (lambda (s) (ggtags-echo "%s" (or s "[definition not found]")))
284   "Function used by `ggtags-show-definition' to print definition."
285   :type 'function
286   :group 'ggtags)
287
288 (defcustom ggtags-mode-sticky t
289   "If non-nil enable Ggtags Mode in files visited."
290   :safe 'booleanp
291   :type 'boolean
292   :group 'ggtags)
293
294 (defcustom ggtags-mode-prefix-key "\C-c"
295   "Key binding used for `ggtags-mode-prefix-map'.
296 Users should change the value using `customize-variable' to
297 properly update `ggtags-mode-map'."
298   :set (lambda (sym value)
299          (when (bound-and-true-p ggtags-mode-map)
300            (let ((old (and (boundp sym) (symbol-value sym))))
301              (and old (define-key ggtags-mode-map old nil)))
302            (and value
303                 (bound-and-true-p ggtags-mode-prefix-map)
304                 (define-key ggtags-mode-map value ggtags-mode-prefix-map)))
305          (set-default sym value))
306   :type 'key-sequence
307   :group 'ggtags)
308
309 (defcustom ggtags-completing-read-function nil
310   "Ggtags specific `completing-read-function' (which see).
311 Nil means using the value of `completing-read-function'."
312   :type '(choice (const :tag "Use completing-read-function" nil)
313                  function)
314   :group 'ggtags)
315
316 (define-obsolete-variable-alias 'ggtags-highlight-tag-delay 'ggtags-highlight-tag
317   "0.8.11")
318
319 (defcustom ggtags-highlight-tag 0.25
320   "If non-nil time in seconds before highlighting tag at point.
321 Set to nil to disable tag highlighting."
322   :set (lambda (sym value)
323          (when (fboundp 'ggtags-setup-highlight-tag-at-point)
324            (ggtags-setup-highlight-tag-at-point value))
325          (set-default sym value))
326   :type '(choice (const :tag "Disable" nil) number)
327   :group 'ggtags)
328
329 (defcustom ggtags-bounds-of-tag-function (lambda ()
330                                            (bounds-of-thing-at-point 'symbol))
331   "Function to get the start and end positions of the tag at point."
332   :type 'function
333   :group 'ggtags)
334
335 ;; Used by ggtags-global-mode
336 (defvar ggtags-global-error "match"
337   "Stem of message to print when no matches are found.")
338
339 (defconst ggtags-bug-url "https://github.com/leoliu/ggtags/issues")
340
341 (defvar ggtags-global-last-buffer nil)
342
343 (defvar ggtags-global-continuation nil)
344
345 (defvar ggtags-current-tag-name nil)
346
347 (defvar ggtags-highlight-tag-overlay nil)
348
349 (defvar ggtags-highlight-tag-timer nil)
350
351 (defmacro ggtags-with-temp-message (message &rest body)
352   (declare (debug t) (indent 1))
353   (let ((init-time (make-symbol "-init-time-"))
354         (tmp-msg (make-symbol "-tmp-msg-")))
355     `(let ((,init-time (float-time))
356            (,tmp-msg ,message))
357        (with-temp-message ,tmp-msg
358          (prog1 (progn ,@body)
359            (message "%sdone (%.2fs)" ,(or tmp-msg "")
360                     (- (float-time) ,init-time)))))))
361
362 (defmacro ggtags-delay-finish-functions (&rest body)
363   "Delay running `compilation-finish-functions' until after BODY."
364   (declare (indent 0) (debug t))
365   (let ((saved (make-symbol "-saved-"))
366         (exit-args (make-symbol "-exit-args-")))
367     `(let ((,saved compilation-finish-functions)
368            ,exit-args)
369        (setq-local compilation-finish-functions nil)
370        (add-hook 'compilation-finish-functions
371                  (lambda (&rest args) (setq ,exit-args args))
372                  nil t)
373        (unwind-protect (progn ,@body)
374          (setq-local compilation-finish-functions ,saved)
375          (and ,exit-args (apply #'run-hook-with-args
376                                 'compilation-finish-functions ,exit-args))))))
377
378 (defmacro ggtags-ensure-global-buffer (&rest body)
379   (declare (debug t) (indent 0))
380   `(progn
381      (or (and (buffer-live-p ggtags-global-last-buffer)
382               (with-current-buffer ggtags-global-last-buffer
383                 (derived-mode-p 'ggtags-global-mode)))
384          (error "No global buffer found"))
385      (with-current-buffer ggtags-global-last-buffer ,@body)))
386
387 (defun ggtags-list-of-string-p (xs)
388   "Return non-nil if XS is a list of strings."
389   (cl-every #'stringp xs))
390
391 (defun ggtags-ensure-localname (file)
392   (and file (or (file-remote-p file 'localname) file)))
393
394 (defun ggtags-echo (format-string &rest args)
395   "Print formatted text to echo area."
396   (let (message-log-max) (apply #'message format-string args)))
397
398 (defun ggtags-forward-to-line (line)
399   "Move to line number LINE in current buffer."
400   (cl-check-type line (integer 1))
401   (save-restriction
402     (widen)
403     (goto-char (point-min))
404     (forward-line (1- line))))
405
406 (defun ggtags-kill-window ()
407   "Quit selected window and kill its buffer."
408   (interactive)
409   (quit-window t))
410
411 (defun ggtags-program-path (name)
412   (if ggtags-executable-directory
413       (expand-file-name name ggtags-executable-directory)
414     name))
415
416 (defun ggtags-process-succeed-p (program &rest args)
417   "Return non-nil if successfully running PROGRAM with ARGS."
418   (let ((program (ggtags-program-path program)))
419     (condition-case err
420         (zerop (apply #'process-file program nil nil nil args))
421       (error (message "`%s' failed: %s" program (error-message-string err))
422              nil))))
423
424 (defun ggtags-process-string (program &rest args)
425   (with-temp-buffer
426     (let ((exit (apply #'process-file
427                        (ggtags-program-path program) nil t nil args))
428           (output (progn
429                     (goto-char (point-max))
430                     (skip-chars-backward " \t\n\r")
431                     (buffer-substring-no-properties (point-min) (point)))))
432       (or (zerop exit)
433           (error "`%s' non-zero exit: %s" program output))
434       output)))
435
436 (defun ggtags-tag-at-point ()
437   (pcase (funcall ggtags-bounds-of-tag-function)
438     (`(,beg . ,end) (buffer-substring-no-properties beg end))))
439
440 ;;; Store for project info and settings
441
442 (defvar ggtags-projects (make-hash-table :size 7 :test #'equal))
443
444 (cl-defstruct (ggtags-project (:constructor ggtags-project--make)
445                               (:copier nil)
446                               (:type vector)
447                               :named)
448   root tag-size has-refs has-path-style has-color dirty-p mtime timestamp)
449
450 (defun ggtags-make-project (root)
451   (cl-check-type root string)
452   (let* ((default-directory (file-name-as-directory root))
453          ;; NOTE: use of GTAGSDBPATH is not recommended. -- GLOBAL(1)
454          ;; ROOT and DB can be different directories due to GTAGSDBPATH.
455          (dbdir (concat (file-remote-p root)
456                         (ggtags-process-string "global" "-p"))))
457     (pcase (nthcdr 5 (file-attributes (expand-file-name "GTAGS" dbdir)))
458       (`(,mtime ,_ ,tag-size . ,_)
459        (let* ((rtags-size (nth 7 (file-attributes (expand-file-name "GRTAGS" dbdir))))
460               (has-refs
461                (when rtags-size
462                  (and (or (> rtags-size (* 32 1024))
463                           (with-demoted-errors "ggtags-make-project: %S"
464                             (not (equal "" (ggtags-process-string "global" "-crs")))))
465                       'has-refs)))
466               ;; http://thread.gmane.org/gmane.comp.gnu.global.bugs/1518
467               (has-path-style
468                (and (ggtags-process-succeed-p "global" "--path-style" "shorter" "--help")
469                     'has-path-style))
470               ;; http://thread.gmane.org/gmane.comp.gnu.global.bugs/1542
471               (has-color (and (ggtags-process-succeed-p "global" "--color" "--help")
472                               'has-color)))
473          (puthash default-directory
474                   (ggtags-project--make :root default-directory
475                                         :tag-size tag-size
476                                         :has-refs has-refs
477                                         :has-path-style has-path-style
478                                         :has-color has-color
479                                         :mtime (float-time mtime)
480                                         :timestamp (float-time))
481                   ggtags-projects))))))
482
483 (defun ggtags-project-expired-p (project)
484   (or (< (ggtags-project-timestamp project) 0)
485       (> (- (float-time)
486             (ggtags-project-timestamp project))
487          ggtags-project-duration)))
488
489 (defun ggtags-project-update-mtime-maybe (&optional project)
490   "Update PROJECT's modtime and if current file is newer.
491 Value is new modtime if updated."
492   (let ((project (or project (ggtags-find-project))))
493     (when (and (ggtags-project-p project)
494                (consp (visited-file-modtime))
495                (> (float-time (visited-file-modtime))
496                   (ggtags-project-mtime project)))
497       (setf (ggtags-project-dirty-p project) t)
498       (setf (ggtags-project-mtime project)
499             (float-time (visited-file-modtime))))))
500
501 (defun ggtags-project-oversize-p (&optional project)
502   (pcase ggtags-oversize-limit
503     (`nil nil)
504     (`t t)
505     (size (let ((project (or project (ggtags-find-project))))
506             (and project (> (ggtags-project-tag-size project) size))))))
507
508 (defvar-local ggtags-last-default-directory nil)
509 (defvar-local ggtags-project-root 'unset
510   "Internal variable for project root directory.")
511
512 ;;;###autoload
513 (defun ggtags-find-project ()
514   ;; See https://github.com/leoliu/ggtags/issues/42
515   ;;
516   ;; It is unsafe to cache `ggtags-project-root' in non-file buffers
517   ;; whose `default-directory' can often change.
518   (unless (equal ggtags-last-default-directory default-directory)
519     (kill-local-variable 'ggtags-project-root))
520   (let ((project (gethash ggtags-project-root ggtags-projects)))
521     (if (ggtags-project-p project)
522         (if (ggtags-project-expired-p project)
523             (progn
524               (remhash ggtags-project-root ggtags-projects)
525               (ggtags-find-project))
526           project)
527       (setq ggtags-last-default-directory default-directory)
528       (setq ggtags-project-root
529             (or (ignore-errors
530                   (file-name-as-directory
531                    (concat (file-remote-p default-directory)
532                            ;; Resolves symbolic links
533                            (ggtags-process-string "global" "-pr"))))
534                 ;; 'global -pr' resolves symlinks before checking the
535                 ;; GTAGS file which could cause issues such as
536                 ;; https://github.com/leoliu/ggtags/issues/22, so
537                 ;; let's help it out.
538                 (let ((dir (locate-dominating-file
539                             default-directory
540                             (lambda (dir) (file-regular-p (expand-file-name "GTAGS" dir))))))
541                   ;; `file-truename' may strip the trailing '/' on
542                   ;; remote hosts, see http://debbugs.gnu.org/16851
543                   (and dir (file-name-as-directory (file-truename dir))))))
544       (when ggtags-project-root
545         (if (gethash ggtags-project-root ggtags-projects)
546             (ggtags-find-project)
547           (ggtags-make-project ggtags-project-root))))))
548
549 (defun ggtags-current-project-root ()
550   (and (ggtags-find-project)
551        (ggtags-project-root (ggtags-find-project))))
552
553 (defun ggtags-check-project ()
554   (or (ggtags-find-project) (error "File GTAGS not found")))
555
556 (defun ggtags-ensure-project ()
557   (or (ggtags-find-project)
558       (progn (call-interactively #'ggtags-create-tags)
559              ;; Need checking because `ggtags-create-tags' can create
560              ;; tags in any directory.
561              (ggtags-check-project))))
562
563 (defun ggtags-save-project-settings (&optional noconfirm)
564   "Save Gnu Global's specific environment variables."
565   (interactive "P")
566   (ggtags-check-project)
567   (let* ((inhibit-read-only t)          ; for `add-dir-local-variable'
568          (default-directory (ggtags-current-project-root))
569          ;; Not using `ggtags-with-current-project' to preserve
570          ;; environment variables that may be present in
571          ;; `ggtags-process-environment'.
572          (process-environment
573           (append ggtags-process-environment
574                   process-environment
575                   (and (not (ggtags-project-has-refs (ggtags-find-project)))
576                        (list "GTAGSLABEL=ctags"))))
577          (envlist (delete-dups
578                    (cl-loop for x in process-environment
579                             when (string-match
580                                   "^\\(GTAGS[^=\n]*\\|MAKEOBJDIRPREFIX\\)=" x)
581                             ;; May have duplicates thus `delete-dups'.
582                             collect (concat (match-string 1 x)
583                                             "="
584                                             (getenv (match-string 1 x))))))
585          (help-form (format "y: save\nn: don't save\n=: diff\n?: help\n")))
586     (add-dir-local-variable nil 'ggtags-process-environment envlist)
587     ;; Remove trailing newlines by `add-dir-local-variable'.
588     (let ((delete-trailing-lines t)) (delete-trailing-whitespace))
589     (or noconfirm
590         (while (pcase (read-char-choice
591                        (format "Save `%s'? (y/n/=/?) " buffer-file-name)
592                        '(?y ?n ?= ??))
593                  (?n (user-error "Aborted"))
594                  (?y nil)
595                  (?= (diff-buffer-with-file) 'loop)
596                  (?? (help-form-show) 'loop))))
597     (save-buffer)
598     (kill-buffer)))
599
600 (defun ggtags-toggle-project-read-only ()
601   (interactive)
602   (ggtags-check-project)
603   (let ((inhibit-read-only t)           ; for `add-dir-local-variable'
604         (val (not buffer-read-only))
605         (default-directory (ggtags-current-project-root)))
606     (add-dir-local-variable nil 'buffer-read-only val)
607     (save-buffer)
608     (kill-buffer)
609     (when buffer-file-name
610       (read-only-mode (if val +1 -1)))
611     (when (called-interactively-p 'interactive)
612       (message "Project read-only-mode is %s" (if val "on" "off")))
613     val))
614
615 (defun ggtags-visit-project-root (&optional project)
616   "Visit the root directory of (current) PROJECT in dired.
617 When called with a prefix \\[universal-argument], choose from past projects."
618   (interactive (list (and current-prefix-arg
619                           (completing-read "Project: " ggtags-projects))))
620   (dired (cl-typecase project
621            (string project)
622            (ggtags-project (ggtags-project-root project))
623            (t (ggtags-ensure-project) (ggtags-current-project-root)))))
624
625 (defmacro ggtags-with-current-project (&rest body)
626   "Eval BODY in current project's `process-environment'."
627   (declare (debug t) (indent 0))
628   (let ((gtagsroot (make-symbol "-gtagsroot-"))
629         (root (make-symbol "-ggtags-project-root-")))
630     `(let* ((,root ggtags-project-root)
631             (,gtagsroot (when (ggtags-find-project)
632                           (ggtags-ensure-localname
633                            (directory-file-name (ggtags-current-project-root)))))
634             (process-environment
635              (append (let ((process-environment (copy-sequence process-environment)))
636                        (and ,gtagsroot (setenv "GTAGSROOT" ,gtagsroot))
637                        (mapcar #'substitute-env-vars ggtags-process-environment))
638                      process-environment
639                      (and ,gtagsroot (list (concat "GTAGSROOT=" ,gtagsroot)))
640                      (and (ggtags-find-project)
641                           (not (ggtags-project-has-refs (ggtags-find-project)))
642                           (list "GTAGSLABEL=ctags")))))
643        (unwind-protect (save-current-buffer ,@body)
644          (setq ggtags-project-root ,root)))))
645
646 (defun ggtags-get-libpath ()
647   (let ((path (ggtags-with-current-project (getenv "GTAGSLIBPATH"))))
648     (and path (mapcar (apply-partially #'concat (file-remote-p default-directory))
649                       (split-string path (regexp-quote path-separator) t)))))
650
651 (defun ggtags-project-relative-file (file)
652   "Get file name relative to current project root."
653   (ggtags-check-project)
654   (if (file-name-absolute-p file)
655       (file-relative-name file (if (string-prefix-p (ggtags-current-project-root)
656                                                     file)
657                                    (ggtags-current-project-root)
658                                  (locate-dominating-file file "GTAGS")))
659     file))
660
661 (defun ggtags-project-file-p (file)
662   "Return non-nil if FILE is part of current project."
663   (when (ggtags-find-project)
664     (with-temp-buffer
665       (ggtags-with-current-project
666         ;; NOTE: `process-file' requires all files in ARGS be relative
667         ;; to `default-directory'; see its doc string for details.
668         (let ((default-directory (ggtags-current-project-root)))
669           (process-file (ggtags-program-path "global") nil t nil
670                         "-vP" (concat "^" (ggtags-project-relative-file file) "$"))))
671       (goto-char (point-min))
672       (not (re-search-forward "^file not found" nil t)))))
673
674 (defun ggtags-invalidate-buffer-project-root (root)
675   (mapc (lambda (buf)
676           (with-current-buffer buf
677             (and buffer-file-truename
678                  (string-prefix-p root buffer-file-truename)
679                  (kill-local-variable 'ggtags-project-root))))
680         (buffer-list)))
681
682 (defun ggtags-create-tags (root)
683   "Create tag files (e.g. GTAGS) in directory ROOT.
684 If file .globalrc or gtags.conf exists in ROOT, it will be used
685 as configuration file per `ggtags-use-project-gtagsconf'.
686
687 If file gtags.files exists in ROOT, it should be a list of source
688 files to index, which can be used to speed gtags up in large
689 source trees. See Info node `(global)gtags' for details."
690   (interactive "DRoot directory: ")
691   (let ((process-environment (copy-sequence process-environment)))
692     (when (zerop (length root)) (error "No root directory provided"))
693     (setenv "GTAGSROOT" (ggtags-ensure-localname
694                          (expand-file-name
695                           (directory-file-name (file-name-as-directory root)))))
696     (ggtags-with-current-project
697       (let ((conf (and ggtags-use-project-gtagsconf
698                        (cl-loop for name in '(".globalrc" "gtags.conf")
699                                 for full = (expand-file-name name root)
700                                 thereis (and (file-exists-p full) full)))))
701         (unless (or conf (getenv "GTAGSLABEL")
702                     (not (yes-or-no-p "Use `ctags' backend? ")))
703           (setenv "GTAGSLABEL" "ctags"))
704         (ggtags-with-temp-message "`gtags' in progress..."
705           (let ((default-directory (file-name-as-directory root))
706                 (args (append (cl-remove-if
707                                #'null
708                                (list (and ggtags-use-idutils "--idutils")
709                                      (and ggtags-use-sqlite3
710                                           (ggtags-process-succeed-p "gtags" "--sqlite3" "--help")
711                                           "--sqlite3")
712                                      (and conf "--gtagsconf")
713                                      (and conf (ggtags-ensure-localname conf))))
714                               ggtags-extra-args)))
715             (condition-case err
716                 (apply #'ggtags-process-string "gtags" args)
717               (error (if (and ggtags-use-idutils
718                               (stringp (cadr err))
719                               (string-match-p "mkid not found" (cadr err)))
720                          ;; Retry without mkid
721                          (apply #'ggtags-process-string
722                                 "gtags" (cl-remove "--idutils" args))
723                        (signal (car err) (cdr err)))))))))
724     (ggtags-invalidate-buffer-project-root (file-truename root))
725     (message "GTAGS generated in `%s'" root)
726     root))
727
728 (defun ggtags-explain-tags ()
729   "Explain how each file is indexed in current project."
730   (interactive (ignore (ggtags-check-project)
731                        (or (ggtags-process-succeed-p "gtags" "--explain" "--help")
732                            (user-error "Global 6.4+ required"))))
733   (ggtags-check-project)
734   (ggtags-with-current-project
735     (let ((default-directory (ggtags-current-project-root)))
736       (compilation-start (concat (ggtags-program-path "gtags") " --explain")))))
737
738 (defun ggtags-update-tags (&optional force)
739   "Update GNU Global tag database.
740 Do nothing if GTAGS exceeds the oversize limit unless FORCE.
741
742 When called interactively on large (per `ggtags-oversize-limit')
743 projects, the update process runs in the background without
744 blocking emacs."
745   (interactive (progn
746                  (ggtags-check-project)
747                  ;; Mark project info expired.
748                  (setf (ggtags-project-timestamp (ggtags-find-project)) -1)
749                  (list 'interactive)))
750   (cond ((and (eq force 'interactive) (ggtags-project-oversize-p))
751          (ggtags-with-current-project
752            (with-display-buffer-no-window
753              (with-current-buffer (compilation-start "global -u")
754                ;; A hack to fool compilation mode to display `global
755                ;; -u finished' on finish.
756                (setq mode-name "global -u")
757                (add-hook 'compilation-finish-functions
758                          #'ggtags-update-tags-finish nil t)))))
759         ((or force (and (ggtags-find-project)
760                         (not (ggtags-project-oversize-p))
761                         (ggtags-project-dirty-p (ggtags-find-project))))
762          (ggtags-with-current-project
763            (ggtags-with-temp-message "`global -u' in progress..."
764              (ggtags-process-string "global" "-u")
765              (ggtags-update-tags-finish))))))
766
767 (defun ggtags-update-tags-finish (&optional buf how)
768   (if (and how buf (string-prefix-p "exited abnormally" how))
769       (display-buffer buf)
770     (setf (ggtags-project-dirty-p (ggtags-find-project)) nil)
771     (setf (ggtags-project-mtime (ggtags-find-project)) (float-time))))
772
773 (defun ggtags-update-tags-single (file &optional nowait)
774   ;; NOTE: NOWAIT is ignored if file is remote file; see
775   ;; `tramp-sh-handle-process-file'.
776   (cl-check-type file string)
777   (let ((nowait (unless (file-remote-p file) nowait)))
778     (ggtags-with-current-project
779       ;; See comment in `ggtags-project-file-p'.
780       (let ((default-directory (ggtags-current-project-root)))
781         (process-file (ggtags-program-path "global") nil (and nowait 0) nil
782                       "--single-update" (ggtags-project-relative-file file))))))
783
784 (defun ggtags-delete-tags ()
785   "Delete file GTAGS, GRTAGS, GPATH, ID etc. generated by gtags."
786   (interactive (ignore (ggtags-check-project)))
787   (when (ggtags-current-project-root)
788     (let* ((re (concat "\\`" (regexp-opt '("GPATH" "GRTAGS" "GTAGS" "ID")) "\\'"))
789            (files (cl-remove-if-not
790                    (lambda (file)
791                      ;; Don't trust `directory-files'.
792                      (let ((case-fold-search nil))
793                        (string-match-p re (file-name-nondirectory file))))
794                    (directory-files (ggtags-current-project-root) t re)))
795            (buffer "*GTags File List*"))
796       (or files (user-error "No tag files found"))
797       (with-output-to-temp-buffer buffer
798         (princ (mapconcat #'identity files "\n")))
799       (let ((win (get-buffer-window buffer)))
800         (unwind-protect
801             (progn
802               (fit-window-to-buffer win)
803               (when (yes-or-no-p "Remove GNU Global tag files? ")
804                 (with-demoted-errors (mapc #'delete-file files))
805                 (remhash (ggtags-current-project-root) ggtags-projects)
806                 (and (overlayp ggtags-highlight-tag-overlay)
807                      (delete-overlay ggtags-highlight-tag-overlay))))
808           (when (window-live-p win)
809             (quit-window t win)))))))
810
811 (defvar-local ggtags-completion-cache nil)
812
813 ;; See global/libutil/char.c
814 ;; (defconst ggtags-regexp-metachars "[][$()*+.?\\{}|^]")
815 (defvar ggtags-completion-flag "")      ;internal use
816
817 (defvar ggtags-completion-table
818   (completion-table-dynamic
819    (lambda (prefix)
820      (let ((cache-key (concat prefix "$" ggtags-completion-flag)))
821        (unless (equal cache-key (car ggtags-completion-cache))
822          (setq ggtags-completion-cache
823                (cons cache-key
824                      (ignore-errors-unless-debug
825                        ;; May throw global: only name char is allowed
826                        ;; with -c option.
827                        (ggtags-with-current-project
828                          (split-string
829                           (apply #'ggtags-process-string
830                                  "global"
831                                  (append (and completion-ignore-case '("--ignore-case"))
832                                          ;; Note -c alone returns only definitions
833                                          (list (concat "-c" ggtags-completion-flag) prefix)))
834                           "\n" t)))))))
835      (cdr ggtags-completion-cache))))
836
837 (defun ggtags-completion-at-point ()
838   "A function for `completion-at-point-functions'."
839   (pcase (funcall ggtags-bounds-of-tag-function)
840     (`(,beg . ,end)
841      (and (< beg end) (list beg end ggtags-completion-table)))))
842
843 (defun ggtags-read-tag (&optional type confirm prompt require-match default)
844   (ggtags-ensure-project)
845   (let ((default (or default (ggtags-tag-at-point)))
846         (prompt (or prompt (capitalize (symbol-name (or type 'tag)))))
847         (ggtags-completion-flag (pcase type
848                                   (`(or nil definition) "T")
849                                   (`symbol "s")
850                                   (`reference "r")
851                                   (`id "I")
852                                   (`path "P")
853                                   ((pred stringp) type)
854                                   (_ ggtags-completion-flag))))
855     (setq ggtags-current-tag-name
856           (cond (confirm
857                  (ggtags-update-tags)
858                  (let ((completing-read-function
859                         (or ggtags-completing-read-function
860                             completing-read-function)))
861                    (completing-read
862                     (format (if default "%s (default %s): " "%s: ") prompt default)
863                     ggtags-completion-table nil require-match nil nil default)))
864                 (default (substring-no-properties default))
865                 (t (ggtags-read-tag type t prompt require-match default))))))
866
867 (defun ggtags-sort-by-nearness-p ()
868   (and ggtags-sort-by-nearness
869        (ggtags-process-succeed-p "global" "--nearness=." "--help")))
870
871 (defun ggtags-global-build-command (cmd &rest args)
872   ;; CMD can be definition, reference, symbol, grep, idutils
873   (let ((xs (append (list (shell-quote-argument (ggtags-program-path "global"))
874                           "-v"
875                           (format "--result=%s" ggtags-global-output-format)
876                           (and ggtags-global-ignore-case "--ignore-case")
877                           (and ggtags-global-use-color
878                                (ggtags-find-project)
879                                (ggtags-project-has-color (ggtags-find-project))
880                                "--color=always")
881                           (and (ggtags-sort-by-nearness-p) "--nearness=.")
882                           (and (ggtags-find-project)
883                                (ggtags-project-has-path-style (ggtags-find-project))
884                                "--path-style=shorter")
885                           (and ggtags-global-treat-text "--other")
886                           (pcase cmd
887                             ((pred stringp) cmd)
888                             (`definition nil) ;-d not supported by Global 5.7.1
889                             (`reference "--reference")
890                             (`symbol "--symbol")
891                             (`path "--path")
892                             (`grep "--grep")
893                             (`idutils "--idutils")))
894                     args)))
895     (mapconcat #'identity (delq nil xs) " ")))
896
897 ;; Can be three values: nil, t and a marker; t means start marker has
898 ;; been saved in the tag ring.
899 (defvar ggtags-global-start-marker nil)
900 (defvar ggtags-global-start-file nil)
901 (defvar ggtags-tag-ring-index nil)
902 (defvar ggtags-global-search-history nil)
903
904 (defvar ggtags-auto-jump-to-match-target nil)
905
906 (defvar-local ggtags-global-exit-info nil) ; (EXIT-STATUS COUNT DB)
907
908 (defun ggtags-global-save-start-marker ()
909   (when (markerp ggtags-global-start-marker)
910     (setq ggtags-tag-ring-index nil)
911     (xref-push-marker-stack ggtags-global-start-marker)
912     (setq ggtags-global-start-marker t)))
913
914 (defun ggtags-global-start (command &optional directory)
915   (let* ((default-directory (or directory (ggtags-current-project-root)))
916          (split-window-preferred-function ggtags-split-window-function)
917          (env ggtags-process-environment))
918     (unless (and (markerp ggtags-global-start-marker)
919                  (marker-position ggtags-global-start-marker))
920       (setq ggtags-global-start-marker (point-marker)))
921     ;; Record the file name for `ggtags-navigation-start-file'.
922     (setq ggtags-global-start-file buffer-file-name)
923     (setq ggtags-auto-jump-to-match-target
924           (nth 4 (assoc (ggtags-global-search-id command default-directory)
925                         ggtags-global-search-history)))
926     (ggtags-navigation-mode +1)
927     (ggtags-update-tags)
928     (ggtags-with-current-project
929       (with-current-buffer (with-display-buffer-no-window
930                              (compilation-start command 'ggtags-global-mode))
931         (setq-local ggtags-process-environment env)
932         (setq ggtags-global-last-buffer (current-buffer))))))
933
934 (defun ggtags-find-tag-continue ()
935   (interactive)
936   (ggtags-ensure-global-buffer
937     (ggtags-navigation-mode +1)
938     (let ((split-window-preferred-function ggtags-split-window-function))
939       (ignore-errors (compilation-next-error 1))
940       (compile-goto-error))))
941
942 (defun ggtags-find-tag (cmd &rest args)
943   (ggtags-check-project)
944   (ggtags-global-start (apply #'ggtags-global-build-command cmd args)))
945
946 (defun ggtags-include-file ()
947   "Calculate the include file based on `ggtags-include-pattern'."
948   (pcase ggtags-include-pattern
949     (`nil nil)
950     ((pred functionp)
951      (funcall ggtags-include-pattern))
952     (`(,re . ,sub)
953      (save-excursion
954        (beginning-of-line)
955        (and (looking-at re) (match-string sub))))
956     (_ (warn "Invalid value for `ggtags-include-pattern': %s"
957              ggtags-include-pattern)
958        nil)))
959
960 ;;;###autoload
961 (defun ggtags-find-tag-dwim (name &optional what)
962   "Find NAME by context.
963 If point is at a definition tag, find references, and vice versa.
964 If point is at a line that matches `ggtags-include-pattern', find
965 the include file instead.
966
967 When called interactively with a prefix arg, always find
968 definition tags."
969   (interactive
970    (let ((include (and (not current-prefix-arg) (ggtags-include-file))))
971      (ggtags-ensure-project)
972      (if include (list include 'include)
973        (list (ggtags-read-tag 'definition current-prefix-arg)
974              (and current-prefix-arg 'definition)))))
975   (ggtags-check-project)    ; For `ggtags-current-project-root' below.
976   (cond
977    ((eq what 'include)
978     (ggtags-find-file name))
979    ((or (eq what 'definition)
980         (not buffer-file-name)
981         (not (ggtags-project-has-refs (ggtags-find-project)))
982         (not (ggtags-project-file-p buffer-file-name)))
983     (ggtags-find-definition name))
984    (t (ggtags-find-tag
985        (format "--from-here=%d:%s"
986                (line-number-at-pos)
987                ;; Note `ggtags-find-tag' binds `default-directory' to
988                ;; project root.
989                (shell-quote-argument
990                 (ggtags-project-relative-file buffer-file-name)))
991        "--" (shell-quote-argument name)))))
992
993 (defun ggtags-find-tag-mouse (event)
994   (interactive "e")
995   (with-selected-window (posn-window (event-start event))
996     (save-excursion
997       (goto-char (posn-point (event-start event)))
998       (call-interactively #'ggtags-find-tag-dwim))))
999
1000 ;; Another option for `M-.'.
1001 (defun ggtags-find-definition (name)
1002   (interactive (list (ggtags-read-tag 'definition current-prefix-arg)))
1003   (ggtags-find-tag 'definition "--" (shell-quote-argument name)))
1004
1005 (defun ggtags-setup-libpath-search (type name)
1006   (pcase (and ggtags-global-search-libpath-for-reference
1007               (ggtags-get-libpath))
1008     ((and libs (guard libs))
1009      (cl-labels ((cont (buf how)
1010                    (pcase ggtags-global-exit-info
1011                      (`(0 0 ,_)
1012                       (with-temp-buffer
1013                         (setq default-directory
1014                               (file-name-as-directory (pop libs)))
1015                         (and libs (setq ggtags-global-continuation #'cont))
1016                         (if (ggtags-find-project)
1017                             (ggtags-find-tag type (shell-quote-argument name))
1018                           (cont buf how))))
1019                      (_ (ggtags-global-handle-exit buf how)))))
1020        (setq ggtags-global-continuation #'cont)))))
1021
1022 (defun ggtags-find-reference (name)
1023   (interactive (list (ggtags-read-tag 'reference current-prefix-arg)))
1024   (ggtags-setup-libpath-search 'reference name)
1025   (ggtags-find-tag 'reference "--" (shell-quote-argument name)))
1026
1027 (defun ggtags-find-other-symbol (name)
1028   "Find tag NAME that is a reference without a definition."
1029   (interactive (list (ggtags-read-tag 'symbol current-prefix-arg)))
1030   (ggtags-setup-libpath-search 'symbol name)
1031   (ggtags-find-tag 'symbol "--" (shell-quote-argument name)))
1032
1033 (defun ggtags-quote-pattern (pattern)
1034   (prin1-to-string (substring-no-properties pattern)))
1035
1036 (defun ggtags-idutils-query (pattern)
1037   (interactive (list (ggtags-read-tag 'id t)))
1038   (ggtags-find-tag 'idutils "--" (ggtags-quote-pattern pattern)))
1039
1040 (defun ggtags-grep (pattern &optional invert-match)
1041   "Grep for lines matching PATTERN.
1042 Invert the match when called with a prefix arg \\[universal-argument]."
1043   (interactive (list (ggtags-read-tag 'definition 'confirm
1044                                       (if current-prefix-arg
1045                                           "Inverted grep pattern" "Grep pattern"))
1046                      current-prefix-arg))
1047   (ggtags-find-tag 'grep (and invert-match "--invert-match")
1048                    "--" (ggtags-quote-pattern pattern)))
1049
1050 (defun ggtags-find-file (pattern &optional invert-match)
1051   (interactive (list (ggtags-read-tag 'path 'confirm (if current-prefix-arg
1052                                                          "Inverted path pattern"
1053                                                        "Path pattern")
1054                                       nil (thing-at-point 'filename))
1055                      current-prefix-arg))
1056   (let ((ggtags-global-output-format 'path))
1057     (ggtags-find-tag 'path (and invert-match "--invert-match")
1058                      "--" (ggtags-quote-pattern pattern))))
1059
1060 ;; Note: Coloured output requested in http://goo.gl/Y9IcX and appeared
1061 ;; in global v6.2.12.
1062 (defun ggtags-find-tag-regexp (regexp directory)
1063   "List tags matching REGEXP in DIRECTORY (default to project root).
1064 When called interactively with a prefix, ask for the directory."
1065   (interactive
1066    (progn
1067      (ggtags-check-project)
1068      (list (ggtags-read-tag "" t "POSIX regexp")
1069            (if current-prefix-arg
1070                (read-directory-name "Directory: " nil nil t)
1071              (ggtags-current-project-root)))))
1072   (ggtags-check-project)
1073   (ggtags-global-start
1074    (ggtags-global-build-command nil nil "-l" "--" (ggtags-quote-pattern regexp))
1075    (file-name-as-directory directory)))
1076
1077 (defvar ggtags-navigation-mode)
1078
1079 (defun ggtags-foreach-file (fn)
1080   "Invoke FN with each file found.
1081 FN is invoked while *ggtags-global* buffer is current."
1082   (ggtags-ensure-global-buffer
1083     (save-excursion
1084       (goto-char (point-min))
1085       (while (with-demoted-errors "compilation-next-error: %S"
1086                (compilation-next-error 1 'file)
1087                t)
1088         (funcall fn (caar
1089                      (compilation--loc->file-struct
1090                       (compilation--message->loc
1091                        (get-text-property (point) 'compilation-message)))))))))
1092
1093 (defun ggtags-query-replace (from to &optional delimited)
1094   "Query replace FROM with TO on files in the Global buffer.
1095 If not in navigation mode, do a grep on FROM first.
1096
1097 Note: the regular expression FROM must be supported by both
1098 Global and Emacs."
1099   (interactive
1100    ;; Note: in 24.4 query-replace-read-args returns a list of 4 elements.
1101    (let ((args (query-replace-read-args "Query replace (regexp)" t t)))
1102      (list (nth 0 args) (nth 1 args) (nth 2 args))))
1103   (unless ggtags-navigation-mode
1104     (let ((ggtags-auto-jump-to-match nil))
1105       (ggtags-grep from)))
1106   (let ((file-form
1107          '(let ((files))
1108             (ggtags-ensure-global-buffer
1109               (ggtags-with-temp-message "Waiting for Grep to finish..."
1110                 (while (get-buffer-process (current-buffer))
1111                   (sit-for 0.2)))
1112               (ggtags-foreach-file
1113                (lambda (file) (push (expand-file-name file) files))))
1114             (ggtags-navigation-mode -1)
1115             (nreverse files))))
1116     (tags-query-replace from to delimited file-form)))
1117
1118 (defun ggtags-global-normalise-command (cmd)
1119   (if (string-match
1120        (concat (regexp-quote (ggtags-global-build-command nil)) "\\s-*")
1121        cmd)
1122       (substring-no-properties cmd (match-end 0))
1123     cmd))
1124
1125 (defun ggtags-global-search-id (cmd directory)
1126   (sha1 (concat directory (make-string 1 0)
1127                 (ggtags-global-normalise-command cmd))))
1128
1129 (defun ggtags-global-current-search ()
1130   ;; CMD DIR ENV LINE TEXT
1131   (ggtags-ensure-global-buffer
1132     (list (ggtags-global-normalise-command (car compilation-arguments))
1133           default-directory
1134           ggtags-process-environment
1135           (line-number-at-pos)
1136           (buffer-substring-no-properties
1137            (line-beginning-position) (line-end-position)))))
1138
1139 (defun ggtags-global-rerun-search (data)
1140   (pcase data
1141     (`(,cmd ,dir ,env ,line ,_text)
1142      (with-current-buffer (let ((ggtags-auto-jump-to-match nil)
1143                                 ;; Switch current project to DIR.
1144                                 (default-directory dir)
1145                                 (ggtags-project-root dir)
1146                                 (ggtags-process-environment env))
1147                             (ggtags-global-start
1148                              (ggtags-global-build-command cmd) dir))
1149        (add-hook 'compilation-finish-functions
1150                  (lambda (buf _msg)
1151                    (with-current-buffer buf
1152                      (ggtags-forward-to-line line)
1153                      (compile-goto-error)))
1154                  nil t)))))
1155
1156 (defvar-local ggtags-global-search-ewoc nil)
1157 (defvar ggtags-view-search-history-last nil)
1158
1159 (defvar ggtags-view-search-history-mode-map
1160   (let ((m (make-sparse-keymap)))
1161     (define-key m "p" 'ggtags-view-search-history-prev)
1162     (define-key m "\M-p" 'ggtags-view-search-history-prev)
1163     (define-key m "n" 'ggtags-view-search-history-next)
1164     (define-key m "\M-n" 'ggtags-view-search-history-next)
1165     (define-key m "\C-k" 'ggtags-view-search-history-kill)
1166     (define-key m [remap yank] (lambda (&optional arg) (interactive "P") (yank arg)))
1167     (define-key m "\C-c\C-c" 'ggtags-view-search-history-update)
1168     (define-key m "r" 'ggtags-save-to-register)
1169     (define-key m "\r" 'ggtags-view-search-history-action)
1170     (define-key m "q" 'ggtags-kill-window)
1171     m))
1172
1173 (defun ggtags-view-search-history-remember ()
1174   (setq ggtags-view-search-history-last
1175         (pcase (ewoc-locate ggtags-global-search-ewoc)
1176           (`nil nil)
1177           (node (ewoc-data node)))))
1178
1179 (defun ggtags-view-search-history-next (&optional arg)
1180   (interactive "p")
1181   (let ((arg (or arg 1)))
1182     (prog1 (funcall (if (cl-minusp arg) #'ewoc-goto-prev #'ewoc-goto-next)
1183                     ggtags-global-search-ewoc (abs arg))
1184       (ggtags-view-search-history-remember))))
1185
1186 (defun ggtags-view-search-history-prev (&optional arg)
1187   (interactive "p")
1188   (ggtags-view-search-history-next (- (or arg 1))))
1189
1190 (defun ggtags-view-search-history-kill (&optional append)
1191   (interactive "P")
1192   (let* ((node (or (ewoc-locate ggtags-global-search-ewoc)
1193                    (user-error "No node at point")))
1194          (next (ewoc-next ggtags-global-search-ewoc node))
1195          (text (filter-buffer-substring (ewoc-location node)
1196                                         (if next (ewoc-location next)
1197                                           (point-max)))))
1198     (put-text-property
1199      0 (length text) 'yank-handler
1200      (list (lambda (arg)
1201              (if (not ggtags-global-search-ewoc)
1202                  (insert (car arg))
1203                (let* ((inhibit-read-only t)
1204                       (node (unless (looking-at-p "[ \t\n]*\\'")
1205                               (ewoc-locate ggtags-global-search-ewoc))))
1206                  (if node
1207                      (ewoc-enter-before ggtags-global-search-ewoc
1208                                         node (cadr arg))
1209                    (ewoc-enter-last ggtags-global-search-ewoc (cadr arg)))
1210                  (setq ggtags-view-search-history-last (cadr arg)))))
1211            (list text (ewoc-data node)))
1212      text)
1213     (if append (kill-append text nil)
1214       (kill-new text))
1215     (let ((inhibit-read-only t))
1216       (ewoc-delete ggtags-global-search-ewoc node))))
1217
1218 (defun ggtags-view-search-history-update (&optional noconfirm)
1219   "Update `ggtags-global-search-history' to current buffer."
1220   (interactive "P")
1221   (when (and (buffer-modified-p)
1222              (or noconfirm
1223                  (yes-or-no-p "Modify `ggtags-global-search-history'?")))
1224     (setq ggtags-global-search-history
1225           (ewoc-collect ggtags-global-search-ewoc #'identity))
1226     (set-buffer-modified-p nil)))
1227
1228 (defun ggtags-view-search-history-action ()
1229   (interactive)
1230   (let ((data (ewoc-data (or (ewoc-locate ggtags-global-search-ewoc)
1231                              (user-error "No search at point")))))
1232     (ggtags-view-search-history-remember)
1233     (quit-window t)
1234     (ggtags-global-rerun-search (cdr data))))
1235
1236 (defvar bookmark-make-record-function)
1237
1238 (define-derived-mode ggtags-view-search-history-mode special-mode "SearchHist"
1239   "Major mode for viewing search history."
1240   :group 'ggtags
1241   (setq-local ggtags-enable-navigation-keys nil)
1242   (setq-local bookmark-make-record-function #'ggtags-make-bookmark-record)
1243   (setq truncate-lines t)
1244   (add-hook 'kill-buffer-hook #'ggtags-view-search-history-update nil t))
1245
1246 (defun ggtags-view-search-history-restore-last ()
1247   (when ggtags-view-search-history-last
1248     (cl-loop for n = (ewoc-nth ggtags-global-search-ewoc 0)
1249              then (ewoc-next ggtags-global-search-ewoc n)
1250              while n when (eq (ewoc-data n)
1251                               ggtags-view-search-history-last)
1252              do (progn (goto-char (ewoc-location n)) (cl-return t)))))
1253
1254 (defun ggtags-view-search-history ()
1255   "Pop to a buffer to view or re-run past searches.
1256
1257 \\{ggtags-view-search-history-mode-map}"
1258   (interactive)
1259   (or ggtags-global-search-history (user-error "No search history"))
1260   (let ((split-window-preferred-function ggtags-split-window-function)
1261         (inhibit-read-only t))
1262     (pop-to-buffer "*Ggtags Search History*")
1263     (erase-buffer)
1264     (ggtags-view-search-history-mode)
1265     (cl-labels ((prop (s)
1266                   (propertize s 'face 'minibuffer-prompt))
1267                 (prop-tag (cmd)
1268                   (with-temp-buffer
1269                     (insert cmd)
1270                     (forward-sexp -1)
1271                     (if (eobp)
1272                         cmd
1273                       (put-text-property (point) (point-max)
1274                                          'face font-lock-constant-face)
1275                       (buffer-string))))
1276                 (pp (data)
1277                   (pcase data
1278                     (`(,_id ,cmd ,dir ,_env ,line ,text)
1279                      (insert (prop " cmd: ") (prop-tag cmd) "\n"
1280                              (prop " dir: ") dir "\n"
1281                              (prop "line: ") (number-to-string line) "\n"
1282                              (prop "text: ") text "\n"
1283                              (propertize (make-string 32 ?-) 'face 'shadow))))))
1284       (setq ggtags-global-search-ewoc
1285             (ewoc-create #'pp "Global search history keys:  n:next  p:prev  r:register  RET:choose\n")))
1286     (dolist (data ggtags-global-search-history)
1287       (ewoc-enter-last ggtags-global-search-ewoc data))
1288     (ggtags-view-search-history-restore-last)
1289     (set-buffer-modified-p nil)
1290     (fit-window-to-buffer nil (floor (frame-height) 2))))
1291
1292 (defun ggtags-save-to-register (r)
1293   "Save current search session to register R.
1294 Use \\[jump-to-register] to restore the search session."
1295   (interactive (list (register-read-with-preview "Save search to register: ")))
1296   (cl-labels ((prn (data)
1297                 (pcase data
1298                   (`(,command ,root ,_env ,line ,_)
1299                    (princ (format "a ggtags search session `%s' in directory `%s' at line %d."
1300                                   command root line))))))
1301     (set-register r (registerv-make
1302                      (if ggtags-global-search-ewoc
1303                          (cdr (ewoc-data (ewoc-locate ggtags-global-search-ewoc)))
1304                        (ggtags-global-current-search))
1305                      :jump-func #'ggtags-global-rerun-search
1306                      :print-func #'prn))))
1307
1308 (defun ggtags-make-bookmark-record ()
1309   `(,(and ggtags-current-tag-name (format "*ggtags %s*" ggtags-current-tag-name))
1310     (ggtags-search . ,(if ggtags-global-search-ewoc
1311                           (cdr (ewoc-data (ewoc-locate ggtags-global-search-ewoc)))
1312                         (ggtags-global-current-search)))
1313     (handler . ggtags-bookmark-jump)))
1314
1315 (declare-function bookmark-prop-get "bookmark")
1316
1317 (defun ggtags-bookmark-jump (bmk)
1318   (ggtags-global-rerun-search (bookmark-prop-get bmk 'ggtags-search)))
1319
1320 (defun ggtags-browse-file-as-hypertext (file line)
1321   "Browse FILE in hypertext (HTML) form."
1322   (interactive (if (or current-prefix-arg (not buffer-file-name))
1323                    (list (read-file-name "Browse file: " nil nil t)
1324                          (read-number "Line: " 1))
1325                  (list buffer-file-name (line-number-at-pos))))
1326   (cl-check-type line (integer 1))
1327   (or (and file (file-exists-p file)) (error "File `%s' doesn't exist" file))
1328   (ggtags-check-project)
1329   (or (file-exists-p (expand-file-name "HTML" (ggtags-current-project-root)))
1330       (if (yes-or-no-p "No hypertext form exists; run htags? ")
1331           (let ((default-directory (ggtags-current-project-root)))
1332             (ggtags-with-current-project (ggtags-process-string "htags")))
1333         (user-error "Aborted")))
1334   (let ((url (ggtags-process-string "gozilla" "-p" (format "+%d" line)
1335                                     (file-relative-name file))))
1336     (or (equal (file-name-extension
1337                 (url-filename (url-generic-parse-url url))) "html")
1338         (user-error "No hypertext form for `%s'" file))
1339     (when (called-interactively-p 'interactive)
1340       (message "Browsing %s" url))
1341     (browse-url url)))
1342
1343 (defun ggtags-next-mark (&optional arg)
1344   "Move to the next (newer) mark in the tag marker ring."
1345   (interactive)
1346   (and (ring-empty-p xref--marker-ring) (user-error "Tag ring empty"))
1347   (setq ggtags-tag-ring-index
1348         ;; Note `ring-minus1' gets newer item.
1349         (funcall (if arg #'ring-plus1 #'ring-minus1)
1350                  (or ggtags-tag-ring-index
1351                      (progn (xref-push-marker-stack)
1352                             0))
1353                  (ring-length xref--marker-ring)))
1354   (let ((m (ring-ref xref--marker-ring ggtags-tag-ring-index))
1355         (i (- (ring-length xref--marker-ring) ggtags-tag-ring-index)))
1356     (ggtags-echo "%d%s marker%s" i (pcase (mod i 10)
1357                                      (1 "st")
1358                                      (2 "nd")
1359                                      (3 "rd")
1360                                      (_ "th"))
1361                  (if (marker-buffer m) "" " (dead)"))
1362     (if (not (marker-buffer m))
1363         (ding)
1364       (switch-to-buffer (marker-buffer m))
1365       (goto-char m))))
1366
1367 (defun ggtags-prev-mark ()
1368   "Move to the previous (older) mark in the tag marker ring."
1369   (interactive)
1370   (ggtags-next-mark 'previous))
1371
1372 (defvar ggtags-view-tag-history-mode-map
1373   (let ((m (make-sparse-keymap)))
1374     (define-key m "\M-n" 'next-error-no-select)
1375     (define-key m "\M-p" 'previous-error-no-select)
1376     (define-key m "q"    'ggtags-kill-window)
1377     m))
1378
1379 (define-derived-mode ggtags-view-tag-history-mode tabulated-list-mode "TagHist"
1380   :abbrev-table nil :group 'ggtags)
1381
1382 (defun ggtags-view-tag-history ()
1383   "Pop to a buffer listing visited locations from newest to oldest.
1384 The buffer is a next error buffer and works with standard
1385 commands `next-error' and `previous-error'.
1386
1387 \\{ggtags-view-tag-history-mode-map}"
1388   (interactive)
1389   (and (ring-empty-p xref--marker-ring)
1390        (user-error "Tag ring empty"))
1391   (let ((split-window-preferred-function ggtags-split-window-function)
1392         (inhibit-read-only t))
1393     (pop-to-buffer "*Tag Ring*")
1394     (erase-buffer)
1395     (ggtags-view-tag-history-mode)
1396     (setq next-error-function #'ggtags-view-tag-history-next-error
1397           next-error-last-buffer (current-buffer))
1398     (setq tabulated-list-entries
1399           ;; Use a function so that revert can work properly.
1400           (lambda ()
1401             (let ((counter (ring-length xref--marker-ring))
1402                   (elements (or (ring-elements xref--marker-ring)
1403                                 (user-error "Tag ring empty")))
1404                   (action (lambda (_button) (next-error 0)))
1405                   (get-line (lambda (m)
1406                               (with-current-buffer (marker-buffer m)
1407                                 (save-excursion
1408                                   (goto-char m)
1409                                   (buffer-substring (line-beginning-position)
1410                                                     (line-end-position)))))))
1411               (setq tabulated-list-format
1412                     `[("ID" ,(max (1+ (floor (log counter 10))) 2)
1413                        car-less-than-car)
1414                       ("Buffer" ,(max (cl-loop for m in elements
1415                                                for b = (marker-buffer m)
1416                                                maximize
1417                                                (length (and b (buffer-name b))))
1418                                       6)
1419                        t :right-align t)
1420                       ("Position" ,(max (cl-loop for m in elements
1421                                                  for p = (or (marker-position m) 1)
1422                                                  maximize (1+ (floor (log p 10))))
1423                                         8)
1424                        (lambda (x y)
1425                          (< (string-to-number (aref (cadr x) 2))
1426                             (string-to-number (aref (cadr y) 2))))
1427                        :right-align t)
1428                       ("Contents" 100 t)])
1429               (tabulated-list-init-header)
1430               (mapcar (lambda (x)
1431                         (prog1
1432                             (list counter
1433                                   (if (marker-buffer x)
1434                                       (vector (number-to-string counter)
1435                                               `(,(buffer-name (marker-buffer x))
1436                                                 face link
1437                                                 follow-link t
1438                                                 marker ,x
1439                                                 action ,action)
1440                                               (number-to-string (marker-position x))
1441                                               (funcall get-line x))
1442                                     (vector (number-to-string counter)
1443                                             "(dead)" "?" "?")))
1444                           (cl-decf counter)))
1445                       elements))))
1446     (setq tabulated-list-sort-key '("ID" . t))
1447     (tabulated-list-print)
1448     (fit-window-to-buffer nil (floor (frame-height) 2))))
1449
1450 (defun ggtags-view-tag-history-next-error (&optional arg reset)
1451   (if (not reset)
1452       (forward-button arg)
1453     (goto-char (point-min))
1454     (forward-button (if (button-at (point)) 0 1)))
1455   (when (get-buffer-window)
1456     (set-window-point (get-buffer-window) (point)))
1457   (pcase (button-get (button-at (point)) 'marker)
1458     ((and (pred markerp) m)
1459      (if (eq (get-buffer-window) (selected-window))
1460          (pop-to-buffer (marker-buffer m))
1461        (switch-to-buffer (marker-buffer m)))
1462      (goto-char (marker-position m)))
1463     (_ (error "Dead marker"))))
1464
1465 (defun ggtags-global-exit-message-1 ()
1466   "Get the total of matches and db file used."
1467   (save-excursion
1468     (goto-char (point-max))
1469     (if (re-search-backward
1470          "^\\w+ \\(not found\\)\\|^\\([0-9]+\\) \\w+ located" nil t)
1471         (cons (or (and (match-string 1) 0)
1472                   (string-to-number (match-string 2)))
1473               (when (re-search-forward
1474                      "using \\(?:\\(idutils\\)\\|'[^']*/\\(\\w+\\)'\\)"
1475                      (line-end-position)
1476                      t)
1477                 (or (and (match-string 1) "ID")
1478                     (match-string 2))))
1479       (cons 0 nil))))
1480
1481 (defun ggtags-global-exit-message-function (_process-status exit-status msg)
1482   "A function for `compilation-exit-message-function'."
1483   (pcase (ggtags-global-exit-message-1)
1484     (`(,count . ,db)
1485      (setq ggtags-global-exit-info (list exit-status count db))
1486      ;; Clear the start marker in case of zero matches.
1487      (and (zerop count)
1488           (markerp ggtags-global-start-marker)
1489           (not ggtags-global-continuation)
1490           (setq ggtags-global-start-marker nil))
1491      (cons (if (> exit-status 0)
1492                msg
1493              (format "found %d %s" count
1494                      (funcall (if (= count 1) #'car #'cadr)
1495                               (pcase db
1496                                 ("GTAGS"  '("definition" "definitions"))
1497                                 ("GSYMS"  '("symbol"     "symbols"))
1498                                 ("GRTAGS" '("reference"  "references"))
1499                                 ("GPATH"  '("file"       "files"))
1500                                 ("ID"     '("identifier" "identifiers"))
1501                                 (_         '("match"      "matches"))))))
1502            exit-status))))
1503
1504 (defun ggtags-global-column (start)
1505   ;; START is the beginning position of source text.
1506   (let ((mbeg (text-property-any start (line-end-position) 'global-color t)))
1507     (and mbeg (- mbeg start))))
1508
1509 ;;; NOTE: Must not match the 'Global started at Mon Jun 3 10:24:13'
1510 ;;; line or `compilation-auto-jump' will jump there and fail. See
1511 ;;; comments before the 'gnu' entry in
1512 ;;; `compilation-error-regexp-alist-alist'.
1513 (defvar ggtags-global-error-regexp-alist-alist
1514   (append
1515    `((path "^\\(?:[^\"'\n]*/\\)?[^ )\t\n]+$" 0)
1516      ;; ACTIVE_ESCAPE   src/dialog.cc   172
1517      (ctags "^\\([^ \t\n]+\\)[ \t]+\\(.*?\\)[ \t]+\\([0-9]+\\)$"
1518             2 3 nil nil 2 (1 font-lock-function-name-face))
1519      ;; ACTIVE_ESCAPE     172 src/dialog.cc    #undef ACTIVE_ESCAPE
1520      (ctags-x "^\\([^ \t\n]+\\)[ \t]+\\([0-9]+\\)[ \t]+\\(\\(?:[^/\n]*/\\)?[^ \t\n]+\\)"
1521               3 2 (,(lambda () (ggtags-global-column (1+ (match-end 0)))))
1522               nil 3 (1 font-lock-function-name-face))
1523      ;; src/dialog.cc:172:#undef ACTIVE_ESCAPE
1524      (grep "^\\(.+?\\):\\([0-9]+\\):\\(?:$\\|[^0-9\n]\\|[0-9][^0-9\n]\\|[0-9][0-9].\\)"
1525            1 2 (,(lambda () (ggtags-global-column (1+ (match-end 2))))) nil 1)
1526      ;; src/dialog.cc ACTIVE_ESCAPE 172 #undef ACTIVE_ESCAPE
1527      (cscope "^\\(.+?\\)[ \t]+\\([^ \t\n]+\\)[ \t]+\\([0-9]+\\).*\\(?:[^0-9\n]\\|[^0-9\n][0-9]\\|[^:\n][0-9][0-9]\\)$"
1528              1 3 nil nil 1 (2 font-lock-function-name-face)))
1529    compilation-error-regexp-alist-alist))
1530
1531 (defun ggtags-abbreviate-file (start end)
1532   (let ((inhibit-read-only t)
1533         (amount (if (numberp ggtags-global-abbreviate-filename)
1534                     (- (- end start) ggtags-global-abbreviate-filename)
1535                   999))
1536         (advance-word (lambda ()
1537                         "Return the length of the text made invisible."
1538                         (let ((wend (min end (progn (forward-word 1) (point))))
1539                               (wbeg (max start (progn (backward-word 1) (point)))))
1540                           (goto-char wend)
1541                           (if (<= (- wend wbeg) 1)
1542                               0
1543                             (put-text-property (1+ wbeg) wend 'invisible t)
1544                             (1- (- wend wbeg)))))))
1545     (goto-char start)
1546     (while (and (> amount 0) (> end (point)))
1547       (cl-decf amount (funcall advance-word)))))
1548
1549 (defun ggtags-abbreviate-files (start end)
1550   (goto-char start)
1551   (let* ((error-re (cdr (assq (car compilation-error-regexp-alist)
1552                               ggtags-global-error-regexp-alist-alist)))
1553          (sub (cadr error-re)))
1554     (when (and ggtags-global-abbreviate-filename error-re)
1555       (while (re-search-forward (car error-re) end t)
1556         (when (and (or (not (numberp ggtags-global-abbreviate-filename))
1557                        (> (length (match-string sub))
1558                           ggtags-global-abbreviate-filename))
1559                    ;; Ignore bogus file lines such as:
1560                    ;;     Global found 2 matches at Thu Jan 31 13:45:19
1561                    (get-text-property (match-beginning sub) 'compilation-message))
1562           (ggtags-abbreviate-file (match-beginning sub) (match-end sub)))))))
1563
1564 (defvar-local ggtags-global-output-lines 0)
1565
1566 (defun ggtags-global--display-buffer (&optional buffer desired-point)
1567   (pcase (let ((buffer (or buffer (current-buffer)))
1568                (split-window-preferred-function ggtags-split-window-function))
1569            (and (not (get-buffer-window buffer))
1570                 (display-buffer buffer '(nil (allow-no-window . t)))))
1571     ((and (pred windowp) w)
1572      (with-selected-window w
1573        (compilation-set-window-height w)
1574        (and desired-point (goto-char desired-point))))))
1575
1576 (defun ggtags-global-filter ()
1577   "Called from `compilation-filter-hook' (which see)."
1578   (let ((ansi-color-apply-face-function
1579          (lambda (beg end face)
1580            (when face
1581              (ansi-color-apply-overlay-face beg end face)
1582              (put-text-property beg end 'global-color t)))))
1583     (ansi-color-apply-on-region compilation-filter-start (point)))
1584   ;; Get rid of line "Using config file '/PATH/TO/.globalrc'." or
1585   ;; "Using default configuration."
1586   (when (re-search-backward
1587          "^ *Using \\(?:config file '.*\\|default configuration.\\)\n"
1588          compilation-filter-start t)
1589     (replace-match ""))
1590   (cl-incf ggtags-global-output-lines
1591            (count-lines compilation-filter-start (point)))
1592   ;; If the number of output lines is small
1593   ;; `ggtags-global-handle-exit' takes care of displaying the buffer.
1594   (when (and (> ggtags-global-output-lines 30) ggtags-navigation-mode)
1595     (ggtags-global--display-buffer nil (or compilation-current-error (point-min))))
1596   (when (and (eq ggtags-auto-jump-to-match 'history)
1597              (numberp ggtags-auto-jump-to-match-target)
1598              (not compilation-current-error)
1599              ;; `ggtags-global-output-lines' is imprecise but use it
1600              ;; as first approximation.
1601              (> (+ 10 ggtags-global-output-lines) ggtags-auto-jump-to-match-target)
1602              (> (line-number-at-pos (point-max))
1603                 ggtags-auto-jump-to-match-target))
1604     (ggtags-forward-to-line ggtags-auto-jump-to-match-target)
1605     (setq-local ggtags-auto-jump-to-match-target nil)
1606     (ggtags-delay-finish-functions
1607       (with-display-buffer-no-window
1608         (condition-case nil
1609             (let ((compilation-auto-jump-to-first-error t))
1610               (compilation-auto-jump (current-buffer) (point)))
1611           (error (message "\
1612 ggtags: history match invalid, jump to first match instead")
1613                  (first-error)))))
1614     ;; `compilation-filter' restores point and as a result commands
1615     ;; dependent on point such as `ggtags-navigation-next-file' and
1616     ;; `ggtags-navigation-previous-file' fail to work.
1617     (run-with-idle-timer
1618      0 nil
1619      (lambda (buf pt)
1620        (and (buffer-live-p buf)
1621             (with-current-buffer buf (goto-char pt))))
1622      (current-buffer) (point)))
1623   (make-local-variable 'ggtags-global-large-output)
1624   (when (> ggtags-global-output-lines ggtags-global-large-output)
1625     (cl-incf ggtags-global-large-output 500)
1626     (ggtags-echo "Output %d lines (Type `C-c C-k' to cancel)"
1627                  ggtags-global-output-lines)))
1628
1629 (defun ggtags-global-handle-exit (buf how)
1630   "A function for `compilation-finish-functions' (which see)."
1631   (cond
1632    (ggtags-global-continuation
1633     (let ((cont (prog1 ggtags-global-continuation
1634                   (setq ggtags-global-continuation nil))))
1635       (funcall cont buf how)))
1636    ((string-prefix-p "exited abnormally" how)
1637     ;; If exit abnormally display the buffer for inspection.
1638     (ggtags-global--display-buffer)
1639     (when (save-excursion
1640             (goto-char (point-max))
1641             (re-search-backward
1642              (eval-when-compile
1643                (format "^global: %s not found.$"
1644                        (regexp-opt '("GTAGS" "GRTAGS" "GSYMS" "GPATH"))))
1645              nil t))
1646       (ggtags-echo "WARNING: Global tag files missing in `%s'"
1647                    ggtags-project-root)
1648       (remhash ggtags-project-root ggtags-projects)))
1649    (ggtags-auto-jump-to-match
1650     (if (pcase (compilation-next-single-property-change
1651                 (point-min) 'compilation-message)
1652           ((and pt (guard pt))
1653            (compilation-next-single-property-change
1654             (save-excursion (goto-char pt) (end-of-line) (point))
1655             'compilation-message)))
1656         ;; There are multiple matches so pop up the buffer.
1657         (and ggtags-navigation-mode (ggtags-global--display-buffer))
1658       ;; Manually run the `compilation-auto-jump' timer. Hackish but
1659       ;; everything else seems unreliable. See:
1660       ;;
1661       ;; - http://debbugs.gnu.org/13829
1662       ;; - http://debbugs.gnu.org/23987
1663       ;; - https://github.com/leoliu/ggtags/issues/89
1664       ;;
1665       (pcase (cl-find 'compilation-auto-jump timer-list :key #'timer--function)
1666         (`nil )
1667         (timer (timer-event-handler timer)))
1668       (ggtags-navigation-mode -1)
1669       (ggtags-navigation-mode-cleanup buf t)))))
1670
1671 (defvar ggtags-global-mode-font-lock-keywords
1672   '(("^Global \\(exited abnormally\\|interrupt\\|killed\\|terminated\\)\\(?:.*with code \\([0-9]+\\)\\)?.*"
1673      (1 'compilation-error)
1674      (2 'compilation-error nil t))
1675     ("^Global found \\([0-9]+\\)" (1 compilation-info-face))))
1676
1677 (define-compilation-mode ggtags-global-mode "Global"
1678   "A mode for showing outputs from gnu global."
1679   ;; Note: Place `ggtags-global-output-format' as first element for
1680   ;; `ggtags-abbreviate-files'.
1681   (setq-local compilation-error-regexp-alist (list ggtags-global-output-format))
1682   (when (markerp ggtags-global-start-marker)
1683     (setq ggtags-project-root
1684           (buffer-local-value 'ggtags-project-root
1685                               (marker-buffer ggtags-global-start-marker))))
1686   (pcase ggtags-auto-jump-to-match
1687     (`history (make-local-variable 'ggtags-auto-jump-to-match-target)
1688               (setq-local compilation-auto-jump-to-first-error
1689                           (not ggtags-auto-jump-to-match-target)))
1690     (`nil (setq-local compilation-auto-jump-to-first-error nil))
1691     (_ (setq-local compilation-auto-jump-to-first-error t)))
1692   (setq-local compilation-scroll-output nil)
1693   ;; See `compilation-move-to-column' for details.
1694   (setq-local compilation-first-column 0)
1695   (setq-local compilation-error-screen-columns nil)
1696   (setq-local compilation-disable-input t)
1697   (setq-local compilation-always-kill t)
1698   (setq-local compilation-error-face 'compilation-info)
1699   (setq-local compilation-exit-message-function
1700               'ggtags-global-exit-message-function)
1701   ;; See: https://github.com/leoliu/ggtags/issues/26
1702   (setq-local find-file-suppress-same-file-warnings t)
1703   (setq-local truncate-lines t)
1704   (jit-lock-register #'ggtags-abbreviate-files)
1705   (add-hook 'compilation-filter-hook 'ggtags-global-filter nil 'local)
1706   (add-hook 'compilation-finish-functions 'ggtags-global-handle-exit nil t)
1707   (setq-local bookmark-make-record-function #'ggtags-make-bookmark-record)
1708   (setq-local ggtags-enable-navigation-keys nil)
1709   (add-hook 'kill-buffer-hook (lambda () (ggtags-navigation-mode -1)) nil t))
1710
1711 ;; NOTE: Need this to avoid putting menu items in
1712 ;; `emulation-mode-map-alists', which creates double entries. See
1713 ;; http://i.imgur.com/VJJTzVc.png
1714 (defvar ggtags-navigation-map
1715   (let ((map (make-sparse-keymap)))
1716     (define-key map "\M-n" 'next-error)
1717     (define-key map "\M-p" 'previous-error)
1718     (define-key map "\M-}" 'ggtags-navigation-next-file)
1719     (define-key map "\M-{" 'ggtags-navigation-previous-file)
1720     (define-key map "\M-=" 'ggtags-navigation-start-file)
1721     (define-key map "\M->" 'ggtags-navigation-last-error)
1722     (define-key map "\M-<" 'first-error)
1723     ;; Note: shadows `isearch-forward-regexp' but it can still be
1724     ;; invoked with `C-u C-s'.
1725     (define-key map "\C-\M-s" 'ggtags-navigation-isearch-forward)
1726     ;; Add an alternative binding because C-M-s is reported not
1727     ;; working on some systems.
1728     (define-key map "\M-ss" 'ggtags-navigation-isearch-forward)
1729     (define-key map "\C-c\C-k"
1730       (lambda () (interactive)
1731         (ggtags-ensure-global-buffer (kill-compilation))))
1732     (define-key map "\M-o" 'ggtags-navigation-visible-mode)
1733     (define-key map [return] 'ggtags-navigation-mode-done)
1734     (define-key map "\r" 'ggtags-navigation-mode-done)
1735     (define-key map [remap xref-pop-marker-stack] 'ggtags-navigation-mode-abort)
1736     map))
1737
1738 (defvar ggtags-mode-map-alist
1739   `((ggtags-enable-navigation-keys . ,ggtags-navigation-map)))
1740
1741 (defvar ggtags-navigation-mode-map
1742   (let ((map (make-sparse-keymap))
1743         (menu (make-sparse-keymap "GG-Navigation")))
1744     ;; Menu items: (info "(elisp)Extended Menu Items")
1745     (define-key map [menu-bar ggtags-navigation] (cons "GG-Navigation" menu))
1746     ;; Ordered backwards
1747     (define-key menu [visible-mode]
1748       '(menu-item "Visible mode" ggtags-navigation-visible-mode
1749                   :button (:toggle . (ignore-errors
1750                                        (ggtags-ensure-global-buffer
1751                                          visible-mode)))))
1752     (define-key menu [done]
1753       '(menu-item "Finish navigation" ggtags-navigation-mode-done))
1754     (define-key menu [abort]
1755       '(menu-item "Abort" ggtags-navigation-mode-abort))
1756     (define-key menu [last-match]
1757       '(menu-item "Last match" ggtags-navigation-last-error))
1758     (define-key menu [first-match] '(menu-item "First match" first-error))
1759     (define-key menu [previous-file]
1760       '(menu-item "Previous file" ggtags-navigation-previous-file))
1761     (define-key menu [next-file]
1762       '(menu-item "Next file" ggtags-navigation-next-file))
1763     (define-key menu [isearch-forward]
1764       '(menu-item "Find match with isearch" ggtags-navigation-isearch-forward))
1765     (define-key menu [previous]
1766       '(menu-item "Previous match" previous-error))
1767     (define-key menu [next]
1768       '(menu-item "Next match" next-error))
1769     map))
1770
1771 (defun ggtags-move-to-tag (&optional name)
1772   "Move to NAME tag in current line."
1773   (let ((tag (or name ggtags-current-tag-name)))
1774     ;; Do nothing if on the tag already i.e. by `ggtags-global-column'.
1775     (unless (or (not tag) (looking-at (concat (regexp-quote tag) "\\_>")))
1776       (let ((orig (point))
1777             (regexps (mapcar (lambda (fmtstr)
1778                                (format fmtstr (regexp-quote tag)))
1779                              '("\\_<%s\\_>" "%s\\_>" "%s"))))
1780         (beginning-of-line)
1781         (if (cl-loop for re in regexps
1782                      ;; Note: tag might not agree with current
1783                      ;; major-mode's symbol, so try harder. For
1784                      ;; example, in `php-mode' $cacheBackend is a
1785                      ;; symbol, but cacheBackend is a tag.
1786                      thereis (re-search-forward re (line-end-position) t))
1787             (goto-char (match-beginning 0))
1788           (goto-char orig))))))
1789
1790 (defun ggtags-navigation-mode-cleanup (&optional buf kill)
1791   (let ((buf (or buf ggtags-global-last-buffer)))
1792     (and (buffer-live-p buf)
1793          (with-current-buffer buf
1794            (when (get-buffer-process (current-buffer))
1795              (kill-compilation))
1796            (when (and (derived-mode-p 'ggtags-global-mode)
1797                       (get-buffer-window))
1798              (quit-windows-on (current-buffer)))
1799            (and kill (kill-buffer buf))))))
1800
1801 (defun ggtags-navigation-mode-done ()
1802   (interactive)
1803   (ggtags-navigation-mode -1)
1804   (setq tags-loop-scan t
1805         tags-loop-operate '(ggtags-find-tag-continue))
1806   (ggtags-navigation-mode-cleanup))
1807
1808 (defun ggtags-navigation-mode-abort ()
1809   "Abort navigation and return to where the search was started."
1810   (interactive)
1811   (ggtags-navigation-mode -1)
1812   (ggtags-navigation-mode-cleanup nil t)
1813   ;; Run after (ggtags-navigation-mode -1) or
1814   ;; ggtags-global-start-marker might not have been saved.
1815   (when (and ggtags-global-start-marker
1816              (not (markerp ggtags-global-start-marker)))
1817     (setq ggtags-global-start-marker nil)
1818     (xref-pop-marker-stack)))
1819
1820 (defun ggtags-navigation-next-file (n)
1821   (interactive "p")
1822   (ggtags-ensure-global-buffer
1823     (compilation-next-file n)
1824     (compile-goto-error)))
1825
1826 (defun ggtags-navigation-previous-file (n)
1827   (interactive "p")
1828   (ggtags-navigation-next-file (- n)))
1829
1830 (defun ggtags-navigation-start-file ()
1831   "Move to the file where navigation session starts."
1832   (interactive)
1833   (let ((start-file (or ggtags-global-start-file
1834                         (user-error "Cannot decide start file"))))
1835     (ggtags-ensure-global-buffer
1836       (pcase (cl-block nil
1837                (ggtags-foreach-file
1838                 (lambda (file)
1839                   (when (file-equal-p file start-file)
1840                     (cl-return (point))))))
1841         (`nil (user-error "No matches for `%s'" start-file))
1842         (n (goto-char n) (compile-goto-error))))))
1843
1844 (defun ggtags-navigation-last-error ()
1845   (interactive)
1846   (ggtags-ensure-global-buffer
1847     (goto-char (point-max))
1848     (compilation-previous-error 1)
1849     (compile-goto-error)))
1850
1851 (defun ggtags-navigation-isearch-forward (&optional regexp-p)
1852   (interactive "P")
1853   (ggtags-ensure-global-buffer
1854     (let ((saved (if visible-mode 1 -1)))
1855       (visible-mode 1)
1856       (with-selected-window (get-buffer-window (current-buffer))
1857         (isearch-forward regexp-p)
1858         (beginning-of-line)
1859         (visible-mode saved)
1860         (compile-goto-error)))))
1861
1862 (defun ggtags-navigation-visible-mode (&optional arg)
1863   (interactive (list (or current-prefix-arg 'toggle)))
1864   (ggtags-ensure-global-buffer
1865     (visible-mode arg)))
1866
1867 (defvar ggtags-global-line-overlay nil)
1868
1869 (defun ggtags-global-next-error-function ()
1870   (when (eq next-error-last-buffer ggtags-global-last-buffer)
1871     (ggtags-move-to-tag)
1872     (ggtags-global-save-start-marker)
1873     (and (ggtags-project-update-mtime-maybe)
1874          (message "File `%s' is newer than GTAGS"
1875                   (file-name-nondirectory buffer-file-name)))
1876     (and ggtags-mode-sticky (ggtags-mode 1))
1877     (ignore-errors
1878       (ggtags-ensure-global-buffer
1879         (unless (overlayp ggtags-global-line-overlay)
1880           (setq ggtags-global-line-overlay (make-overlay (point) (point)))
1881           (overlay-put ggtags-global-line-overlay 'face 'ggtags-global-line))
1882         (move-overlay ggtags-global-line-overlay
1883                       (line-beginning-position) (line-end-position)
1884                       (current-buffer))
1885         ;; Update search history
1886         (let ((id (ggtags-global-search-id (car compilation-arguments)
1887                                            default-directory)))
1888           (setq ggtags-global-search-history
1889                 (cl-remove id ggtags-global-search-history :test #'equal :key #'car))
1890           (add-to-history 'ggtags-global-search-history
1891                           (cons id (ggtags-global-current-search))
1892                           ggtags-global-history-length))))
1893     (run-hooks 'ggtags-find-tag-hook)))
1894
1895 (put 'ggtags-navigation-mode-lighter 'risky-local-variable t)
1896
1897 (defvar ggtags-navigation-mode-lighter
1898   '(" GG["
1899     (:eval
1900      (if (not (buffer-live-p ggtags-global-last-buffer))
1901          '(:propertize "??" face error help-echo "No Global buffer")
1902        (with-current-buffer ggtags-global-last-buffer
1903          (pcase (or ggtags-global-exit-info '(0 0 ""))
1904            (`(,exit ,count ,db)
1905             `((:propertize ,(pcase db
1906                               (`"GTAGS"  "D")
1907                               (`"GRTAGS" "R")
1908                               (`"GSYMS"  "S")
1909                               (`"GPATH"  "F")
1910                               (`"ID"     "I"))
1911                            face success)
1912               (:propertize
1913                ,(pcase (get-text-property (line-beginning-position)
1914                                           'compilation-message)
1915                   (`nil "?")
1916                   ;; Assume the first match appears at line 5
1917                   (_ (number-to-string (- (line-number-at-pos) 4))))
1918                face success)
1919               "/"
1920               (:propertize ,(number-to-string count) face success)
1921               ,(unless (zerop exit)
1922                  `(":" (:propertize ,(number-to-string exit) face error)))))))))
1923     "]")
1924   "Ligher for `ggtags-navigation-mode'; set to nil to disable it.")
1925
1926 (define-minor-mode ggtags-navigation-mode nil
1927   ;; If `ggtags-enable-navigation-keys' is set to nil only display the
1928   ;; lighter in `ggtags-mode' buffers.
1929   ;; See https://github.com/leoliu/ggtags/issues/124
1930   :lighter (:eval (and (or ggtags-enable-navigation-keys
1931                            ggtags-mode)
1932                        ggtags-navigation-mode-lighter))
1933   :global t
1934   (if ggtags-navigation-mode
1935       (progn
1936         ;; Higher priority for `ggtags-navigation-mode' to avoid being
1937         ;; hijacked by modes such as `view-mode'.
1938         (add-to-list 'emulation-mode-map-alists 'ggtags-mode-map-alist)
1939         (add-hook 'next-error-hook 'ggtags-global-next-error-function)
1940         (add-hook 'minibuffer-setup-hook 'ggtags-minibuffer-setup-function))
1941     (setq emulation-mode-map-alists
1942           (delq 'ggtags-mode-map-alist emulation-mode-map-alists))
1943     (remove-hook 'next-error-hook 'ggtags-global-next-error-function)
1944     (remove-hook 'minibuffer-setup-hook 'ggtags-minibuffer-setup-function)))
1945
1946 (defun ggtags-minibuffer-setup-function ()
1947   ;; Disable ggtags-navigation-mode in minibuffer.
1948   (setq-local ggtags-enable-navigation-keys nil))
1949
1950 (defun ggtags-kill-file-buffers (&optional interactive)
1951   "Kill all buffers visiting files in current project."
1952   (interactive "p")
1953   (ggtags-check-project)
1954   (let ((directories (cons (ggtags-current-project-root) (ggtags-get-libpath)))
1955         (count 0))
1956     (dolist (buf (buffer-list))
1957       (let ((file (and (buffer-live-p buf)
1958                        (not (eq buf (current-buffer)))
1959                        (buffer-file-name buf))))
1960         (when (and file (cl-some (lambda (dir)
1961                                    ;; Don't use `file-in-directory-p'
1962                                    ;; to allow symbolic links.
1963                                    (string-prefix-p dir file))
1964                                  directories))
1965           (and (kill-buffer buf) (cl-incf count)))))
1966     (and interactive
1967          (message "%d %s killed" count (if (= count 1) "buffer" "buffers")))))
1968
1969 (defun ggtags-after-save-function ()
1970   (when (ggtags-find-project)
1971     (ggtags-project-update-mtime-maybe)
1972     (and buffer-file-name ggtags-update-on-save
1973          (ggtags-update-tags-single buffer-file-name 'nowait))))
1974
1975 (defun ggtags-global-output (buffer cmds callback &optional cutoff sync)
1976   "Asynchronously pipe the output of running CMDS to BUFFER.
1977 When finished invoke CALLBACK in BUFFER with process exit status.
1978 If SYNC is non-nil, synchronously run CMDS and call CALLBACK."
1979   (or buffer (error "Output buffer required"))
1980   (when (get-buffer-process (get-buffer buffer))
1981     ;; Notice running multiple processes in the same buffer so that we
1982     ;; can fix the caller. See for example `ggtags-eldoc-function'.
1983     (message "Warning: detected %S already running in %S; interrupting..."
1984              (get-buffer-process buffer) buffer)
1985     (interrupt-process (get-buffer-process buffer)))
1986   (let* ((program (car cmds))
1987          (args (cdr cmds))
1988          (cutoff (and cutoff (+ cutoff (if (get-buffer buffer)
1989                                            (with-current-buffer buffer
1990                                              (line-number-at-pos (point-max)))
1991                                          0))))
1992          (proc (apply #'start-file-process program buffer program args))
1993          (filter (lambda (proc string)
1994                    (and (buffer-live-p (process-buffer proc))
1995                         (with-current-buffer (process-buffer proc)
1996                           (goto-char (process-mark proc))
1997                           (insert string)
1998                           (cl-incf (process-get proc :nlines)
1999                                    (count-lines (process-mark proc) (point)))
2000                           (set-marker (process-mark proc) (point))
2001                           (when (and (> (line-number-at-pos (point-max)) cutoff)
2002                                      (process-live-p proc))
2003                             (interrupt-process (current-buffer)))))))
2004          (sentinel (lambda (proc _msg)
2005                      (when (memq (process-status proc) '(exit signal))
2006                        (with-current-buffer (process-buffer proc)
2007                          (set-process-buffer proc nil)
2008                          (unwind-protect
2009                              (funcall callback (process-exit-status proc))
2010                            (process-put proc :callback-done t)))))))
2011     (set-process-query-on-exit-flag proc nil)
2012     (and cutoff (set-process-filter proc filter))
2013     (set-process-sentinel proc sentinel)
2014     (process-put proc :callback-done nil)
2015     (process-put proc :nlines 0)
2016     (if sync (while (not (process-get proc :callback-done))
2017                (accept-process-output proc 1))
2018       proc)))
2019
2020 (cl-defun ggtags-fontify-code (code &optional (mode major-mode))
2021   (cl-check-type mode function)
2022   (if (stringp code)
2023       (with-temp-buffer
2024         (insert code)
2025         (funcall mode)
2026         (font-lock-ensure)
2027         (buffer-string))
2028     code))
2029
2030 (defun ggtags-get-definition-default (defs)
2031   (and (caar defs)
2032        (concat (ggtags-fontify-code (caar defs))
2033                (and (cdr defs) " [guess]"))))
2034
2035 (defun ggtags-show-definition (name)
2036   (interactive (list (ggtags-read-tag 'definition current-prefix-arg)))
2037   (ggtags-check-project)
2038   (let* ((re (cadr (assq 'grep ggtags-global-error-regexp-alist-alist)))
2039          (current (current-buffer))
2040          (buffer (get-buffer-create " *ggtags-definition*"))
2041          (args (list "--result=grep" "--path-style=absolute" name))
2042          ;; Need these bindings so that let-binding
2043          ;; `ggtags-print-definition-function' can work see
2044          ;; `ggtags-eldoc-function'.
2045          (get-fn ggtags-get-definition-function)
2046          (print-fn ggtags-print-definition-function)
2047          (show (lambda (_status)
2048                  (goto-char (point-min))
2049                  (let ((defs (cl-loop while (re-search-forward re nil t)
2050                                       collect (list (buffer-substring-no-properties
2051                                                      (1+ (match-end 2))
2052                                                      (line-end-position))
2053                                                     name
2054                                                     (match-string 1)
2055                                                     (string-to-number (match-string 2))))))
2056                    (kill-buffer buffer)
2057                    (with-current-buffer current
2058                      (funcall print-fn (funcall get-fn defs)))))))
2059     (ggtags-with-current-project
2060       (ggtags-global-output
2061        buffer
2062        (cons (ggtags-program-path "global")
2063              (if (ggtags-sort-by-nearness-p) (cons "--nearness=." args) args))
2064        show 100))))
2065
2066 (defvar ggtags-mode-prefix-map
2067   (let ((m (make-sparse-keymap)))
2068     ;; Globally bound to `M-g p'.
2069     ;; (define-key m "\M-'" 'previous-error)
2070     (define-key m (kbd "M-DEL") 'ggtags-delete-tags)
2071     (define-key m "\M-p" 'ggtags-prev-mark)
2072     (define-key m "\M-n" 'ggtags-next-mark)
2073     (define-key m "\M-f" 'ggtags-find-file)
2074     (define-key m "\M-o" 'ggtags-find-other-symbol)
2075     (define-key m "\M-g" 'ggtags-grep)
2076     (define-key m "\M-i" 'ggtags-idutils-query)
2077     (define-key m "\M-b" 'ggtags-browse-file-as-hypertext)
2078     (define-key m "\M-k" 'ggtags-kill-file-buffers)
2079     (define-key m "\M-h" 'ggtags-view-tag-history)
2080     (define-key m "\M-j" 'ggtags-visit-project-root)
2081     (define-key m "\M-/" 'ggtags-view-search-history)
2082     (define-key m (kbd "M-SPC") 'ggtags-save-to-register)
2083     (define-key m (kbd "M-%") 'ggtags-query-replace)
2084     (define-key m "\M-?" 'ggtags-show-definition)
2085     m))
2086
2087 (defvar ggtags-mode-map
2088   (let ((map (make-sparse-keymap))
2089         (menu (make-sparse-keymap "Ggtags")))
2090     (define-key map "\M-." 'ggtags-find-tag-dwim)
2091     (define-key map (kbd "M-]") 'ggtags-find-reference)
2092     (define-key map (kbd "C-M-.") 'ggtags-find-tag-regexp)
2093     (define-key map ggtags-mode-prefix-key ggtags-mode-prefix-map)
2094     ;; Menu items
2095     (define-key map [menu-bar ggtags] (cons "Ggtags" menu))
2096     ;; Ordered backwards
2097     (define-key menu [report-bugs]
2098       `(menu-item "Report bugs"
2099                   (lambda () (interactive)
2100                     (browse-url ggtags-bug-url)
2101                     (message "Please visit %s" ggtags-bug-url))
2102                   :help ,(format "Visit %s" ggtags-bug-url)))
2103     (define-key menu [custom-ggtags]
2104       '(menu-item "Customize Ggtags"
2105                   (lambda () (interactive) (customize-group 'ggtags))))
2106     (define-key menu [eldoc-mode]
2107       '(menu-item "Toggle eldoc mode" eldoc-mode :button (:toggle . eldoc-mode)))
2108     (define-key menu [save-project]
2109       '(menu-item "Save project settings" ggtags-save-project-settings))
2110     (define-key menu [toggle-read-only]
2111       '(menu-item "Toggle project read-only" ggtags-toggle-project-read-only
2112                   :button (:toggle . buffer-read-only)))
2113     (define-key menu [visit-project-root]
2114       '(menu-item "Visit project root" ggtags-visit-project-root))
2115     (define-key menu [sep2] menu-bar-separator)
2116     (define-key menu [browse-hypertext]
2117       '(menu-item "Browse as hypertext" ggtags-browse-file-as-hypertext
2118                   :enable (ggtags-find-project)))
2119     (define-key menu [delete-tags]
2120       '(menu-item "Delete tags" ggtags-delete-tags
2121                   :enable (ggtags-find-project)
2122                   :help "Delete file GTAGS, GRTAGS, GPATH, ID etc."))
2123     (define-key menu [kill-buffers]
2124       '(menu-item "Kill project file buffers" ggtags-kill-file-buffers
2125                   :enable (ggtags-find-project)))
2126     (define-key menu [view-tag]
2127       '(menu-item "View tag history" ggtags-view-tag-history))
2128     (define-key menu [pop-mark]
2129       '(menu-item "Pop mark" xref-pop-marker-stack
2130                   :help "Pop to previous mark and destroy it"))
2131     (define-key menu [next-mark]
2132       '(menu-item "Next mark" ggtags-next-mark))
2133     (define-key menu [prev-mark]
2134       '(menu-item "Previous mark" ggtags-prev-mark))
2135     (define-key menu [sep1] menu-bar-separator)
2136     (define-key menu [previous-error]
2137       '(menu-item "Previous match" previous-error))
2138     (define-key menu [next-error]
2139       '(menu-item "Next match" next-error))
2140     (define-key menu [rerun-search]
2141       '(menu-item "View past searches" ggtags-view-search-history))
2142     (define-key menu [save-to-register]
2143       '(menu-item "Save search to register" ggtags-save-to-register))
2144     (define-key menu [find-file]
2145       '(menu-item "Find files" ggtags-find-file))
2146     (define-key menu [query-replace]
2147       '(menu-item "Query replace" ggtags-query-replace))
2148     (define-key menu [idutils]
2149       '(menu-item "Query idutils DB" ggtags-idutils-query))
2150     (define-key menu [grep]
2151       '(menu-item "Grep" ggtags-grep))
2152     (define-key menu [find-symbol]
2153       '(menu-item "Find other symbol" ggtags-find-other-symbol
2154                   :help "Find references without definition"))
2155     (define-key menu [find-tag-regexp]
2156       '(menu-item "Find tag matching regexp" ggtags-find-tag-regexp))
2157     (define-key menu [show-definition]
2158       '(menu-item "Show definition" ggtags-show-definition))
2159     (define-key menu [find-reference]
2160       '(menu-item "Find reference" ggtags-find-reference))
2161     ;; TODO: bind `find-tag-continue' to `M-*' after dropping support
2162     ;; for emacs < 25.
2163     (define-key menu [find-tag-continue]
2164       '(menu-item "Continue find tag" tags-loop-continue))
2165     (define-key menu [find-tag]
2166       '(menu-item "Find tag" ggtags-find-tag-dwim))
2167     (define-key menu [update-tags]
2168       '(menu-item "Update tag files" ggtags-update-tags
2169                   :visible (ggtags-find-project)))
2170     (define-key menu [run-gtags]
2171       '(menu-item "Run gtags" ggtags-create-tags
2172                   :visible (not (ggtags-find-project))))
2173     map))
2174
2175 (defvar ggtags-mode-line-project-keymap
2176   (let ((map (make-sparse-keymap)))
2177     (define-key map [mode-line mouse-1] 'ggtags-visit-project-root)
2178     map))
2179
2180 (put 'ggtags-mode-line-project-name 'risky-local-variable t)
2181 (defvar ggtags-mode-line-project-name
2182   '("[" (:eval (let ((name (if (stringp ggtags-project-root)
2183                                (file-name-nondirectory
2184                                 (directory-file-name ggtags-project-root))
2185                              "?")))
2186                  (propertize
2187                   name 'face compilation-info-face
2188                   'help-echo (if (stringp ggtags-project-root)
2189                                  (concat "mouse-1 to visit " ggtags-project-root)
2190                                "mouse-1 to set project")
2191                   'mouse-face 'mode-line-highlight
2192                   'keymap ggtags-mode-line-project-keymap)))
2193     "]")
2194   "Mode line construct for displaying current project name.
2195 The value is the name of the project root directory. Setting it
2196 to nil disables displaying this information.")
2197
2198 ;;;###autoload
2199 (define-minor-mode ggtags-mode nil
2200   :lighter (:eval (if ggtags-navigation-mode "" " GG"))
2201   (ggtags-setup-highlight-tag-at-point ggtags-highlight-tag)
2202   (if ggtags-mode
2203       (progn
2204         (add-hook 'after-save-hook 'ggtags-after-save-function nil t)
2205         ;; Append to serve as a fallback method.
2206         (add-hook 'completion-at-point-functions
2207                   #'ggtags-completion-at-point t t)
2208         ;; Work around http://debbugs.gnu.org/19324
2209         (or eldoc-documentation-function
2210             (setq-local eldoc-documentation-function #'ignore))
2211         (add-function :after-until (local 'eldoc-documentation-function)
2212                       #'ggtags-eldoc-function '((name . ggtags-eldoc-function)
2213                                                 (depth . -100)))
2214         (unless (memq 'ggtags-mode-line-project-name
2215                       mode-line-buffer-identification)
2216           (setq mode-line-buffer-identification
2217                 (append mode-line-buffer-identification
2218                         '(ggtags-mode-line-project-name)))))
2219     (remove-hook 'after-save-hook 'ggtags-after-save-function t)
2220     (remove-hook 'completion-at-point-functions #'ggtags-completion-at-point t)
2221     (remove-function (local 'eldoc-documentation-function) 'ggtags-eldoc-function)
2222     (setq mode-line-buffer-identification
2223           (delq 'ggtags-mode-line-project-name mode-line-buffer-identification))
2224     (ggtags-cancel-highlight-tag-at-point 'keep-timer)))
2225
2226 (defvar ggtags-highlight-tag-map
2227   (let ((map (make-sparse-keymap)))
2228     ;; Bind down- events so that the global keymap won't ``shine
2229     ;; through''. See `mode-line-buffer-identification-keymap' for
2230     ;; similar workaround.
2231     (define-key map [S-mouse-1] 'ggtags-find-tag-dwim)
2232     (define-key map [S-down-mouse-1] 'ignore)
2233     (define-key map [S-mouse-3] 'ggtags-find-reference)
2234     (define-key map [S-down-mouse-3] 'ignore)
2235     map)
2236   "Keymap used for valid tag at point.")
2237
2238 (put 'ggtags-active-tag 'face 'ggtags-highlight)
2239 (put 'ggtags-active-tag 'keymap ggtags-highlight-tag-map)
2240 ;; (put 'ggtags-active-tag 'mouse-face 'match)
2241 (put 'ggtags-active-tag 'help-echo
2242      "S-mouse-1 for definitions\nS-mouse-3 for references")
2243
2244 (defun ggtags-setup-highlight-tag-at-point (flag)
2245   (cond ((null flag) (ggtags-cancel-highlight-tag-at-point))
2246         ((not (timerp ggtags-highlight-tag-timer))
2247          (setq ggtags-highlight-tag-timer
2248                (run-with-idle-timer flag t #'ggtags-highlight-tag-at-point)))
2249         (t (timer-set-idle-time ggtags-highlight-tag-timer flag t))))
2250
2251 (defun ggtags-cancel-highlight-tag-at-point (&optional keep-timer)
2252   (when (and (not keep-timer)
2253              (timerp ggtags-highlight-tag-timer))
2254     (cancel-timer ggtags-highlight-tag-timer)
2255     (setq ggtags-highlight-tag-timer nil))
2256   (when ggtags-highlight-tag-overlay
2257     (delete-overlay ggtags-highlight-tag-overlay)
2258     (setq ggtags-highlight-tag-overlay nil)))
2259
2260 (defun ggtags-highlight-tag-at-point ()
2261   (when (and ggtags-mode ggtags-project-root (ggtags-find-project))
2262     (unless (overlayp ggtags-highlight-tag-overlay)
2263       (setq ggtags-highlight-tag-overlay (make-overlay (point) (point) nil t))
2264       (overlay-put ggtags-highlight-tag-overlay 'modification-hooks
2265                    (list (lambda (o after &rest _args)
2266                            (and (not after) (delete-overlay o))))))
2267     (let ((bounds (funcall ggtags-bounds-of-tag-function))
2268           (o ggtags-highlight-tag-overlay))
2269       (cond
2270        ((and bounds
2271              (eq (overlay-buffer o) (current-buffer))
2272              (= (overlay-start o) (car bounds))
2273              (= (overlay-end o) (cdr bounds)))
2274         ;; Overlay matches current tag so do nothing.
2275         nil)
2276        ((and bounds (let ((completion-ignore-case nil))
2277                       (test-completion
2278                        (buffer-substring-no-properties
2279                         (car bounds) (cdr bounds))
2280                        ggtags-completion-table)))
2281         (move-overlay o (car bounds) (cdr bounds) (current-buffer))
2282         (overlay-put o 'category 'ggtags-active-tag))
2283        (t (move-overlay o
2284                         (or (car bounds) (point))
2285                         (or (cdr bounds) (point))
2286                         (current-buffer))
2287           (overlay-put o 'category nil))))))
2288
2289 ;;; eldoc
2290
2291 (defvar-local ggtags-eldoc-cache nil)
2292
2293 (declare-function eldoc-message "eldoc")
2294 (defun ggtags-eldoc-function ()
2295   "A function suitable for `eldoc-documentation-function' (which see)."
2296   (pcase (ggtags-tag-at-point)
2297     (`nil nil)
2298     (tag (if (equal tag (car ggtags-eldoc-cache))
2299              (cadr ggtags-eldoc-cache)
2300            (and ggtags-project-root (ggtags-find-project)
2301                 (let* ((ggtags-print-definition-function
2302                         (lambda (s)
2303                           (setq ggtags-eldoc-cache (list tag s))
2304                           (eldoc-message s))))
2305                   ;; Prevent multiple runs of ggtags-show-definition
2306                   ;; for the same tag.
2307                   (setq ggtags-eldoc-cache (list tag))
2308                   (condition-case err
2309                       (ggtags-show-definition tag)
2310                     (file-error
2311                      (remove-function (local 'eldoc-documentation-function)
2312                                       'ggtags-eldoc-function)
2313                      (message "\
2314 Function `ggtags-eldoc-function' disabled for eldoc in current buffer: %S" err)))
2315                   nil))))))
2316
2317 ;;; imenu
2318
2319 (defun ggtags-goto-imenu-index (name line &rest _args)
2320   (ggtags-forward-to-line line)
2321   (ggtags-move-to-tag name))
2322
2323 ;;;###autoload
2324 (defun ggtags-build-imenu-index ()
2325   "A function suitable for `imenu-create-index-function'."
2326   (let ((file (and buffer-file-name (file-relative-name buffer-file-name))))
2327     (and file (with-temp-buffer
2328                 (when (with-demoted-errors "ggtags-build-imenu-index: %S"
2329                         (zerop (ggtags-with-current-project
2330                                  (process-file (ggtags-program-path "global")
2331                                                nil t nil "-x" "-f" file))))
2332                   (goto-char (point-min))
2333                   (cl-loop while (re-search-forward
2334                                   "^\\([^ \t]+\\)[ \t]+\\([0-9]+\\)" nil t)
2335                            collect (list (match-string 1)
2336                                          (string-to-number (match-string 2))
2337                                          'ggtags-goto-imenu-index)))))))
2338
2339 ;;; hippie-expand
2340
2341 ;;;###autoload
2342 (defun ggtags-try-complete-tag (old)
2343   "A function suitable for `hippie-expand-try-functions-list'."
2344   (eval-and-compile (require 'hippie-exp))
2345   (unless old
2346     (he-init-string (or (car (funcall ggtags-bounds-of-tag-function)) (point))
2347                     (point))
2348     (setq he-expand-list
2349           (and (not (equal he-search-string ""))
2350                (ggtags-find-project)
2351                (sort (all-completions he-search-string
2352                                       ggtags-completion-table)
2353                      #'string-lessp))))
2354   (if (null he-expand-list)
2355       (progn
2356         (if old (he-reset-string))
2357         nil)
2358     (he-substitute-string (car he-expand-list))
2359     (setq he-expand-list (cdr he-expand-list))
2360     t))
2361
2362 (defun ggtags-reload (&optional force)
2363   (interactive "P")
2364   (unload-feature 'ggtags force)
2365   (require 'ggtags))
2366
2367 (provide 'ggtags)
2368 ;;; ggtags.el ends here