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