-
Notifications
You must be signed in to change notification settings - Fork 1
/
Copy pathperl-doc.el
1457 lines (1345 loc) · 54 KB
/
perl-doc.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
;;; perl-doc.el --- Read Perl documentation -*- lexical-binding: t -*-
;; Copyright (C) 2022-2023 Free Software Foundation, Inc.
;; Author: Harald Jörg <[email protected]>
;; Maintainer: Harald Jörg <[email protected]>
;; Created: 2022
;; Version: 0.81
;; Keywords: languages
;; URL: https://github.com/HaraldJoerg/emacs-perl-doc
;; Package-Requires: ((emacs "27"))
;; This file 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 file 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 contains a command to read Perl documentation in Emacs.
;; It uses two external commands which come with Perl: `perldoc` to
;; locate the Perl documentation for the Perl modules installed on
;; your system, and `pod2html` to format the documentation to HTML.
;; This HTML version is then displayed using Emacs' "simple HTML
;; renderer" shr.
;;
;; Motivation
;;
;; Perl documentation is written in a markup format called POD ("Plain
;; Old Documentation") and is usually converted to other formats for
;; reading by humans. The documentation used to be available in Emacs
;; for a long time in 'info' or 'man' format. However, Perl does no
;; longer ship 'info' files, and the software available from CPAN
;; never did. 'man' is not available on all platforms and allows only
;; rather restricted formatting, most notably linking between
;; documents does not work.
;; On the other hand, Perl provides a converter from POD to HTML.
;; HTML is well supported by Emacs and is well suited for presentation
;; of structured documents.
;; The user visible benefits over the other formats are:
;;
;; * Works nicely on platforms which do not have man
;;
;; * Unlike with 'man', Hyperlinks between POD documents work and
;; resolve to POD documentation on your system, no web server
;; required.
;;
;; * Makes use of Emacs faces: variable-pitch font for text,
;; fixed-pitch for code, italics for, well, italics
;;; Code:
;;; Compatibility with older Emacs versions
;; Available in Emacs 28: format-prompt
(defalias 'perl-doc--format-prompt
(if (fboundp 'format-prompt) 'format-prompt
(lambda (msg default)
(if default (format "%s (default %s): " msg default)
(concat msg ": ")))))
;; Available in Emacs 28: string-search
(defun perl-doc--string-search (needle haystack)
"Search for the string NEEDLE in the string HAYSTACK.
Returns nil if no NEEDLE was found, non-nil otherwise. This is a
reduced version of the function `string-search' which is
sufficient for the purpose of this module and works in Emacs 27."
(string-match (regexp-quote needle) haystack))
;; We use some features from cperl-mode:
;; * cperl-word-at-point : Finding Perl syntax elements
;; * cperl-short-docs : Tell functions from modules (for use with -f)
(require 'cperl-mode)
(require 'shr)
(require 'face-remap)
(require 'imenu)
(require 'speedbar)
(defcustom perl-doc-perl-program "perl"
"Path to the Perl interpreter."
:type 'file
:group 'perl-doc)
(defcustom perl-doc-pod2html-program "pod2html"
"Path to the shell command pod2html."
:type 'file
:group 'perl-doc)
(defcustom perl-doc-perldoc-program "perldoc"
"Path to the shell command perldoc."
:type 'file
:group 'perl-doc)
(defcustom perl-doc-extra-libs '()
"A list of directories to scan for POD documentation.
This is in addition to what's built into the Perl executable as
@INC and what is in the environment variable \"PERL5LIB\". This
allows to read documentation for modules which you do not want to
be used by the Perl interpreter."
:group 'perl-doc
:type '(repeat directory))
(defvar perl-doc--debug nil
"If non-nil, unrecognized POD links are reported to the message buffer.
This is only relevant for developers, not for users.")
;; Make elint-current-buffer happy
(defvar button-buffer-map) ; in button.el
(defvar special-mode-map) ; in simple.el
(defun perl-doc--index-available-p ()
"Return a non-nil value if an `imenu' index can be built.
Our current implementation is based on shr, which started to use
named faces for headings (which we use to build the index) in
Emacs 28."
(facep 'shr-h1))
(defvar perl-doc-mode-map
(let ((map (make-sparse-keymap)))
(set-keymap-parent
map (make-composed-keymap button-buffer-map special-mode-map))
(define-key map [follow-link] 'mouse-face)
(define-key map [mouse-2] #'perl-doc-browse-url)
(define-key map "\r" #'perl-doc-browse-url)
(define-key map "v" #'perl-doc-view-source)
map)
"A keymap to allow following links in perldoc buffers.")
(defmacro perl-doc--with-environment-variables (variables &rest body)
"Set VARIABLES in the environment and execute BODY.
VARIABLES is a list of variable settings of the form (VAR VALUE),
where VAR is the name of the variable (a string) and VALUE
is its value (also a string).
The previous values will be restored upon exit.
This is an 1:1 copy of the macro with-environment-variables.
I (haj) was about to write it a macro which did that when I
noticed that it is included in Emacs 28. So I dropped my own
version, and will drop this one as well when the minimum Emacs
version is raised to 28."
(declare (indent 1) (debug (sexp body)))
(unless (consp variables)
(error "Invalid VARIABLES: %s" variables))
`(let ((process-environment (copy-sequence process-environment)))
,@(mapcar (lambda (elem)
`(setenv ,(car elem) ,(cadr elem)))
variables)
,@body))
;;;
;;; perl-doc-mode Index functions
;;;
(defun perl-doc--heading-properties (_ face-or-list-of-faces)
"Examine the FACE-OR-LIST-OF-FACES for headings.
If a heading face is present, return a cons cell (face . depth)
with the actual face found and its numerical depth in the hierarchy.
Return nil if no heading face is present in FACE-OR-LIST-OF-FACES."
(let ((faces (if (listp face-or-list-of-faces)
face-or-list-of-faces
(list face-or-list-of-faces)))
face level)
(while (and faces (null level))
(if (member (setq face (car faces))
'(shr-h1 shr-h2 shr-h3 shr-h4 shr-h5 shr-h6))
(setq level (string-to-number
(substring (face-name face) -1)))
(setq faces (cdr faces))))
(if level (cons face level) nil)))
(defun perl-doc--heading-face-end-p (expected got)
"Find the first character where the face EXPECTED is not in GOT."
(not (member expected (if (listp got) got (list got)))))
(defun perl-doc-create-imenu-index ()
"Create an imenu index for the current buffer."
(goto-char (point-min))
(let (index start-match end-match)
(while (setq start-match (text-property-search-forward
'face nil
#'perl-doc--heading-properties))
(let* ((heading-properties (perl-doc--heading-properties
nil
(prop-match-value start-match)))
(face (car heading-properties))
(level (cdr heading-properties)))
(setq end-match (text-property-search-forward
'face face
#'perl-doc--heading-face-end-p))
(let* ((start (prop-match-beginning start-match))
(end (prop-match-beginning end-match))
(marker (copy-marker start))
(text (concat
(make-string (1- level) ?. )
(buffer-substring-no-properties start end))))
(push (cons text marker) index))))
(reverse index)))
(define-derived-mode perl-doc-mode special-mode "perl-doc"
"A mode for displaying Perl documentation.
The following key bindings are currently in effect in the buffer:
\\{perl-doc-mode-map}"
:interactive nil
(setq buffer-auto-save-file-name nil)
(buffer-disable-undo)
(auto-fill-mode -1)
(add-hook 'window-size-change-functions #'perl-doc--auto-refresh nil t)
(set-buffer-modified-p nil)
(setq-local bidi-paragraph-direction 'left-to-right)
;; Creating the index only works with shr faces which have been
;; added in Emacs 28
(when (perl-doc--index-available-p)
(setq-local imenu-create-index-function #'perl-doc-create-imenu-index)))
(defun perl-doc-goto-section (section)
"Find SECTION in the current buffer.
There is no precise indicator for SECTION in shr-generated
buffers, so this function is using some fuzzy regexp matching
which takes into account that the perldoc/pod2html workflow has
no clear specification what makes a section."
(goto-char (point-min))
;; Here's a workaround for a misunderstanding between pod2html and
;; shr: pod2html converts a section like "/__SUB__" to a fragment
;; "#SUB__". The shr renderer doesn't pick id elements in its
;; character properties, so we need to sloppily allow leading "__"
;; before looking for the text of the heading.
(let ((target-re (replace-regexp-in-string "-" "." (regexp-quote section)))
(prefix "^\\(__\\)?")
(suffix "\\([[:blank:]]\\|$\\)"))
(if (re-search-forward (concat prefix target-re suffix) nil t)
(goto-char (line-beginning-position))
(message "Warning: No section '%s' found." section))))
(defmacro perl-doc-with-L-grammar (&rest body)
"Execute BODY with rx extensions for POD's L<...> element.
In Perl's documentation format POD, the link element L<...>
is the most complex. This macro defines syntactic components
which allow to process these elements with some confidence."
`(rx-let
((backslash ?\\)
(double-quote ?\")
(escaped (char) (sequence backslash char))
(quoted (sequence double-quote
(zero-or-more
(or
(escaped backslash)
(escaped double-quote)
(not double-quote)))
double-quote))
(plain (not (any "|<>"))) ; no link nor markup special chars
(extended (not (any "|/"))) ; markup is ok, separators are not ok
(unrestricted (seq (not ?/) (* any))) ; not starting with a slash
(not-markup (seq (not (any "A-Z")) "<")) ; A "harmless" less-than char
(markup-start (sequence (in "A-Z") "<"))
(link-start (sequence "L<" (optional (group-n 1 (1+ "<") " "))))
(simple-markup (sequence
markup-start
(+? (or
(not (any "<>/"))
not-markup))
">"))
(extended-markup (sequence
(in "A-Z") "<<" space ; opening phrase
;; Delimiters are forbidden in links,
;; allowed elsewhwere. We can ignore
;; this since we only treat links here)
(+? any)
space ">>")) ; ending phrase
(markup ; We allow _one_ level of nesting
(or extended-markup
(sequence markup-start
(+? (or extended-markup
simple-markup
not-markup
(not (any "/>"))))
">")))
;; Now these are the things we're actually after: The parts
;; that make a L<name|url> link. We expect either an URL
;; or a name for the target.
(component (or plain markup not-markup))
(name (group-n 2 (zero-or-more
(or (not (any " \"\t|/<>"))
markup))))
(url (group-n 2 (sequence (one-or-more alpha) ; protocol
":/"
(one-or-more (not (any " |<>"))))))
;; old-style references to a section in the same page.
;; This style is deprecated, but found in the wild. We are
;; following the recommended heuristic from perlpodspec:
;; .... if it contains any whitespace, it's a section.
;; We also found quoted things to be sections.
(old-section
(group-n 2
(or (sequence (1+ component) blank (1+ component))
quoted)))
(text-simple (group-n 1 (+? component)))
(section-simple (group-n 3 (or quoted (+ component))))
(link-re-simple (sequence
point
(? (sequence text-simple "|" (? space)))
(or url
(sequence name (? (sequence "/" section-simple)))
old-section)
">"))
(text-extended (group-n 1 (+? extended)))
(section-extended (group-n 3 (or quoted unrestricted)))
(link-re-extended (sequence
point
(? (or text-extended (? space)))
(or url
(sequence name (? (sequence "/" section-extended)))
old-section)
))
)
,@body))
(defun perl-doc--process-links ()
"Find the next link in a POD section, and process it.
The L<...> syntax is the most complex markup in the POD family of
strange things. Also, quite a lot of modules on CPAN and
elsewhere found ways to violate the spec in interesting ways
which seem to work, at least, with some formatters."
;; Note: Processing links can't be done with syntax tables by using
;; <> as a bracket pair because links can contain unbalanced < or >
;; symbols. So do it the hard way....
(goto-char (point-min))
;; Links, in general, have three components: L<text|name/section>.
;; "text" is what POD readers should display. "name" is the link target
;; (a POD file or a Perl module), and "section" is an anchor within
;; the link target.
;; In the following we match and capture like this:
;; - (match-string 1) to text, which is optional
;; - (match-string 2) to name, which is mandatory but may be empty
;; for targets in the same file. We capture old-style sections
;; here, too, because syntactically they look like names.
;; - (match-string 3) to section.
;; Links can contain markup, too. We support two levels of nesting
;; (because we've seen such things in the wild), but only with
;; single <> delimiters. For the link element as a whole,
;; L<<< stuff >>> is supported.
(perl-doc-with-L-grammar
(while (re-search-forward (rx link-start) nil t)
(let* ((terminator-length (length (match-string 1)))
(allow-angle (> terminator-length 0)); L<< ... >>
(re (if allow-angle (concat (rx link-re-extended)
(make-string terminator-length ?>))
(rx link-re-simple)))
(end-marker (make-marker)))
(re-search-forward re nil t)
(set-marker end-marker (match-end 0))
(cond
((null (match-string 2))
;; This means that the regexp failed. Either the L<...>
;; element is really, really bad, or the regexp isn't
;; complicated enough. Since the consequences are rather
;; harmless, don't raise an error.
(when perl-doc--debug
(message "perl-doc: Unexpected string: %s"
(buffer-substring (line-beginning-position)
(line-end-position)))))
((string= (match-string 2) "")
;; L<Some text|/anchor> or L</anchor> -> don't touch
nil)
((save-match-data
(string-match "^\\w+:/" (match-string 2)))
;; L<https://www.perl.org/> -> don't touch
nil)
((save-match-data
(string-match " " (match-string 2)))
;; L<SEE ALSO> -> L<SEE ALSO|/"SEE ALSO">, fix old style section
(goto-char (match-end 2))
(insert "\"")
(goto-char (match-beginning 2))
(insert (concat (match-string 2) "|/\"")))
((save-match-data
(and (match-string 1) (string-match (rx quoted) (match-string 2))))
;; L<unlink1|"unlink1"> -> L<unlink1|/"unlink1">, as seen in File::Temp
(goto-char (match-beginning 2))
(insert "/"))
((save-match-data
(string-match (rx quoted) (match-string 2)))
;; L<"safe_level"> -> L<safe_level|/"safe_level">, as seen in File::Temp
(goto-char (match-beginning 2))
(insert (concat (substring (match-string 2) 1 -1) "|/")))
((match-string 3)
;; L<Some text|page/sect> -> L<Some text|perldoc:///page/sect>
;; L<page/section> -> L<page/section|perldoc:///page/section>
;; In both cases:
;; Work around a bug in pod2html as of 2020-07-27: It
;; doesn't grok spaces in the "section" part, though they
;; are perfectly valid. Also, it retains quotes around
;; sections which it removes for links to local sections.
(let ((section (match-string 3))
(text (if (match-string 1) ""
(concat (match-string 3)
" in "
(match-string 2) "|"))))
(save-match-data
(setq section (replace-regexp-in-string "\"" "" section))
(setq section (replace-regexp-in-string " " "-" section)))
(goto-char (match-beginning 3))
(delete-char (- (match-end 3) (match-beginning 3)))
(insert section)
(goto-char (match-beginning 2))
(insert text)
(insert "perldoc:///")))
((match-string 1) ; but without section
;; L<Some text|page> -> L<Some text|perldoc:///page>
(goto-char (match-beginning 2))
(insert "perldoc:///"))
;; ((match-string 3)
;; ;; L<page/section> -> L<page/section|perldoc:///page/section>
;; ;; Work around a bug in pod2html as of 2020-07-27, see above
;; (goto-char (match-beginning 2))
;; (insert (concat (match-string 3) " in " (match-string 2)
;; "|" "perldoc:///")))
(t
;; L<page> -> L<page|perldoc:///page>
(goto-char (match-beginning 2))
(insert (concat (match-string 2) "|" "perldoc:///"))))
(goto-char (marker-position end-marker))))))
(defvar-local perl-doc-base nil)
(defvar-local perl-doc--current-topic nil)
(defvar-local perl-doc--current-type nil)
(defvar-local perl-doc--current-section nil)
(defvar-local perl-doc-text-scale nil)
(defvar-local perl-doc-window-width 0
"The width of a perl-doc-mode window in pixels. Used to avoid
unneccesary calls to -refresh: If only the height of the window
changes (which easily happens due to minibuffer and echo-area
activities), then we do not redraw.")
(defvar-local perl-doc-module-history nil
"This list keeps track of the documentation read so far.")
(defun perl-doc--collect-perl5lib ()
"Build a suitable PERL5LIB environment variable.
Uses the customizable value `perl-doc-extra-libs' and the
existing value of PERL5LIB. Either one, or both, may be empty."
(let ((extra-libs (if perl-doc-extra-libs
(mapconcat #'expand-file-name
perl-doc-extra-libs
path-separator)))
(perl5lib (getenv "PERL5LIB")))
(if (and extra-libs perl5lib)
(concat extra-libs path-separator perl5lib)
(or extra-libs perl5lib))))
(defun perl-doc--fetch-pod (topic type)
"Fetch the pod document for WORD.
WORD is the name of either a module, a file name, a function or a
variable. We use heuristics to identify functions (from
cperl-mode shortdocs) and variables (from their first character
being a sigil)."
;; Add our extra-libraries to PERL5LIB
(let ((args (pcase type
('perl-variable (list "-v" topic))
('perl-function (list "-f" topic))
(_ (list topic)))))
(perl-doc--with-environment-variables
(("PERL5LIB" (perl-doc--collect-perl5lib)))
;; Fetch plain POD into the current buffer
(not (< 0 (apply #'call-process
(append
(list perl-doc-perldoc-program nil t t "-u")
args)))))))
(defun perl-doc--render-pod ()
"Render the POD in the current buffer.
As a first step, process links in the POD document. Then,
converted POD to HTML with the external program pod2html, and
then render that HTML with `shr-render-region'."
(shell-command-on-region (point-min) (point-max)
(concat perl-doc-pod2html-program
" --cachedir="
(make-temp-file "perl-doc" t)
" --flush"
" --noindex"
" --quiet")
(current-buffer) t "*perldoc error*")
(shr-render-region (point-min) (point-max) (current-buffer))
(deactivate-mark)
;; Remove shr's keymap for links which would shadow our mode's keymap
(remove-text-properties (point-min) (point-max) '(keymap nil)))
(defun perl-doc--completion-check-choice (choice)
"Check whether the CHOICE made during completion is valid.
The purpose is to prevent exiting with a trailing \"::\" which
does not lead to valid POD but needs another completion. We do
permit, however, things which look like a variable or a function,
since there is no completion for those."
(null (string-match "::\\'" choice)))
(defun perl-doc--common (topic type &optional section noselect)
"Get Perl documentation for TOPIC of TYPE, the go to SECTION.
If NOSELECT, do not pop to the buffer. This is the common
backend for `perl-doc', `perl-doc-function' and others. TYPE is
one of the symbols m, f or v, declaring TOPIC as a module, a
function or a variable."
(let* ((case-fold-search nil)
(buffer-name-prefix '((perl-function . "f/")
(perl-variable . "v/")))
(perldoc-buffer (concat "*perldoc-"
(cdr (assoc type buffer-name-prefix))
(substring-no-properties topic)
"*")))
(unless (get-buffer perldoc-buffer)
;; Jump to the relevant frame (if applicable)
(dframe-select-attached-frame)
(with-current-buffer (get-buffer-create perldoc-buffer)
;; We do this early, so that our buffer-local variables can be
;; set without being clobbered by a subsequent `perl-doc-mode'.
(perl-doc-mode)
(let ((inhibit-read-only t))
(when (perl-doc--fetch-pod topic type)
(perl-doc--process-links)
(perl-doc--render-pod)
(when perl-doc-text-scale
(setq-local text-scale-mode-amount perl-doc-text-scale)
(text-scale-mode nil))
(if section
(perl-doc-goto-section section)
(goto-char (point-min)))))
(setq-local revert-buffer-function #'perl-doc--refresh
perl-doc--current-topic topic
perl-doc--current-type type
perl-doc--current-section section)
(setq-local perl-doc-window-width
(window-body-width (selected-window) t))))
;; Eventually, show the buffer and store current variables
(or noselect
(pop-to-buffer perldoc-buffer))))
;;;###autoload
(defun perl-doc (word &optional section)
"Get Perl documentation like the perldoc command.
Does better formatting than man pages, including hyperlinks."
;; Process user input to retrieve WORD
(interactive
(let* ((default (cperl-word-at-point))
(read (completing-read
(perl-doc--format-prompt
"Find doc for Perl topic" default)
#'perl-doc--complete-module
nil
;; Emacs 29 or newer needed for
;; REQUIRE-MATCH to be a function
(if (>= emacs-major-version 29)
#'perl-doc--completion-check-choice
nil)
nil
'perl-doc-module-history
default)))
(list (if (equal read "")
default
read))))
;; Apply heuristics to detect the type
(let ((type
(cond
((string-match (rx string-start (in "$@%")) word)
(setq-local perl-doc-base "perlvar")
'perl-variable)
((and
(string-match "^\\(-[A-Za-z]\\|[a-z2]+\\)$" word)
(string-match (concat "^" word "\\>")
(documentation-property
'cperl-short-docs
'variable-documentation))
;; FIXME: Ugly disambiguation between pragma and function
(not (string= word "open")))
(setq-local perl-doc-base "perlfunc")
'perl-function)
(t
(setq-local perl-doc-base nil)
'module))))
;; Eventually, do the hard work
(perl-doc--common word type section)))
;;;###autoload
(defun perl-doc-function (topic)
"Get Perl documentation for a builtin function WORD.
This retrieves the corresponding section from the perlfunc page.
No completion is done (yet). Sorry."
(interactive "MFunction name: ")
(perl-doc--common topic 'perl-function))
;;;###autoload
(defun perl-doc-variable (topic)
"Get Perl documentation for a builtin function WORD.
This retrieves the corresponding section from the perlfunc page.
No completion is done (yet). Sorry."
(interactive "MVariable name: ")
(perl-doc--common topic 'perl-variable))
;;;###autoload
(defun perl-doc-file (file)
"Run `perl-doc' on FILE.
This is the same as running `perl-doc' with FILE as an argument,
but provides file-name completion."
(interactive "f")
(let ((absolute-path (expand-file-name file)))
(setq-local default-directory (file-name-directory absolute-path))
(perl-doc--common absolute-path 'module)))
;; Make elint-current-buffer happy
(defvar text-scale-mode-amount) ; in face-remap.el, which we require
(defun perl-doc--buffer-namespace (buffer-name)
"Return the Perl namespace for the buffer named BUFFER-NAME.
Return nil if the buffer name does not fit the perl-doc schema
or if it fits the perl-doc schema for a file name."
(and (string-match (rx string-start "*perldoc-"
(group (+ (not (in "/"))))
"*" string-end)
buffer-name)
(match-string 1 buffer-name)))
(defun perl-doc--refresh (&optional _ignore-auto _noconfirm)
"Refresh the current piece of documentation."
(when (string-equal major-mode "perl-doc-mode")
(let ((inhibit-read-only t)
(position (point))
(scale (if (and (boundp 'text-scale-mode) text-scale-mode)
text-scale-mode-amount
nil)))
(erase-buffer)
(when (perl-doc--fetch-pod perl-doc--current-topic
perl-doc--current-type)
(perl-doc--process-links)
(perl-doc--render-pod)
(goto-char (min position (point-max)))
(when scale
(setq-local text-scale-mode-amount scale)
(text-scale-mode nil))))))
(defvar perl-doc--window-size-change-timer nil)
(defun perl-doc--auto-refresh (window)
"Reformat the page after a change of window size"
(when (and (window-live-p window)
(/= (window-body-width window t)
perl-doc-window-width))
(setq-local perl-doc-window-width
(window-body-width window t))
(when (timerp perl-doc--window-size-change-timer)
(cancel-timer perl-doc--window-size-change-timer))
(setq perl-doc--window-size-change-timer
(run-with-idle-timer 1 nil #'perl-doc--refresh))))
(defun perl-doc-browse-url ()
"Browse the URL at point, using either perldoc or `shr-browse-url'.
If the URL at point starts with the \"perldoc\" schema, then run
either perl-doc, or produce a man-page if the URL is of the type
\"topic(section)\". If it is a local fragment, just search for
it in the current buffer. For URLs with a schema, run
browse-url."
(interactive)
(let ((url (get-text-property (point) 'shr-url)))
(pcase url
((pred (string-match
(concat "^perldoc:///" ; our scheme
"\\(?:\\(?1:[^/]*\\)" ; 1: page, may be empty
"\\(?:#\\|/\\)" ; section separator
"\\(?2:.+\\)" ; "/" + 2: nonzero section
"\\|" ; or
"\\(?1:.+\\)\\)$"))) ; 1: just a page
;; link to be handled by perl-doc
(let ((page (match-string 1 url))
(section (match-string 2 url)))
(if (> (length page) 0)
(if (string-match "([1-9])$" page)
(man page)
(perl-doc--common page 'module section))
(when section
(perl-doc-goto-section section)))))
((pred (string-match "^#\\(.+\\)"))
;; ((string-match "^#\\(.+\\)" url)
;; local section created by pod2html
(if perl-doc-base
(perl-doc--common perl-doc-base 'module
(match-string-no-properties 1 url))
(perl-doc-goto-section (match-string-no-properties 1 url))))
(_
(shr-browse-url)))))
(defvar perl-doc-speedbar-nodes
(make-hash-table :test #'equal :size 60)
"Cache the nodes where documentation was found.")
(defun perl-doc-view-source ()
"Visit the file which contains the POD source of the current buffer."
(interactive)
(let ((topic perl-doc--current-topic)
(pod-source))
(with-temp-buffer
(if (= 0
(perl-doc--with-environment-variables
(("PERL5LIB" (perl-doc--collect-perl5lib)))
(call-process perl-doc-perldoc-program nil t t "-l" topic)))
(progn
(setq pod-source
(buffer-substring (point-min) (1- (point-max))))
(view-file pod-source))
;; perldoc did not provide a source file.
;; Let's try the speedbar-nodes!
(string-match (rx string-start
(group (? (: (* any) "::")))
(group (+ (not (in ":"))))
string-end)
topic)
(let* ((nodes (progn
(gethash (match-string 1 topic)
perl-doc-speedbar-nodes nil)))
(node (assoc topic nodes))
(file-names (when node
(cddr node))))
(pcase (length file-names)
(0 nil)
(1 (view-file (car file-names)))
(_
(setq pod-source
(completing-read "Select POD source: "
file-names
nil nil nil nil
(car file-names)))
(view-file pod-source))))))))
;;; Completion for documentation topics
(defun perl-doc--complete-collect-candidates (input)
"Collect the list of valid completions for INPUT.
Collects module names and Perl core documentation, but not
variables. This function is the backend for
`perl-doc-complete-module' which can be used in
`completing-read'."
(let ((namespace "")
(candidate input)
(depth 0)
(nodes (perl-doc--collect-directories
(perl-doc--root-directories) ""))
ancestor
ancestor-node)
(while (string-match (rx string-start
(group (* (not (in ":")))
"::")
(group (* any)))
candidate)
(setq ancestor (match-string 1 candidate)
candidate (match-string 2 candidate)
namespace (concat namespace ancestor)
ancestor-node (assoc namespace nodes)
nodes (perl-doc--collect-directories
(cddr ancestor-node) namespace)
depth (1+ depth)))
(mapcar #'car nodes)))
(defun perl-doc--complete-module (input _predicate flag)
"Complete INPUT to the next namespace separator.
Collects the list of candidates as a function of INPUT and then
calls the basic completion functions with this list."
(pcase flag
('nil
(try-completion input (perl-doc--complete-collect-candidates input)))
('t
(all-completions input (perl-doc--complete-collect-candidates input)))
('lambda
(test-completion input (perl-doc--complete-collect-candidates input)))
(`('boundaries ,suffix)
;; The default from `cperl-word-at-point' can be a
;; Deeply::Nested::Module, so we want to verify the whole path.
;; Let's return the basic default, as mentioned in the
;; documentation.
`(boundaries 0 . ,(length suffix)))
('metadata
;; Not used yet.
nil)))
;;;
;;; Speedbar support
;;;
(declare-function speedbar-make-specialized-keymap "speedbar" ())
(declare-function speedbar-add-expansion-list "speedbar" (new-list))
(declare-function speedbar-add-mode-functions-list "speedbar" (list))
(defvar speedbar-last-selected-file nil
"The last file which was selected in speedbar buffer.
We need to override that when switching to perl-doc display.")
(defvar perl-doc--browser-p nil
"Indicates whether `perl-doc-browser' has been started.
If t, then `perl-doc-speedbar-buttons' will not switch to another
mode if the current buffer is not in perl-doc-mode.")
(defun perl-doc-browser ()
"Use a `speedbar' frame to browse Perl documentation on your system.
This uses a speedbar major display mode."
(interactive)
(require 'speedbar)
(setq perl-doc--browser-p t)
(speedbar-change-initial-expansion-list "perl-doc")
(speedbar-frame-mode 1)
(speedbar-refresh)
)
(defvar perl-doc-speedbar-keymap nil
"A keymap for use in the perl-doc view of Speedbar.")
(defun perl-doc--speedbar-key-RET ()
"Handle <RET> in the perl-doc view.
Calls whatever is in the text-property \"speedbar-function\" at
point."
(interactive)
(let ((func (get-text-property (point) 'speedbar-function)))
(when func
(funcall func (speedbar-line-text)
(speedbar-line-token)
(perl-doc--speedbar-current-depth)))))
(defun perl-doc--speedbar-key-+ ()
"Expand the view for the current line, if possible.
If there's a \"+\" in the current line, call the appropriate
function. Otherwise, do nothing."
(interactive)
(save-excursion
(goto-char (line-beginning-position))
(when (search-forward-regexp "[<[{]\\+" nil t)
(let ((func (get-text-property (point) 'speedbar-function)))
(when func
(funcall func (speedbar-line-text)
(speedbar-line-token)
(perl-doc--speedbar-current-depth)))))))
(defun perl-doc-quit-browser ()
"Stop displaying the speedbar in \"perl-doc\" display.
If the browser was active, then this does not close the speedbar
frame, but puts the selection of the speedbar display back to
automatic selection. If the browser was not active, close the
speedbar frame."
(interactive)
(if perl-doc--browser-p
(progn
(setq perl-doc--browser-p nil)
(speedbar-refresh))
(dframe-close-frame)))
(defun perl-doc--speedbar-view-source ()
"View the POD source of the current line in speedbar."
(interactive)
(let ((perl-doc--current-topic (car (speedbar-line-token))))
(perl-doc-view-source)))
(defun perl-doc--install-speedbar-variables ()
"Do whatever is needed to fire up speedbar for POD files"
(or perl-doc-speedbar-keymap
(let ((map (speedbar-make-specialized-keymap)))
(define-key map "\C-m" #'perl-doc--speedbar-key-RET)
(define-key map "+" #'perl-doc--speedbar-key-+)
(define-key map "q" #'perl-doc-quit-browser)
(define-key map "v" #'perl-doc--speedbar-view-source)
(setq perl-doc-speedbar-keymap map))))
(with-eval-after-load 'speedbar
(perl-doc--install-speedbar-variables))
(defun perl-doc-speedbar-line-directory (&optional _depth)
"The function to serve as `speedbar-line-directory'"
(pcase (speedbar-line-token)
('nil
;; No token: Return the current buffer name in the attached frame
(buffer-name
(window-buffer (frame-selected-window
(speedbar-select-attached-frame)))))
((pred listp)
;; "our" token: Return the current buffer name in the attached frame
(buffer-name
(window-buffer (frame-selected-window
(speedbar-select-attached-frame)))))
((pred markerp)
;; a tag, return the buffer's file name
;; FIXME: That's broken because docs have no file name
(buffer-file-name (marker-buffer (speedbar-line-token))))
(_
(message "I don't know what to do with text '%s' and token '%s'"
(speedbar-line-text) (speedbar-line-token)))))
(defun perl-doc-speedbar-item-info ()
"The function to serve as `speedbar-item-info' in perl-doc view."
(pcase (speedbar-line-token)
((pred listp)
;; "our" token
(let* ((node (speedbar-line-token))
(namespace (car node))
(type (nth 1 node)))
(if (eq type 'directory)
(if (equal namespace "")
(speedbar-line-text)
namespace) ; Directory
(concat namespace " in " (nth 2 node)))))
((pred markerp)
;; An imenu tag (at least we hope so)
(concat "Heading: " (speedbar-line-text)))))
(defvar perl-doc-speedbar-menu-items
'(["Expand" speedbar-expand-line
(save-excursion (beginning-of-line)
(looking-at "[0-9]+: *.\\+. "))]
["Contract" speedbar-contract-line
(save-excursion (beginning-of-line)
(looking-at "[0-9]+: *.-. "))]
["Render POD" perl-doc-speedbar-view-pod
(equal (cadr (speedbar-line-token)) 'file)]
["View POD source" perl-doc--speedbar-view-source
(equal (cadr (speedbar-line-token)) 'file)]
)
"The menu for browsing Perl documentation.")
(defun perl-doc-activate-speedbar-display ()
"Use perl-doc to view your speedbar entries."
(interactive)
(speedbar-add-expansion-list '("perl-doc"
perl-doc-speedbar-menu-items
perl-doc-speedbar-keymap
perl-doc-speedbar-buttons))
(speedbar-add-mode-functions-list
'("perl-doc"
(speedbar-item-info . perl-doc-speedbar-item-info)
(speedbar-line-directory . perl-doc-speedbar-line-directory))))
(defun perl-doc--root-directories ()
"Return the list of directories to be used used by `perl-doc'.
The list is built from the customizable list
`perl-doc-extra-libs' and the array @INC as used by Perl itself.
Directories which don't exist are eliminated, as well as any
non-directory entry in @INC."
(let ((roots (append perl-doc-extra-libs
(with-temp-buffer
(call-process "perl"
nil t nil
"-E" "say for @INC")
(split-string (buffer-string) "\n" t)))))
(cl-remove-if-not #'file-exists-p roots)))
;; This function is no longer used. It turned out to be too slow when
;; used for filtering out files which don't have POD.
(defun perl-doc--pod-source-p (file)
"Return true if FILE contains POD.
Delegates the examination to `perl-doc-perldoc-program' which
should yield a nonzero exit code if FILE does not contain usable
POD."
(if (equal 0
(perl-doc--with-environment-variables
(("PERL5LIB" (perl-doc--collect-perl5lib)))
(call-process perl-doc-perldoc-program
nil nil nil "-l" file)))
t ; exit code = 0, POD found
nil)) ; exit code != 0, no POD
(defun perl-doc--nodes-by-name (n1 n2)
"Return t if node N1 is to be sorted before N2.
N1 and N2 are lists (namespace type file) where file is an
absolute path and type indicates either a file or a directory.
The namespace part has highest priority for sorting. The
namespace of directories has a trailing \"::\", so it is
automatically sorted after the files."
(let* ((name1 (car n1)) (type1 (nth 1 n1)) (file1 (nth 2 n1))
(name2 (car n2)) (type2 (nth 1 n2)) (file2 (nth 2 n2)))
(cond
;; The easy part: Different basenames
((string-lessp name1 name2) t)
((string-lessp name2 name1) nil)
;; Different types: Files before directories (should not be used ever)
((and (eq type1 'file) (eq type2 'directory)) t)
((and (eq type2 'file) (eq type1 'directory)) nil)
;; Different extensions: "pod" to be preferred
((string= (file-name-extension file1) "pod") t)
((string= (file-name-extension file2) "pod") nil)
(t ; Fallback: Just compare
(string-lessp file1 file2)))))
(defvar directory-files-no-dot-files-regexp nil
"Defined in files.el.")
(defun perl-doc--collect-directory (directory namespace)
"Collect files and directories from DIRECTORY under NAMESPACE.
NAMESPACE is the Perl namespace for DIRECTORY which will be
prepended to the namespace entries in the results. Files with