-
Notifications
You must be signed in to change notification settings - Fork 56
/
ggtags.el
2488 lines (2253 loc) · 105 KB
/
ggtags.el
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
;;; ggtags.el --- emacs frontend to GNU Global source code tagging system -*- lexical-binding: t; -*-
;; Copyright (C) 2013-2019 Free Software Foundation, Inc.
;; Author: Leo Liu <sdl.web@gmail.com>
;; Version: 0.9.0
;; Keywords: tools, convenience
;; Created: 2013-01-29
;; URL: https://github.com/leoliu/ggtags
;; Package-Requires: ((emacs "25"))
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;; A package to integrate GNU Global source code tagging system
;; (http://www.gnu.org/software/global) with Emacs.
;;
;; Usage:
;;
;; `ggtags' is similar to the standard `etags' package. These keys
;; `M-.', `M-,' and `C-M-.' should work as expected in `ggtags-mode'.
;; See the README in https://github.com/leoliu/ggtags for more
;; details.
;;
;; All commands are available from the `Ggtags' menu in `ggtags-mode'.
;;; NEWS 0.8.13 (2018-07-25):
;; - Don't choke on tag names start with `-'.
;; - `ggtags-show-definition' supports `ggtags-sort-by-nearness'.
;; - New variable `ggtags-extra-args'.
;; - Unbreak `ggtags-sort-by-nearness'.
;;
;; See full NEWS on https://github.com/leoliu/ggtags#news
;;; Code:
(eval-when-compile
(require 'url-parse))
(require 'cl-lib)
(require 'ewoc)
(require 'compile)
(require 'etags)
(eval-when-compile
(defmacro ignore-errors-unless-debug (&rest body)
"Ignore all errors while executing BODY unless debug is on."
(declare (debug t) (indent 0))
`(condition-case-unless-debug nil (progn ,@body) (error nil)))
(defmacro with-display-buffer-no-window (&rest body)
(declare (debug t) (indent 0))
;; See http://debbugs.gnu.org/13594
`(let ((display-buffer-overriding-action
(if ggtags-auto-jump-to-match
(list #'display-buffer-no-window)
display-buffer-overriding-action)))
,@body)))
(defgroup ggtags nil
"GNU Global source code tagging system."
:group 'tools)
(defface ggtags-highlight '((t (:underline t)))
"Face used to highlight a valid tag at point."
:group 'ggtags)
(defface ggtags-global-line '((t (:inherit secondary-selection)))
"Face used to highlight matched line in Global buffer."
:group 'ggtags)
(defcustom ggtags-executable-directory nil
"If non-nil the directory to search global executables."
:type '(choice (const :tag "Unset" nil) directory)
:risky t
:group 'ggtags)
(defcustom ggtags-oversize-limit (* 10 1024 1024)
"The over size limit for the GTAGS file.
When the size of the GTAGS file is below this limit, ggtags
always maintains up-to-date tags for the whole source tree by
running `global -u'. For projects with GTAGS larger than this
limit, only files edited in Ggtags mode are updated (via `global
--single-update')."
:safe 'numberp
:type '(choice (const :tag "None" nil)
(const :tag "Always" t)
number)
:group 'ggtags)
(defcustom ggtags-include-pattern
'("^\\s-*#\\s-*\\(?:include\\|import\\)\\s-*[\"<]\\(?:[./]*\\)?\\(.*?\\)[\">]" . 1)
"Pattern used to detect #include files.
Value can be (REGEXP . SUB) or a function with no arguments.
REGEXP should match from the beginning of line."
:type '(choice (const :tag "Disable" nil)
(cons regexp integer)
function)
:safe 'stringp
:group 'ggtags)
;; See also: http://article.gmane.org/gmane.comp.gnu.global.bugs/1751
(defcustom ggtags-use-project-gtagsconf t
"Non-nil to use GTAGSCONF file found at project root.
File .globalrc and gtags.conf are checked in order.
Note: GNU Global v6.2.13 has the feature of using gtags.conf at
project root. Setting this variable to nil doesn't disable this
feature."
:safe 'booleanp
:type 'boolean
:group 'ggtags)
(defcustom ggtags-project-duration 600
"Seconds to keep information of a project in memory."
:type 'number
:group 'ggtags)
(defcustom ggtags-process-environment nil
"Similar to `process-environment' with higher precedence.
Elements are run through `substitute-env-vars' before use.
GTAGSROOT will always be expanded to current project root
directory. This is intended for project-wise ggtags-specific
process environment settings. Note on remote hosts (e.g. tramp)
directory local variables is not enabled by default per
`enable-remote-dir-locals' (which see)."
:safe 'ggtags-list-of-string-p
:type '(repeat string)
:group 'ggtags)
(defcustom ggtags-auto-jump-to-match 'history
"Strategy on how to jump to match: nil, first or history.
nil: never automatically jump to any match;
first: jump to the first match;
history: jump to the match stored in search history."
:type '(choice (const :tag "First match" first)
(const :tag "Search History" history)
(const :tag "Never" nil))
:group 'ggtags)
(defcustom ggtags-global-window-height 8 ; ggtags-global-mode
"Number of lines for the *ggtags-global* popup window.
If nil, use Emacs default."
:type '(choice (const :tag "Default" nil) integer)
:group 'ggtags)
(defcustom ggtags-global-abbreviate-filename 40
"Non-nil to display file names abbreviated e.g. \"/u/b/env\".
If an integer abbreviate only names longer than that number."
:type '(choice (const :tag "No" nil)
(const :tag "Always" t)
integer)
:group 'ggtags)
(defcustom ggtags-split-window-function split-window-preferred-function
"A function to control how ggtags pops up the auxiliary window."
:type 'function
:group 'ggtags)
(defcustom ggtags-use-idutils (and (executable-find "mkid") t)
"Non-nil to also generate the idutils DB."
:type 'boolean
:group 'ggtags)
(defcustom ggtags-use-sqlite3 nil
"Use sqlite3 for storage instead of Berkeley DB.
This feature requires GNU Global 6.3.3+ and is ignored if `gtags'
isn't built with sqlite3 support."
:type 'boolean
:safe 'booleanp
:group 'ggtags)
(defcustom ggtags-extra-args nil
"Extra arguments to pass to `gtags' in `ggtags-create-tags'."
:type '(repeat string)
:safe #'ggtags-list-of-string-p
:group 'ggtags)
(defcustom ggtags-sort-by-nearness nil
"Sort tags by nearness to current directory.
GNU Global 6.5+ required."
:type 'boolean
:safe #'booleanp
:group 'ggtags)
(defcustom ggtags-update-on-save t
"Non-nil to update tags for current buffer on saving."
;; It is reported that `global --single-update' can be slow in sshfs
;; directories. See https://github.com/leoliu/ggtags/issues/85.
:safe #'booleanp
:type 'boolean
:group 'ggtags)
(defcustom ggtags-global-output-format 'grep
"Global output format: path, ctags, ctags-x, grep or cscope."
:type '(choice (const path)
(const ctags)
(const ctags-x)
(const grep)
(const cscope))
:group 'ggtags)
(defcustom ggtags-global-use-color t
"Non-nil to use color in output if supported by Global.
Note: processing colored output takes noticeable time
particularly when the output is large."
:type 'boolean
:safe 'booleanp
:group 'ggtags)
(defcustom ggtags-global-ignore-case nil
"Non-nil if Global should ignore case in the search pattern."
:safe 'booleanp
:type 'boolean
:group 'ggtags)
(defcustom ggtags-global-treat-text nil
"Non-nil if Global should include matches from text files.
This affects `ggtags-find-file' and `ggtags-grep'."
:safe 'booleanp
:type 'boolean
:group 'ggtags)
;; See also https://github.com/leoliu/ggtags/issues/52
(defcustom ggtags-global-search-libpath-for-reference t
"If non-nil global will search GTAGSLIBPATH for references.
Search is only continued in GTAGSLIBPATH if it finds no matches
in current project."
:safe 'booleanp
:type 'boolean
:group 'ggtags)
(defcustom ggtags-global-large-output 1000
"Number of lines in the Global buffer to indicate large output."
:type 'number
:group 'ggtags)
(defcustom ggtags-global-history-length history-length
"Maximum number of items to keep in `ggtags-global-search-history'."
:type 'integer
:group 'ggtags)
(defcustom ggtags-enable-navigation-keys t
"If non-nil key bindings in `ggtags-navigation-map' are enabled."
:safe 'booleanp
:type 'boolean
:group 'ggtags)
(defcustom ggtags-find-tag-hook nil
"Hook run immediately after finding a tag."
:options '(recenter reposition-window)
:type 'hook
:group 'ggtags)
(defcustom ggtags-get-definition-function #'ggtags-get-definition-default
"Function called by `ggtags-show-definition' to get definition.
It is passed a list of definition candidates of the form:
(TEXT NAME FILE LINE)
where TEXT is usually the source line of the definition.
The return value is passed to `ggtags-print-definition-function'."
:type 'function
:group 'ggtags)
(defcustom ggtags-print-definition-function
(lambda (s) (ggtags-echo "%s" (or s "[definition not found]")))
"Function used by `ggtags-show-definition' to print definition."
:type 'function
:group 'ggtags)
(defcustom ggtags-mode-sticky t
"If non-nil enable Ggtags Mode in files visited."
:safe 'booleanp
:type 'boolean
:group 'ggtags)
(defcustom ggtags-mode-prefix-key "\C-c"
"Key binding used for `ggtags-mode-prefix-map'.
Users should change the value using `customize-variable' to
properly update `ggtags-mode-map'."
:set (lambda (sym value)
(when (bound-and-true-p ggtags-mode-map)
(let ((old (and (boundp sym) (symbol-value sym))))
(and old (define-key ggtags-mode-map old nil)))
(and value
(bound-and-true-p ggtags-mode-prefix-map)
(define-key ggtags-mode-map value ggtags-mode-prefix-map)))
(set-default sym value))
:type 'key-sequence
:group 'ggtags)
(defcustom ggtags-completing-read-function nil
"Ggtags specific `completing-read-function' (which see).
Nil means using the value of `completing-read-function'."
:type '(choice (const :tag "Use completing-read-function" nil)
function)
:group 'ggtags)
(define-obsolete-variable-alias 'ggtags-highlight-tag-delay 'ggtags-highlight-tag
"0.8.11")
(defcustom ggtags-highlight-tag 0.25
"If non-nil time in seconds before highlighting tag at point.
Set to nil to disable tag highlighting."
:set (lambda (sym value)
(when (fboundp 'ggtags-setup-highlight-tag-at-point)
(ggtags-setup-highlight-tag-at-point value))
(set-default sym value))
:type '(choice (const :tag "Disable" nil) number)
:group 'ggtags)
(defcustom ggtags-bounds-of-tag-function (lambda ()
(bounds-of-thing-at-point 'symbol))
"Function to get the start and end positions of the tag at point."
:type 'function
:group 'ggtags)
;; Used by ggtags-global-mode
(defvar ggtags-global-error "match"
"Stem of message to print when no matches are found.")
(defconst ggtags-bug-url "https://github.com/leoliu/ggtags/issues")
(defvar ggtags-global-last-buffer nil)
(defvar ggtags-global-continuation nil)
(defvar ggtags-current-tag-name nil)
(defvar ggtags-highlight-tag-overlay nil)
(defvar ggtags-highlight-tag-timer nil)
(defmacro ggtags-with-temp-message (message &rest body)
(declare (debug t) (indent 1))
(let ((init-time (make-symbol "-init-time-"))
(tmp-msg (make-symbol "-tmp-msg-")))
`(let ((,init-time (float-time))
(,tmp-msg ,message))
(with-temp-message ,tmp-msg
(prog1 (progn ,@body)
(message "%sdone (%.2fs)" ,(or tmp-msg "")
(- (float-time) ,init-time)))))))
(defmacro ggtags-delay-finish-functions (&rest body)
"Delay running `compilation-finish-functions' until after BODY."
(declare (indent 0) (debug t))
(let ((saved (make-symbol "-saved-"))
(exit-args (make-symbol "-exit-args-")))
`(let ((,saved compilation-finish-functions)
,exit-args)
(setq-local compilation-finish-functions nil)
(add-hook 'compilation-finish-functions
(lambda (&rest args) (setq ,exit-args args))
nil t)
(unwind-protect (progn ,@body)
(setq-local compilation-finish-functions ,saved)
(and ,exit-args (apply #'run-hook-with-args
'compilation-finish-functions ,exit-args))))))
(defmacro ggtags-ensure-global-buffer (&rest body)
(declare (debug t) (indent 0))
`(progn
(or (and (buffer-live-p ggtags-global-last-buffer)
(with-current-buffer ggtags-global-last-buffer
(derived-mode-p 'ggtags-global-mode)))
(error "No global buffer found"))
(with-current-buffer ggtags-global-last-buffer ,@body)))
(defun ggtags-list-of-string-p (xs)
"Return non-nil if XS is a list of strings."
(cl-every #'stringp xs))
(defun ggtags-ensure-localname (file)
(and file (or (file-remote-p file 'localname) file)))
(defun ggtags-echo (format-string &rest args)
"Print formatted text to echo area."
(let (message-log-max) (apply #'message format-string args)))
(defun ggtags-forward-to-line (line)
"Move to line number LINE in current buffer."
(cl-check-type line (integer 1))
(save-restriction
(widen)
(goto-char (point-min))
(forward-line (1- line))))
(defun ggtags-kill-window ()
"Quit selected window and kill its buffer."
(interactive)
(quit-window t))
(defun ggtags-program-path (name)
(if ggtags-executable-directory
(expand-file-name name ggtags-executable-directory)
name))
(defun ggtags-process-succeed-p (program &rest args)
"Return non-nil if successfully running PROGRAM with ARGS."
(let ((program (ggtags-program-path program)))
(condition-case err
(zerop (apply #'process-file program nil nil nil args))
(error (message "`%s' failed: %s" program (error-message-string err))
nil))))
(defun ggtags-process-string (program &rest args)
(with-temp-buffer
(let ((exit (apply #'process-file
(ggtags-program-path program) nil t nil args))
(output (progn
(goto-char (point-max))
(skip-chars-backward " \t\n\r")
(buffer-substring-no-properties (point-min) (point)))))
(or (zerop exit)
(error "`%s' non-zero exit: %s" program output))
output)))
(defun ggtags-tag-at-point ()
(pcase (funcall ggtags-bounds-of-tag-function)
(`(,beg . ,end) (buffer-substring-no-properties beg end))))
;;; Store for project info and settings
(defvar ggtags-projects (make-hash-table :size 7 :test #'equal))
(cl-defstruct (ggtags-project (:constructor ggtags-project--make)
(:copier nil)
(:type vector)
:named)
root tag-size has-refs has-path-style has-color dirty-p mtime timestamp)
(defun ggtags-make-project (root)
(cl-check-type root string)
(let* ((default-directory (file-name-as-directory root))
;; NOTE: use of GTAGSDBPATH is not recommended. -- GLOBAL(1)
;; ROOT and DB can be different directories due to GTAGSDBPATH.
(dbdir (concat (file-remote-p root)
(ggtags-process-string "global" "-p"))))
(pcase (nthcdr 5 (file-attributes (expand-file-name "GTAGS" dbdir)))
(`(,mtime ,_ ,tag-size . ,_)
(let* ((rtags-size (nth 7 (file-attributes (expand-file-name "GRTAGS" dbdir))))
(has-refs
(when rtags-size
(and (or (> rtags-size (* 32 1024))
(with-demoted-errors "ggtags-make-project: %S"
(not (equal "" (ggtags-process-string "global" "-crs")))))
'has-refs)))
;; http://thread.gmane.org/gmane.comp.gnu.global.bugs/1518
(has-path-style
(and (ggtags-process-succeed-p "global" "--path-style" "shorter" "--help")
'has-path-style))
;; http://thread.gmane.org/gmane.comp.gnu.global.bugs/1542
(has-color (and (ggtags-process-succeed-p "global" "--color" "--help")
'has-color)))
(puthash default-directory
(ggtags-project--make :root default-directory
:tag-size tag-size
:has-refs has-refs
:has-path-style has-path-style
:has-color has-color
:mtime (float-time mtime)
:timestamp (float-time))
ggtags-projects))))))
(defun ggtags-project-expired-p (project)
(or (< (ggtags-project-timestamp project) 0)
(> (- (float-time)
(ggtags-project-timestamp project))
ggtags-project-duration)))
(defun ggtags-project-update-mtime-maybe (&optional project)
"Update PROJECT's modtime and if current file is newer.
Value is new modtime if updated."
(let ((project (or project (ggtags-find-project))))
(when (and (ggtags-project-p project)
(consp (visited-file-modtime))
(> (float-time (visited-file-modtime))
(ggtags-project-mtime project)))
(setf (ggtags-project-dirty-p project) t)
(setf (ggtags-project-mtime project)
(float-time (visited-file-modtime))))))
(defun ggtags-project-oversize-p (&optional project)
(pcase ggtags-oversize-limit
(`nil nil)
(`t t)
(size (let ((project (or project (ggtags-find-project))))
(and project (> (ggtags-project-tag-size project) size))))))
(defvar-local ggtags-last-default-directory nil)
(defvar-local ggtags-project-root 'unset
"Internal variable for project root directory.")
;;;###autoload
(defun ggtags-find-project ()
;; See https://github.com/leoliu/ggtags/issues/42
;;
;; It is unsafe to cache `ggtags-project-root' in non-file buffers
;; whose `default-directory' can often change.
(unless (equal ggtags-last-default-directory default-directory)
(kill-local-variable 'ggtags-project-root))
(let ((project (gethash ggtags-project-root ggtags-projects)))
(if (ggtags-project-p project)
(if (ggtags-project-expired-p project)
(progn
(remhash ggtags-project-root ggtags-projects)
(ggtags-find-project))
project)
(setq ggtags-last-default-directory default-directory)
(setq ggtags-project-root
(or (ignore-errors
(file-name-as-directory
(concat (file-remote-p default-directory)
;; Resolves symbolic links
(ggtags-process-string "global" "-pr"))))
;; 'global -pr' resolves symlinks before checking the
;; GTAGS file which could cause issues such as
;; https://github.com/leoliu/ggtags/issues/22, so
;; let's help it out.
(let ((dir (locate-dominating-file
default-directory
(lambda (dir) (file-regular-p (expand-file-name "GTAGS" dir))))))
;; `file-truename' may strip the trailing '/' on
;; remote hosts, see http://debbugs.gnu.org/16851
(and dir (file-name-as-directory (file-truename dir))))))
(when ggtags-project-root
(if (gethash ggtags-project-root ggtags-projects)
(ggtags-find-project)
(ggtags-make-project ggtags-project-root))))))
(defun ggtags-current-project-root ()
(and (ggtags-find-project)
(ggtags-project-root (ggtags-find-project))))
(defun ggtags-check-project ()
(or (ggtags-find-project) (error "File GTAGS not found")))
(defun ggtags-ensure-project ()
(or (ggtags-find-project)
(progn (call-interactively #'ggtags-create-tags)
;; Need checking because `ggtags-create-tags' can create
;; tags in any directory.
(ggtags-check-project))))
(defun ggtags-save-project-settings (&optional noconfirm)
"Save Gnu Global's specific environment variables."
(interactive "P")
(ggtags-check-project)
(let* ((inhibit-read-only t) ; for `add-dir-local-variable'
(default-directory (ggtags-current-project-root))
;; Not using `ggtags-with-current-project' to preserve
;; environment variables that may be present in
;; `ggtags-process-environment'.
(process-environment
(append ggtags-process-environment
process-environment
(and (not (ggtags-project-has-refs (ggtags-find-project)))
(list "GTAGSLABEL=ctags"))))
(envlist (delete-dups
(cl-loop for x in process-environment
when (string-match
"^\\(GTAGS[^=\n]*\\|MAKEOBJDIRPREFIX\\)=" x)
;; May have duplicates thus `delete-dups'.
collect (concat (match-string 1 x)
"="
(getenv (match-string 1 x))))))
(help-form (format "y: save\nn: don't save\n=: diff\n?: help\n")))
(add-dir-local-variable nil 'ggtags-process-environment envlist)
;; Remove trailing newlines by `add-dir-local-variable'.
(let ((delete-trailing-lines t)) (delete-trailing-whitespace))
(or noconfirm
(while (pcase (read-char-choice
(format "Save `%s'? (y/n/=/?) " buffer-file-name)
'(?y ?n ?= ??))
(?n (user-error "Aborted"))
(?y nil)
(?= (diff-buffer-with-file) 'loop)
(?? (help-form-show) 'loop))))
(save-buffer)
(kill-buffer)))
(defun ggtags-toggle-project-read-only ()
(interactive)
(ggtags-check-project)
(let ((inhibit-read-only t) ; for `add-dir-local-variable'
(val (not buffer-read-only))
(default-directory (ggtags-current-project-root)))
(add-dir-local-variable nil 'buffer-read-only val)
(save-buffer)
(kill-buffer)
(when buffer-file-name
(read-only-mode (if val +1 -1)))
(when (called-interactively-p 'interactive)
(message "Project read-only-mode is %s" (if val "on" "off")))
val))
(defun ggtags-visit-project-root (&optional project)
"Visit the root directory of (current) PROJECT in dired.
When called with a prefix \\[universal-argument], choose from past projects."
(interactive (list (and current-prefix-arg
(completing-read "Project: " ggtags-projects))))
(dired (cl-typecase project
(string project)
(ggtags-project (ggtags-project-root project))
(t (ggtags-ensure-project) (ggtags-current-project-root)))))
(defmacro ggtags-with-current-project (&rest body)
"Eval BODY in current project's `process-environment'."
(declare (debug t) (indent 0))
(let ((gtagsroot (make-symbol "-gtagsroot-"))
(root (make-symbol "-ggtags-project-root-")))
`(let* ((,root ggtags-project-root)
(,gtagsroot (when (ggtags-find-project)
(ggtags-ensure-localname
(directory-file-name (ggtags-current-project-root)))))
(process-environment
(append (let ((process-environment (copy-sequence process-environment)))
(and ,gtagsroot (setenv "GTAGSROOT" ,gtagsroot))
(mapcar #'substitute-env-vars ggtags-process-environment))
process-environment
(and ,gtagsroot (list (concat "GTAGSROOT=" ,gtagsroot)))
(and (ggtags-find-project)
(not (ggtags-project-has-refs (ggtags-find-project)))
(list "GTAGSLABEL=ctags")))))
(unwind-protect (save-current-buffer ,@body)
(setq ggtags-project-root ,root)))))
(defun ggtags-get-libpath ()
(let ((path (ggtags-with-current-project (getenv "GTAGSLIBPATH"))))
(and path (mapcar (apply-partially #'concat (file-remote-p default-directory))
(split-string path (regexp-quote path-separator) t)))))
(defun ggtags-project-relative-file (file)
"Get file name relative to current project root."
(ggtags-check-project)
(if (file-name-absolute-p file)
(file-relative-name file (if (string-prefix-p (ggtags-current-project-root)
file)
(ggtags-current-project-root)
(locate-dominating-file file "GTAGS")))
file))
(defun ggtags-project-file-p (file)
"Return non-nil if FILE is part of current project."
(when (ggtags-find-project)
(with-temp-buffer
(ggtags-with-current-project
;; NOTE: `process-file' requires all files in ARGS be relative
;; to `default-directory'; see its doc string for details.
(let ((default-directory (ggtags-current-project-root)))
(process-file (ggtags-program-path "global") nil t nil
"-vP" (concat "^" (ggtags-project-relative-file file) "$"))))
(goto-char (point-min))
(not (re-search-forward "^file not found" nil t)))))
(defun ggtags-invalidate-buffer-project-root (root)
(mapc (lambda (buf)
(with-current-buffer buf
(and buffer-file-truename
(string-prefix-p root buffer-file-truename)
(kill-local-variable 'ggtags-project-root))))
(buffer-list)))
(defun ggtags-create-tags (root)
"Create tag files (e.g. GTAGS) in directory ROOT.
If file .globalrc or gtags.conf exists in ROOT, it will be used
as configuration file per `ggtags-use-project-gtagsconf'.
If file gtags.files exists in ROOT, it should be a list of source
files to index, which can be used to speed gtags up in large
source trees. See Info node `(global)gtags' for details."
(interactive "DRoot directory: ")
(let ((process-environment (copy-sequence process-environment)))
(when (zerop (length root)) (error "No root directory provided"))
(setenv "GTAGSROOT" (ggtags-ensure-localname
(expand-file-name
(directory-file-name (file-name-as-directory root)))))
(ggtags-with-current-project
(let ((conf (and ggtags-use-project-gtagsconf
(cl-loop for name in '(".globalrc" "gtags.conf")
for full = (expand-file-name name root)
thereis (and (file-exists-p full) full)))))
(unless (or conf (getenv "GTAGSLABEL")
(not (yes-or-no-p "Use `ctags' backend? ")))
(setenv "GTAGSLABEL" "ctags"))
(ggtags-with-temp-message "`gtags' in progress..."
(let ((default-directory (file-name-as-directory root))
(args (append (cl-remove-if
#'null
(list (and ggtags-use-idutils "--idutils")
(and ggtags-use-sqlite3
(ggtags-process-succeed-p "gtags" "--sqlite3" "--help")
"--sqlite3")
(and conf "--gtagsconf")
(and conf (ggtags-ensure-localname conf))))
ggtags-extra-args)))
(condition-case err
(apply #'ggtags-process-string "gtags" args)
(error (if (and ggtags-use-idutils
(stringp (cadr err))
(string-match-p "mkid not found" (cadr err)))
;; Retry without mkid
(apply #'ggtags-process-string
"gtags" (cl-remove "--idutils" args))
(signal (car err) (cdr err)))))))))
(ggtags-invalidate-buffer-project-root (file-truename root))
(message "GTAGS generated in `%s'" root)
root))
(defun ggtags-explain-tags ()
"Explain how each file is indexed in current project."
(interactive (ignore (ggtags-check-project)
(or (ggtags-process-succeed-p "gtags" "--explain" "--help")
(user-error "Global 6.4+ required"))))
(ggtags-check-project)
(ggtags-with-current-project
(let ((default-directory (ggtags-current-project-root)))
(compilation-start (concat (ggtags-program-path "gtags") " --explain")))))
(defun ggtags-update-tags (&optional force)
"Update GNU Global tag database.
Do nothing if GTAGS exceeds the oversize limit unless FORCE.
When called interactively on large (per `ggtags-oversize-limit')
projects, the update process runs in the background without
blocking emacs."
(interactive (progn
(ggtags-check-project)
;; Mark project info expired.
(setf (ggtags-project-timestamp (ggtags-find-project)) -1)
(list 'interactive)))
(cond ((and (eq force 'interactive) (ggtags-project-oversize-p))
(ggtags-with-current-project
(with-display-buffer-no-window
(with-current-buffer (compilation-start "global -u")
;; A hack to fool compilation mode to display `global
;; -u finished' on finish.
(setq mode-name "global -u")
(add-hook 'compilation-finish-functions
#'ggtags-update-tags-finish nil t)))))
((or force (and (ggtags-find-project)
(not (ggtags-project-oversize-p))
(ggtags-project-dirty-p (ggtags-find-project))))
(ggtags-with-current-project
(ggtags-with-temp-message "`global -u' in progress..."
(ggtags-process-string "global" "-u")
(ggtags-update-tags-finish))))))
(defun ggtags-update-tags-finish (&optional buf how)
(if (and how buf (string-prefix-p "exited abnormally" how))
(display-buffer buf)
(setf (ggtags-project-dirty-p (ggtags-find-project)) nil)
(setf (ggtags-project-mtime (ggtags-find-project)) (float-time))))
(defun ggtags-update-tags-single (file &optional nowait)
;; NOTE: NOWAIT is ignored if file is remote file; see
;; `tramp-sh-handle-process-file'.
(cl-check-type file string)
(let ((nowait (unless (file-remote-p file) nowait)))
(ggtags-with-current-project
;; See comment in `ggtags-project-file-p'.
(let ((default-directory (ggtags-current-project-root)))
(process-file (ggtags-program-path "global") nil (and nowait 0) nil
"--single-update" (ggtags-project-relative-file file))))))
(defun ggtags-delete-tags ()
"Delete file GTAGS, GRTAGS, GPATH, ID etc. generated by gtags."
(interactive (ignore (ggtags-check-project)))
(when (ggtags-current-project-root)
(let* ((re (concat "\\`" (regexp-opt '("GPATH" "GRTAGS" "GTAGS" "ID")) "\\'"))
(files (cl-remove-if-not
(lambda (file)
;; Don't trust `directory-files'.
(let ((case-fold-search nil))
(string-match-p re (file-name-nondirectory file))))
(directory-files (ggtags-current-project-root) t re)))
(buffer "*GTags File List*"))
(or files (user-error "No tag files found"))
(with-output-to-temp-buffer buffer
(princ (mapconcat #'identity files "\n")))
(let ((win (get-buffer-window buffer)))
(unwind-protect
(progn
(fit-window-to-buffer win)
(when (yes-or-no-p "Remove GNU Global tag files? ")
(with-demoted-errors (mapc #'delete-file files))
(remhash (ggtags-current-project-root) ggtags-projects)
(and (overlayp ggtags-highlight-tag-overlay)
(delete-overlay ggtags-highlight-tag-overlay))))
(when (window-live-p win)
(quit-window t win)))))))
(defvar-local ggtags-completion-cache nil)
;; See global/libutil/char.c
;; (defconst ggtags-regexp-metachars "[][$()*+.?\\{}|^]")
(defvar ggtags-completion-flag "") ;internal use
(defvar ggtags-completion-table
(completion-table-dynamic
(lambda (prefix)
(let ((cache-key (concat prefix "$" ggtags-completion-flag)))
(unless (equal cache-key (car ggtags-completion-cache))
(setq ggtags-completion-cache
(cons cache-key
(ignore-errors-unless-debug
;; May throw global: only name char is allowed
;; with -c option.
(ggtags-with-current-project
(split-string
(apply #'ggtags-process-string
"global"
(append (and completion-ignore-case '("--ignore-case"))
;; Note -c alone returns only definitions
(list (concat "-c" ggtags-completion-flag) prefix)))
"\n" t)))))))
(cdr ggtags-completion-cache))))
(defun ggtags-completion-at-point ()
"A function for `completion-at-point-functions'."
(pcase (funcall ggtags-bounds-of-tag-function)
(`(,beg . ,end)
(and (< beg end) (list beg end ggtags-completion-table)))))
(defun ggtags-read-tag (&optional type confirm prompt require-match default)
(ggtags-ensure-project)
(let ((default (or default (ggtags-tag-at-point)))
(prompt (or prompt (capitalize (symbol-name (or type 'tag)))))
(ggtags-completion-flag (pcase type
(`(or nil definition) "T")
(`symbol "s")
(`reference "r")
(`id "I")
(`path "P")
((pred stringp) type)
(_ ggtags-completion-flag))))
(setq ggtags-current-tag-name
(cond (confirm
(ggtags-update-tags)
(let ((completing-read-function
(or ggtags-completing-read-function
completing-read-function)))
(completing-read
(format (if default "%s (default %s): " "%s: ") prompt default)
ggtags-completion-table nil require-match nil nil default)))
(default (substring-no-properties default))
(t (ggtags-read-tag type t prompt require-match default))))))
(defun ggtags-sort-by-nearness-p (&optional start-location)
(and ggtags-sort-by-nearness
(ggtags-process-succeed-p "global" "--nearness=." "--help")
(concat "--nearness="
(or start-location buffer-file-name default-directory))))
(defun ggtags-global-build-command (cmd &rest args)
;; CMD can be definition, reference, symbol, grep, idutils
(let ((xs (append (list (shell-quote-argument (ggtags-program-path "global"))
"-v"
(format "--result=%s" ggtags-global-output-format)
(and ggtags-global-ignore-case "--ignore-case")
(and ggtags-global-use-color
(ggtags-find-project)
(ggtags-project-has-color (ggtags-find-project))
"--color=always")
(and (ggtags-find-project)
(ggtags-project-has-path-style (ggtags-find-project))
"--path-style=shorter")
(and ggtags-global-treat-text "--other")
(pcase cmd
((pred stringp) cmd)
(`definition nil) ;-d not supported by Global 5.7.1
(`reference "--reference")
(`symbol "--symbol")
(`path "--path")
(`grep "--grep")
(`idutils "--idutils")))
args)))
(mapconcat #'identity (delq nil xs) " ")))
;; Can be three values: nil, t and a marker; t means start marker has
;; been saved in the tag ring.
(defvar ggtags-global-start-marker nil)
(defvar ggtags-global-start-file nil)
(defvar ggtags-tag-ring-index nil)
(defvar ggtags-global-search-history nil)
(defvar ggtags-auto-jump-to-match-target nil)
(defvar-local ggtags-global-exit-info nil) ; (EXIT-STATUS COUNT DB)
(defun ggtags-global-save-start-marker ()
(when (markerp ggtags-global-start-marker)
(setq ggtags-tag-ring-index nil)
(xref-push-marker-stack ggtags-global-start-marker)
(setq ggtags-global-start-marker t)))
(defun ggtags-global-start (command &optional directory)
(let* ((default-directory (or directory (ggtags-current-project-root)))
(split-window-preferred-function ggtags-split-window-function)
(env ggtags-process-environment))
(unless (and (markerp ggtags-global-start-marker)
(marker-position ggtags-global-start-marker))
(setq ggtags-global-start-marker (point-marker)))
;; Record the file name for `ggtags-navigation-start-file'.
(setq ggtags-global-start-file buffer-file-name)
(setq ggtags-auto-jump-to-match-target
(nth 4 (assoc (ggtags-global-search-id command default-directory)
ggtags-global-search-history)))
(ggtags-navigation-mode +1)
(ggtags-update-tags)
(ggtags-with-current-project
(with-current-buffer (with-display-buffer-no-window
(compilation-start command 'ggtags-global-mode))
(setq-local ggtags-process-environment env)
(setq ggtags-global-last-buffer (current-buffer))))))
(defun ggtags-find-tag-continue ()
(interactive)
(ggtags-ensure-global-buffer
(ggtags-navigation-mode +1)
(let ((split-window-preferred-function ggtags-split-window-function))
(ignore-errors (compilation-next-error 1))
(compile-goto-error))))
(defun ggtags-find-tag (cmd &rest args)
(ggtags-check-project)
(let ((nearness (ggtags-sort-by-nearness-p
(ggtags-project-relative-file
(or buffer-file-name default-directory)))))
(ggtags-global-start
(apply #'ggtags-global-build-command cmd nearness args))))
(defun ggtags-include-file ()
"Calculate the include file based on `ggtags-include-pattern'."
(pcase ggtags-include-pattern
(`nil nil)
((pred functionp)
(funcall ggtags-include-pattern))
(`(,re . ,sub)
(save-excursion
(beginning-of-line)
(and (looking-at re) (match-string sub))))
(_ (warn "Invalid value for `ggtags-include-pattern': %s"
ggtags-include-pattern)
nil)))
;;;###autoload
(defun ggtags-find-tag-dwim (name &optional what)
"Find NAME by context.
If point is at a definition tag, find references, and vice versa.
If point is at a line that matches `ggtags-include-pattern', find
the include file instead.
When called interactively with a prefix arg, always find
definition tags."
(interactive
(let ((include (and (not current-prefix-arg) (ggtags-include-file))))
(ggtags-ensure-project)
(if include (list include 'include)
(list (ggtags-read-tag 'definition current-prefix-arg)
(and current-prefix-arg 'definition)))))
(ggtags-check-project) ; For `ggtags-current-project-root' below.
(cond
((eq what 'include)
(ggtags-find-file name))
((or (eq what 'definition)
(not buffer-file-name)
(not (ggtags-project-has-refs (ggtags-find-project)))
(not (ggtags-project-file-p buffer-file-name)))
(ggtags-find-definition name))
(t (ggtags-find-tag
(format "--from-here=%d:%s"
(line-number-at-pos)
;; Note `ggtags-find-tag' binds `default-directory' to
;; project root.
(shell-quote-argument
(ggtags-project-relative-file buffer-file-name)))
"--" (shell-quote-argument name)))))
(defun ggtags-find-tag-mouse (event)
(interactive "e")
(with-selected-window (posn-window (event-start event))
(save-excursion