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
|
;;; bug-reference.el --- buttonize bug references -*- lexical-binding: t; -*-
;; Copyright (C) 2008-2025 Free Software Foundation, Inc.
;; Author: Tom Tromey <tromey@redhat.com>
;; Created: 21 Mar 2007
;; Keywords: tools
;; This file is part of GNU Emacs.
;; GNU Emacs 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.
;; GNU Emacs 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 GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
;;; Commentary:
;; This file provides minor modes for putting clickable overlays on
;; references to bugs. A bug reference is text like "PR foo/29292";
;; this is mapped to a URL using a user-supplied format; see
;; `bug-reference-url-format' and `bug-reference-bug-regexp'. More
;; extensive documentation is in (info "(emacs) Bug Reference").
;; Two minor modes are provided. One works on any text in the buffer;
;; the other operates only on comments and strings. By default, the
;; URL link is followed by invoking C-c RET or mouse-2.
;;; Code:
(require 'thingatpt)
(defgroup bug-reference nil
"Hyperlinking references to bug reports."
;; Somewhat arbitrary, by analogy with eg goto-address.
:group 'comm)
(defvar-keymap bug-reference-map
:doc "Keymap used by bug reference buttons."
"<mouse-2>" #'bug-reference-push-button
"C-c RET" #'bug-reference-push-button)
;; E.g., "https://gcc.gnu.org/PR%s"
(defvar bug-reference-url-format nil
"Format used to turn a bug number into a URL.
The bug number is supplied as a string, so this should have a single %s.
This can also be a function designator; it is called without arguments
and should return a string.
It can use `match-string' to get parts matched against
`bug-reference-bug-regexp', specifically:
1. issue kind (bug, patch, rfe &c)
2. issue number.
There is no default setting for this, it must be set per file.
If you set it to a symbol in the file Local Variables section,
you need to add a `bug-reference-url-format' property to it:
\(put \\='my-bug-reference-url-format \\='bug-reference-url-format t)
so that it is considered safe, see `enable-local-variables'.")
;;;###autoload
(put 'bug-reference-url-format 'safe-local-variable
(lambda (s)
(or (stringp s)
(and (symbolp s)
(get s 'bug-reference-url-format)))))
(defcustom bug-reference-bug-regexp
"\\(\\b\\(?:[Bb]ug ?#?\\|[Pp]atch ?#\\|RFE ?#\\|PR [a-z+-]+/\\)\\([0-9]+\\(?:#[0-9]+\\)?\\)\\)"
"Regular expression matching bug references.
The first subexpression defines the region of the bug-reference
overlay, i.e., the region being fontified and made clickable in
order to browse the referenced bug in the corresponding project's
issue tracker.
If `bug-reference-url-format' is set to a format string with
single %s placeholder, the second subexpression must match
the (part of the) bug reference which needs to be injected in
place of the %s in order to form the bug's ticket URL.
If `bug-reference-url-format' is a function, the interpretation
of the subexpressions larger than 1 is up to the function.
However, it is checked that the bounds of all matching
subexpressions from 2 to 10 are within the bounds of the
subexpression 1 defining the overlay region. Larger
subexpressions may also be used by the function but may lay
outside the bounds of subexpressions 1 and then don't contribute
to the highlighted and clickable region."
:type 'regexp
; 24.3: defconst -> defcustom
; 28.1: contract about subexpression 1 defines the overlay region.
:version "28.1")
;;;###autoload
(put 'bug-reference-bug-regexp 'safe-local-variable 'stringp)
(defun bug-reference-set-overlay-properties ()
"Set properties of bug reference overlays."
(put 'bug-reference 'evaporate t)
(put 'bug-reference 'face 'link)
(put 'bug-reference 'mouse-face 'highlight)
(put 'bug-reference 'help-echo "mouse-1, C-c RET: visit this bug")
(put 'bug-reference 'keymap bug-reference-map)
(put 'bug-reference 'follow-link t))
(bug-reference-set-overlay-properties)
(defun bug-reference--overlays-in (start end)
"Return bug reference overlays in the region between START and END."
(let (overlays)
(dolist (o (overlays-in start end))
(when (eq (overlay-get o 'category) 'bug-reference)
(push o overlays)))
(nreverse overlays)))
(defun bug-reference-unfontify (start end)
"Remove bug reference overlays from the region between START and END."
(mapc #'delete-overlay (bug-reference--overlays-in start end)))
(defvar bug-reference-prog-mode)
(defvar bug-reference--nonconforming-regexps nil)
(defun bug-reference--overlay-bounds ()
(let ((m-b1 (match-beginning 1))
(m-e1 (match-end 1)))
(if (and m-b1 m-e1
(catch 'within-bounds
(let ((i 2))
(while (<= i 10)
(when (and (match-beginning i)
(or (< (match-beginning i) m-b1)
(> (match-end i) m-e1)))
(throw 'within-bounds nil))
(cl-incf i))
t)))
;; All groups 2..10 are within bounds.
(cons m-b1 m-e1)
;; The regexp doesn't fulfill the contract of
;; bug-reference-bug-regexp, so fall back to the old behavior.
(unless (member bug-reference-bug-regexp
bug-reference--nonconforming-regexps)
(setq bug-reference--nonconforming-regexps
(cons bug-reference-bug-regexp
bug-reference--nonconforming-regexps))
(display-warning
'bug-reference
(format-message
"The value of `bug-reference-bug-regexp'
%S
in buffer %S doesn't conform to the contract specified by its
docstring. The subexpression 1 should define the region of the
bug-reference overlay and cover all other subexpressions up to
subexpression 10."
bug-reference-bug-regexp
(buffer-name))))
(cons (match-beginning 0) (match-end 0)))))
(defun bug-reference-fontify (start end)
"Apply bug reference overlays to the region between START and END."
(save-excursion
(let* ((beg-line (progn (goto-char start) (line-beginning-position)))
(end-line (progn (goto-char end) (line-end-position)))
;; Reuse existing overlays overlays.
(overlays (bug-reference--overlays-in beg-line end-line)))
(goto-char beg-line)
(while (and (< (point) end-line)
(re-search-forward bug-reference-bug-regexp end-line 'move))
(when (or (not bug-reference-prog-mode)
;; This tests for both comment and string syntax.
(nth 8 (save-match-data (syntax-ppss))))
(let* ((bounds (bug-reference--overlay-bounds))
(overlay (or
(let ((ov (pop overlays)))
(when ov
(move-overlay ov (car bounds) (cdr bounds))
ov))
(let ((ov (make-overlay (car bounds) (cdr bounds)
nil t nil)))
(overlay-put ov 'category 'bug-reference)
ov))))
;; Don't put a link if format is undefined.
(when bug-reference-url-format
(overlay-put overlay 'bug-reference-url
(if (stringp bug-reference-url-format)
(format bug-reference-url-format
(match-string-no-properties 2))
(funcall bug-reference-url-format)))))))
;; Delete remaining but unused overlays.
(dolist (ov overlays)
(delete-overlay ov))
;; Signal the bounds we actually fontified to jit-lock to allow for
;; optimizations (bug#70796).
`(jit-lock-bounds ,beg-line . ,end-line))))
;; Taken from button.el.
(defun bug-reference-push-button (&optional pos _use-mouse-action)
"Open URL corresponding to the bug reference at POS."
(interactive
(list (if (integerp last-command-event) (point) last-command-event)))
(when (null bug-reference-url-format)
(user-error
"You must customize some bug-reference variables; see Emacs info node Bug Reference"))
(if (and (not (integerp pos)) (eventp pos))
;; POS is a mouse event; switch to the proper window/buffer
(let ((posn (event-start pos)))
(with-current-buffer (window-buffer (posn-window posn))
(bug-reference-push-button (posn-point posn) t)))
;; POS is just normal position.
(dolist (o (overlays-at pos))
;; It should only be possible to have one URL overlay.
(let ((url (overlay-get o 'bug-reference-url)))
(when url
(browse-url url))))))
(defun bug-reference-maybe-setup-from-vc (url url-rx bug-rx bug-url-fmt)
(when (string-match url-rx url)
(setq-local bug-reference-bug-regexp bug-rx)
(setq-local bug-reference-url-format
(let (groups)
(dotimes (i (/ (length (match-data)) 2))
(push (match-string i url) groups))
(funcall bug-url-fmt (nreverse groups))))))
(defvar bug-reference--setup-from-vc-alist nil
"An alist for setting up `bug-reference-mode' based on VC URL.
This is like `bug-reference-setup-from-vc-alist' but generated
from a few default entries, and the value of
`bug-reference-forge-alist'.")
(defvar bug-reference-forge-alist
'(("github.com" github "https")
("gitea.com" gitea "https")
("codeberg.org" gitea "https")
("gitlab.com" gitlab "https")
("framagit.org" gitlab "https")
("salsa.debian.org" gitlab "https")
("sr.ht" sourcehut "https"))
"An alist of forge instances.
Each entry has the form (HOST-DOMAIN FORGE-TYPE PROTOCOL).
HOST-DOMAIN is the host- and domain name, e.g., gitlab.com,
salsa.debian.org, or sr.ht.
FORGE-TYPE is the type of the forge, e.g., gitlab, gitea,
sourcehut, or github.
PROTOCOL is the protocol for accessing the forge's issue tracker,
usually \"https\" but for self-hosted forge instances not
accessible via the internet it might also be \"http\".")
(cl-defgeneric bug-reference--build-forge-setup-entry
(host-domain forge-type protocol)
"Build an entry for `bug-reference--setup-from-vc-alist'.
HOST-DOMAIN is the host- and domain name, e.g., gitlab.com, or
sr.ht.
FORGE-TYPE is the type of the forge, e.g., gitlab, gitea,
sourcehut, or github.
PROTOCOL is the protocol for accessing the forge's issue tracker,
usually https but for self-hosted forge instances not accessible
via the internet it might also be http.")
;; GitHub: Here #17 may refer to either an issue or a pull request but
;; visiting the issue/17 web page will automatically redirect to the
;; pull/17 page if 17 is a PR. Explicit user/project#17 links to
;; possibly different projects are also supported.
(cl-defmethod bug-reference--build-forge-setup-entry
(host-domain (_forge-type (eql 'github)) protocol)
`(,(concat "[/@]" (regexp-quote host-domain)
"[/:]\\([.A-Za-z0-9_/-]+?\\)\\(?:\\.git\\)?/?\\'")
"\\(\\([.A-Za-z0-9_/-]+\\)?\\(?:#\\)\\([0-9]+\\)\\)\\>"
,(lambda (groups)
(let ((ns-project (nth 1 groups)))
(lambda ()
(format "%s://%s/%s/issues/%s"
protocol host-domain
(or (match-string-no-properties 2) ns-project)
(match-string-no-properties 3)))))))
;; GitLab: Here #18 is an issue and !17 is a merge request. Explicit
;; namespace/project#18 or namespace/project!17 references to possibly
;; different projects are also supported.
(cl-defmethod bug-reference--build-forge-setup-entry
(host-domain (_forge-type (eql 'gitlab)) protocol)
`(,(concat "[/@]" (regexp-quote host-domain)
"[/:]\\([.A-Za-z0-9_/-]+?\\)\\(?:\\.git\\)?/?\\'")
"\\(\\([.A-Za-z0-9_/-]+\\)?\\([#!]\\)\\([0-9]+\\)\\)\\>"
,(lambda (groups)
(let ((ns-project (nth 1 groups)))
(lambda ()
(format "%s://%s/%s/-/%s/%s"
protocol host-domain
(or (match-string-no-properties 2) ns-project)
(if (string= (match-string-no-properties 3) "#")
"issues/"
"merge_requests/")
(match-string-no-properties 4)))))))
;; Gitea: The systematics is exactly as for Github projects.
(cl-defmethod bug-reference--build-forge-setup-entry
(host-domain (_forge-type (eql 'gitea)) protocol)
`(,(concat "[/@]" (regexp-quote host-domain)
"[/:]\\([.A-Za-z0-9_/-]+?\\)\\(?:\\.git\\)?/?\\'")
"\\(\\([.A-Za-z0-9_/-]+\\)?\\(?:#\\)\\([0-9]+\\)\\)\\>"
,(lambda (groups)
(let ((ns-project (nth 1 groups)))
(lambda ()
(format "%s://%s/%s/issues/%s"
protocol host-domain
(or (match-string-no-properties 2) ns-project)
(match-string-no-properties 3)))))))
;; Sourcehut: #19 is an issue. Other project's issues can be
;; referenced as ~user/project#19.
;;
;; Caveat: The code assumes that a project on git.sr.ht or hg.sr.ht
;; has a tracker of the same name on todo.sh.ht. That's a very common
;; setup but all sr.ht services are loosely coupled, so you can have a
;; repo without tracker, or a repo with a tracker using a different
;; name, etc. So we can only try to make a good guess.
(cl-defmethod bug-reference--build-forge-setup-entry
(host-domain (_forge-type (eql 'sourcehut)) protocol)
`(,(concat "[/@]\\(?:git\\|hg\\)." (regexp-quote host-domain)
"[/:]\\(~[.A-Za-z0-9_/-]+\\)")
"\\(\\(~[.A-Za-z0-9_/-]+\\)?\\(?:#\\)\\([0-9]+\\)\\)\\>"
,(lambda (groups)
(let ((ns-project (nth 1 groups)))
(lambda ()
(format "%s://todo.%s/%s/%s"
protocol host-domain
(or (match-string-no-properties 2) ns-project)
(match-string-no-properties 3)))))))
(defun bug-reference--setup-from-vc-alist (&optional rebuild)
"Compute the `bug-reference--setup-from-vc-alist' value.
If REBUILD is non-nil, compute it again even if has been computed
already. The value contains a few default entries, and entries
generated from `bug-reference-forge-alist'."
(if (and bug-reference--setup-from-vc-alist
(null rebuild))
bug-reference--setup-from-vc-alist
(setq bug-reference--setup-from-vc-alist
`(;; GNU projects on savannah.
;;
;; Not all of them use debbugs but that doesn't really
;; matter because the auto-setup is only performed if
;; `bug-reference-url-format' and
;; `bug-reference-bug-regexp' aren't set already.
("git\\.\\(?:sv\\|savannah\\)\\.gnu\\.org:"
"\\(\\b\\(?:[Bb]ug ?#?\\)\\([0-9]+\\(?:#[0-9]+\\)?\\)\\)\\>"
,(lambda (_) "https://debbugs.gnu.org/%s"))
;; Entries for the software forges of
;; `bug-reference-forge-alist'.
,@(mapcar (lambda (entry)
(apply #'bug-reference--build-forge-setup-entry entry))
bug-reference-forge-alist)))))
(defvar bug-reference-setup-from-vc-alist nil
"An alist for setting up `bug-reference-mode' based on VC URL.
Each element has the form (URL-REGEXP BUG-REGEXP URL-FORMAT-FN).
URL-REGEXP is matched against the version control URL of the
current buffer's file. If it matches, BUG-REGEXP is set as
`bug-reference-bug-regexp'. URL-FORMAT-FN is a function of one
argument that receives a list of the groups 0 to N of matching
URL-REGEXP against the VCS URL and returns the value to be set as
`bug-reference-url-format'.")
(defun bug-reference-try-setup-from-vc ()
"Try setting up `bug-reference-mode' based on VC information.
Test each configuration in `bug-reference-setup-from-vc-alist'
and `bug-reference--setup-from-vc-alist' and apply it if
applicable."
(when-let ((file-or-dir (or buffer-file-name
;; Catches modes such as vc-dir and Magit.
default-directory))
(backend (vc-responsible-backend file-or-dir t))
(url (seq-some (lambda (remote)
(ignore-errors
(vc-call-backend backend 'repository-url
file-or-dir remote)))
'("upstream" nil))))
(seq-some (lambda (config)
(apply #'bug-reference-maybe-setup-from-vc url config))
(append bug-reference-setup-from-vc-alist
(bug-reference--setup-from-vc-alist)))))
(defvar bug-reference-setup-from-mail-alist
`((,(regexp-opt '("emacs" "auctex" "gnus" "tramp" "orgmode") 'words)
,(regexp-opt '("@debbugs.gnu.org" "-devel@gnu.org"
;; List-Id of Gnus devel mailing list.
"ding.gnus.org"))
"\\(\\b[Bb]ug ?#?\\([0-9]+\\(?:#[0-9]+\\)?\\)\\)"
"https://debbugs.gnu.org/%s"))
"An alist for setting up `bug-reference-mode' in mail modes.
This takes action if `bug-reference-mode' is enabled in group and
message buffers of Emacs mail clients. Currently, Gnus and Rmail
are supported.
Each element has the form
(GROUP-REGEXP HEADER-REGEXP BUG-REGEXP URL-FORMAT)
GROUP-REGEXP is a regexp matched against the current mail folder
or newsgroup name. HEADER-REGEXP is a regexp matched against the
From, To, Cc, Newsgroup, and List-ID header values of the current
mail or newsgroup message. If any of those matches, BUG-REGEXP
is set as `bug-reference-bug-regexp' and URL-FORMAT is set as
`bug-reference-url-format'.
Note: In Gnus, if a summary buffer has been set up based on
GROUP-REGEXP, all article buffers opened from there will get the
same `bug-reference-url-format' and `bug-reference-url-format'.")
(defvar gnus-newsgroup-name)
(defun bug-reference-maybe-setup-from-mail (group header-values)
"Set up according to mail GROUP or HEADER-VALUES.
Group is a mail group/folder name and HEADER-VALUES is a list of
mail header values, e.g., the values of From, To, Cc, List-ID,
and Newsgroup.
If any GROUP-REGEXP or HEADER-REGEXP of
`bug-reference-setup-from-mail-alist' matches GROUP or any
element in HEADER-VALUES, the corresponding BUG-REGEXP and
URL-FORMAT are set."
(catch 'setup-done
(dolist (config bug-reference-setup-from-mail-alist)
(when (or
(and group
(car config)
(string-match-p (car config) group))
(and header-values
(nth 1 config)
(catch 'matching-header
(dolist (h header-values)
(when (and h (string-match-p (nth 1 config) h))
(throw 'matching-header t))))))
(setq-local bug-reference-bug-regexp (nth 2 config))
(setq-local bug-reference-url-format (nth 3 config))
(throw 'setup-done t)))))
(defun bug-reference-try-setup-from-gnus ()
"Try setting up `bug-reference-mode' based on Gnus group or article.
Test each configuration in `bug-reference-setup-from-mail-alist'
and set it if applicable."
(when (and (derived-mode-p 'gnus-summary-mode)
(bound-and-true-p gnus-newsgroup-name))
;; Gnus reuses its article buffer so we have to check whenever the
;; article changes.
(add-hook 'gnus-article-prepare-hook
#'bug-reference--try-setup-gnus-article)
(bug-reference-maybe-setup-from-mail gnus-newsgroup-name nil)))
(defvar gnus-article-buffer)
(defvar gnus-original-article-buffer)
(defvar gnus-summary-buffer)
(defvar bug-reference-mode)
(defun bug-reference--try-setup-gnus-article ()
(when (and bug-reference-mode ;; Only if enabled in article buffers.
(derived-mode-p
'(gnus-article-mode
;; Apparently, `gnus-article-prepare-hook' is run in the
;; summary buffer...
gnus-summary-mode))
gnus-article-buffer
gnus-original-article-buffer
(buffer-live-p (get-buffer gnus-article-buffer))
(buffer-live-p (get-buffer gnus-original-article-buffer)))
(with-current-buffer gnus-article-buffer
(catch 'setup-done
;; Copy over the values from the summary buffer.
(when (and gnus-summary-buffer
(buffer-live-p gnus-summary-buffer))
(setq-local bug-reference-bug-regexp
(with-current-buffer gnus-summary-buffer
bug-reference-bug-regexp))
(setq-local bug-reference-url-format
(with-current-buffer gnus-summary-buffer
bug-reference-url-format))
(when (and bug-reference-bug-regexp
bug-reference-url-format)
(throw 'setup-done t)))
;; If the summary had no values, try setting according to
;; the values of the From, To, and Cc headers.
(let (header-values)
(with-current-buffer
gnus-original-article-buffer
(save-excursion
(goto-char (point-min))
;; The Newsgroup is omitted because we already matched
;; based on group name in the summary buffer.
(dolist (field '("list-id" "to" "from" "cc"))
(let ((val (mail-fetch-field field)))
(when val
(push val header-values))))))
(bug-reference-maybe-setup-from-mail nil header-values))))))
(defun bug-reference-try-setup-from-rmail ()
"Try setting up `bug-reference-mode' from the current rmail mail.
Guesses suitable `bug-reference-bug-regexp' and
`bug-reference-url-format' values by matching the current Rmail
file's name against GROUP-REGEXP and the values of List-Id, To,
From, and Cc against HEADER-REGEXP in
`bug-reference-setup-from-mail-alist'."
(when (and bug-reference-mode
(derived-mode-p 'rmail-mode))
(let (header-values)
(save-excursion
(goto-char (point-min))
(dolist (field '("list-id" "to" "from" "cc"))
(let ((val (mail-fetch-field field)))
(when val
(push val header-values)))))
(bug-reference-maybe-setup-from-mail
(buffer-file-name) header-values))))
(defvar bug-reference-setup-from-irc-alist
`((,(concat "#" (regexp-opt '("emacs" "gnus" "org-mode" "rcirc"
"erc") 'words))
"Libera.Chat"
"\\(\\b[Bb]ug ?#?\\([0-9]+\\(?:#[0-9]+\\)?\\)\\)"
"https://debbugs.gnu.org/%s"))
"An alist for setting up `bug-reference-mode' in IRC modes.
This takes action if `bug-reference-mode' is enabled in IRC
channels using one of Emacs's IRC clients. Currently, rcirc and
ERC are supported.
Each element has the form
(CHANNEL-REGEXP NETWORK-REGEXP BUG-REGEXP URL-FORMAT)
CHANNEL-REGEXP is a regexp matched against the current IRC
channel name (e.g. #emacs). NETWORK-REGEXP is matched against
the IRC network name (e.g. Libera.Chat). Both entries are
optional. If all given entries match, BUG-REGEXP is set as
`bug-reference-bug-regexp' and URL-FORMAT is set as
`bug-reference-url-format'.")
(defun bug-reference-maybe-setup-from-irc (channel network)
"Set up according to IRC CHANNEL or NETWORK.
CHANNEL is an IRC channel name (or generally a target, i.e., it
could also be a user name) and NETWORK is that channel's network
name.
If any `bug-reference-setup-from-irc-alist' entry's
CHANNEL-REGEXP and NETWORK-REGEXP match CHANNEL and NETWORK, the
corresponding BUG-REGEXP and URL-FORMAT are set."
(catch 'setup-done
(dolist (config bug-reference-setup-from-irc-alist)
(let ((channel-rx (car config))
(network-rx (nth 1 config)))
(when (and
;; One of both has to be given.
(or channel-rx network-rx)
;; The args have to be set.
channel network)
(when (and
(or (null channel-rx)
(string-match-p channel-rx channel))
(or (null network-rx)
(string-match-p network-rx network)))
(setq-local bug-reference-bug-regexp (nth 2 config))
(setq-local bug-reference-url-format (nth 3 config))
(throw 'setup-done t)))))))
(defvar rcirc-target)
(defvar rcirc-server-buffer)
(defvar rcirc-server)
(defun bug-reference-try-setup-from-rcirc ()
"Try setting up `bug-reference-mode' based on rcirc channel and server.
Test each configuration in `bug-reference-setup-from-irc-alist'
and set it if applicable."
(when (derived-mode-p 'rcirc-mode)
(bug-reference-maybe-setup-from-irc
rcirc-target
(and rcirc-server-buffer
(buffer-live-p rcirc-server-buffer)
(with-current-buffer rcirc-server-buffer
rcirc-server)))))
(declare-function erc-format-target "erc")
(declare-function erc-network-name "erc-networks")
(defun bug-reference-try-setup-from-erc ()
"Try setting up `bug-reference-mode' based on ERC channel and server.
Test each configuration in `bug-reference-setup-from-irc-alist'
and set it if applicable."
(when (derived-mode-p 'erc-mode)
(bug-reference-maybe-setup-from-irc
(erc-format-target)
(erc-network-name))))
(defvar bug-reference-auto-setup-functions nil
"Functions trying to auto-setup `bug-reference-mode'.
These functions are run after `bug-reference-mode' has been
activated in a buffer and try to guess suitable values for
`bug-reference-bug-regexp' and `bug-reference-url-format'. Their
guesswork is based on these variables:
- `bug-reference-setup-from-vc-alist' for guessing based on
version control, e.g., URL of repository.
- `bug-reference-setup-from-mail-alist' for guessing based on
mail group names or mail header values.
- `bug-reference-setup-from-irc-alist' for guessing based on IRC
channel or network names.
Note: This variable's purpose is to allow packages to provide
bug-reference auto-setup support in buffers managed by this
package. Therefore, such auto-setup function should check if the
current buffer is \"their\" buffer and only act if that's the
case, e.g., in terms of `derived-mode-p'.
The variable is not intended for users. Those are advised to set
`bug-reference-bug-regexp' and `bug-reference-url-format' using
other means such as file-local variable sections, a
`.dir-locals.el' file, or compute and set their values in
`bug-reference-mode-hook' or `bug-reference-prog-mode-hook'. If
the bug regexp and URL format are already set after those hooks
have been run, the auto-setup is inhibited.")
;; Add the default auto-setup functions. We don't have them as
;; init value of bug-reference-auto-setup-functions because then
;; they wouldn't be added if some package uses
;;
;; (add-hook 'bug-reference-auto-setup-functions
;; #'my-pkg--bug-reference-try-setup-from-my-pkg)
;;
;; before bug-reference.el is loaded.
(dolist (fn (list #'bug-reference-try-setup-from-vc
#'bug-reference-try-setup-from-gnus
#'bug-reference-try-setup-from-rmail
#'bug-reference-try-setup-from-rcirc
#'bug-reference-try-setup-from-erc))
(add-hook 'bug-reference-auto-setup-functions fn))
(defun bug-reference--run-auto-setup ()
(when (or bug-reference-mode
bug-reference-prog-mode)
;; Automatic setup only if the variables aren't already set, e.g.,
;; by a local variables section in the file.
(unless (and bug-reference-bug-regexp
bug-reference-url-format)
(with-demoted-errors
"Error during bug-reference auto-setup: %S"
(run-hook-with-args-until-success
'bug-reference-auto-setup-functions)))))
(defun bug-reference--url-at-point ()
"`thing-at-point' provider function."
(thing-at-point-for-char-property 'bug-reference-url))
(defun bug-reference--forward-url (backward)
"`forward-thing' provider function."
(forward-thing-for-char-property 'bug-reference-url backward))
(defun bug-reference--bounds-of-url-at-point ()
"`bounds-of-thing-at-point' provider function."
(bounds-of-thing-at-point-for-char-property 'bug-reference-url))
(defun bug-reference--init (enable)
(if enable
(progn
(jit-lock-register #'bug-reference-fontify)
(setq-local thing-at-point-provider-alist
(cons '(url . bug-reference--url-at-point)
thing-at-point-provider-alist))
(setq-local forward-thing-provider-alist
(cons '(url . bug-reference--forward-url)
forward-thing-provider-alist))
(setq-local bounds-of-thing-at-point-provider-alist
(cons '(url . bug-reference--bounds-of-url-at-point)
bounds-of-thing-at-point-provider-alist)))
(jit-lock-unregister #'bug-reference-fontify)
(setq thing-at-point-provider-alist
(delete '((url . bug-reference--url-at-point))
thing-at-point-provider-alist))
(setq forward-thing-provider-alist
(delete '((url . bug-reference--forward-url))
forward-thing-provider-alist))
(setq bounds-of-thing-at-point-provider-alist
(delete '((url . bug-reference--bounds-of-url-at-point))
bounds-of-thing-at-point-provider-alist))
(save-restriction
(widen)
(bug-reference-unfontify (point-min) (point-max)))))
;;;###autoload
(define-minor-mode bug-reference-mode
"Toggle hyperlinking bug references in the buffer (Bug Reference mode)."
:after-hook (bug-reference--run-auto-setup)
(bug-reference--init bug-reference-mode))
(defun bug-reference-mode-force-auto-setup ()
"Enable `bug-reference-mode' and force auto-setup.
Enabling `bug-reference-mode' runs its auto-setup only if
`bug-reference-bug-regexp' and `bug-reference-url-format' are not
set already. This function sets the latter to nil
buffer-locally, so that the auto-setup will always run.
This is mostly intended for MUA modes like `rmail-mode' where the
same buffer is reused for different contexts."
(setq-local bug-reference-url-format nil)
(bug-reference-mode))
;;;###autoload
(define-minor-mode bug-reference-prog-mode
"Like `bug-reference-mode', but only buttonize in comments and strings."
:after-hook (bug-reference--run-auto-setup)
(bug-reference--init bug-reference-prog-mode))
(provide 'bug-reference)
;;; bug-reference.el ends here
|
