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