branch: externals/perl-doc
commit cd2c4c406b5d5e1d5311eb61b6fb68913c572461
Author: Harald Jörg <h...@posteo.de>
Commit: Harald Jörg <h...@posteo.de>
Refactoring: Use rx notation instead of homegrown compact regexes
* NEWS: New file, loosely following Emacs conventions.
* README.md: Add the commands available in this package.
* perl-doc.el: The home-grown compact regex construction set has
been replaced by rx notation. This is less compact, but easier to
maintain (I hope).
(perl-doc-mode-map): New key "v" to invoke `perl-doc-view-source'.
(perl-doc-goto-section): Bugfix: Sections with regexp
metacharacters in their titles are now found.
(perl-doc-with-L-grammar): New macro to run elisp code with a
lexical definition for the L<...> element of POD syntax in rx
notation.
(perl-doc--process-links): Eliminate the definition of string
regexps in favor of rx notation (which is factored out to the
macro `perl-doc-with-L-grammar').
(perl-doc-file): New command to run `perl-doc' with completion for
a file name.
(perl-doc-view-source): New command to view the POD source for the
documentation in the current buffer.
* test/perl-doc-tests.el: Some tests for perl-doc.el, in
particular for the regular expressions used.
* .elpaignore: New file, exclude tests from the package
---
.elpaignore | 3 +
ChangeLog | 30 ++++
NEWS | 38 +++++
README.md | 10 +-
perl-doc.el | 370 ++++++++++++++++++++++++++++---------------------
test/perl-doc-tests.el | 83 +++++++++++
6 files changed, 375 insertions(+), 159 deletions(-)
diff --git a/.elpaignore b/.elpaignore
new file mode 100644
index 0000000000..99967d7b67
--- /dev/null
+++ b/.elpaignore
@@ -0,0 +1,3 @@
+test
+ChangeLog
+.gitignore
\ No newline at end of file
diff --git a/ChangeLog b/ChangeLog
new file mode 100644
index 0000000000..e2c91c4fe4
--- /dev/null
+++ b/ChangeLog
@@ -0,0 +1,30 @@
+2022-09-27 Harald Jörg <h...@posteo.de>
+
+ * NEWS: New file, loosely following Emacs conventions.
+
+ * README.md: Add the commands available in this package.
+
+2022-09-26 Harald Jörg <h...@posteo.de>
+
+ * perl-doc.el: The home-grown compact regex construction set has
+ been replaced by rx notation. This is less compact, but easier to
+ maintain (I hope).
+ (perl-doc-mode-map): New key "v" to invoke `perl-doc-view-source'.
+ (perl-doc-goto-section): Bugfix: Sections with regexp
+ metacharacters in their titles are now found.
+ (perl-doc-with-L-grammar): New macro to run elisp code with a
+ lexical definition for the L<...> element of POD syntax in rx
+ notation.
+ (perl-doc--process-links): Eliminate the definition of string
+ regexps in favor of rx notation (which is factored out to the
+ macro `perl-doc-with-L-grammar').
+ (perl-doc-file): New command to run `perl-doc' with completion for
+ a file name.
+ (perl-doc-view-source): New command to view the POD source for the
+ documentation in the current buffer.
+
+ * test/perl-doc-tests.el: Some tests for perl-doc.el, in
+ particular for the regular expressions used.
+
+ * .elpaignore: New file, exclude tests from the package
+
diff --git a/NEWS b/NEWS
new file mode 100644
index 0000000000..70ec24917a
--- /dev/null
+++ b/NEWS
@@ -0,0 +1,38 @@
+perl-doc.el for GNU Emacs NEWS -- history of user-visible changes.
+
+Copyright (C) 2022 Free Software Foundation, Inc.
+See the end of the file for license conditions.
+
+* Changes in perl-doc.el 0.3
+
+** New command `perl-doc-file'
+
+Like `perl-doc', but prompt for a file name with completion.
+
+** New command `perl-doc-view-source'
+
+View the POD source for the Perl documentation shown in the current
+buffer. The command is bound to "v" in `perl-doc-mode'.
+
+
+
+----------------------------------------------------------------------
+perl-doc.el 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.
+
+perl-doc.el 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/>.
+
+
+Local variables:
+coding: utf-8
+mode: outline
+paragraph-separate: "[ ]*$"
+end:
diff --git a/README.md b/README.md
index 5ad8051306..77dc75b01c 100644
--- a/README.md
+++ b/README.md
@@ -1,13 +1,20 @@
# emacs-perl-doc
Read nicely rendered Perl documentation in Emacs
-This file contains a command to read Perl documentation in Emacs.
+This file contains commands 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.
+ * `perl-doc`: Read perl documentation, prompt for topic. You can
+ give perldoc sections (e.g. "perldebug"), names of modules
+ installed on your system, but also functions and variable names.
+ * `perl-doc-file`: Like `perl-doc`, but prompts for a file name.
+ * `perl-doc-view-source`: View the POD source for the documentation
+ in the current buffer.
+
## Motivation
Perl documentation is written in a markup format called POD ([Plain
@@ -37,7 +44,6 @@ from [GNU ELPA](https://elpa.gnu.org/packages/)
and works with Emacs 27 and newer. Indexing with imenu can
be used with Emacs 28 and newer.
-
The file comes with two customization items
`perl-doc-pod2html-program` and `perl-doc-perldoc-program` which point
to the pod2html and perldoc programs, respectively. On many platforms
diff --git a/perl-doc.el b/perl-doc.el
index a3db8ffbcc..85b660d0c0 100644
--- a/perl-doc.el
+++ b/perl-doc.el
@@ -19,7 +19,7 @@
;; 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
+;; 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
@@ -59,12 +59,6 @@
;;
;; * Makes use of Emacs faces: variable-pitch font for text,
;; fixed-pitch for code, italics for, well, italics
-;;
-;; TODO list
-;;
-;; * The regex mechanism in `perl-doc--process-links` is a hack. The
-;; author wrote this before he learned about rx and always meant to
-;; rewrite it in rx notation, but well, tuits.
;;; Code:
@@ -78,7 +72,7 @@
;; 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)
+;; * cperl-short-docs : Tell functions from modules (for use with -f)
(require 'cperl-mode)
(require 'shr)
@@ -99,16 +93,17 @@
This is only relevant for developers, not for users.")
;; Make elint-current-buffer happy
-(defvar button-buffer-map) ; in button.el
+(defvar button-buffer-map) ; in button.el
(defvar special-mode-map) ; in simple.el
(defvar perl-doc-mode-map
(let ((map (make-sparse-keymap)))
- (set-keymap-parent map
- (make-composed-keymap button-buffer-map special-mode-map))
+ (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.")
@@ -130,7 +125,7 @@ The following key bindings are currently in effect in the
buffer:
#'perl-doc--prev-index-position)
(setq-local imenu-extract-index-name-function
#'perl-doc--extract-index-name)))
-
+
(defun perl-doc-goto-section (section)
"Find SECTION in the current buffer.
There is no precise indicator for SECTION in shr-generated
@@ -140,20 +135,104 @@ 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
+ ;; "#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 "-" "." section))
+ (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
+ (not-delimiter (or (escaped "|") (escaped "/") (not (any "|/"))))
+ (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)
+ (+? not-delimiter)
+ 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
+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
@@ -161,6 +240,9 @@ which seem to work, at least, with some formatters."
;; 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
@@ -171,134 +253,87 @@ which seem to work, at least, with some formatters."
;; (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.
- ;; By the way: Are you tired of backslasheritis? Well, I am.
- (let* (({ "\\(?:")
- ({1 "\\(?1:")
- ({2 "\\(?2:")
- ({3 "\\(?3:")
- (} "\\)")
- (or "\\|")
- (bs "\\\\")
- (q "\"")
- (ws (concat { "[[:blank:]]" or "\n" } ))
- (quoted (concat { q { bs bs or bs q or "[^\"]" } "*" q } ))
- (plain (concat { "[^|<>]" } ))
- (extended (concat { "[^|/]" } ))
- (unrestricted "[^/].*?")
- (nomarkup (concat { "[^A-Z]<" } ))
- (no-del (concat { bs "|" or bs "/" or "[^|/]" } ))
- (m2 (concat { "[A-Z]<<" ws no-del "+?" ws ">>" } ))
- (m0 (concat { "[A-Z]<" { "[^<>|/]" or nomarkup } "+?>" } ))
- (markup (concat { m2 or "[A-Z]<"
- { m2 or m0 or nomarkup or "[^|/>]" }
- "+?>" } ))
- (component (concat { plain or markup or nomarkup } ))
- (name (concat {2 { "[^ \"\t|/<>]" or markup } "*" } ))
- (url (concat {2 "\\w+:/[^ |<>]+" } ))
- ;; 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-sect (concat {2 { component "+ " component "+" }
- or quoted
- } )))
- (while (re-search-forward (rx "L<" (optional (group-n 1 (1+ "<") " ")))
- nil t)
- (let* ((terminator-length (length (match-string 1)))
- (allow-angle (> terminator-length 0)); L<< ... >>
- (text (if allow-angle
- (concat {1 extended "+?" } )
- (concat {1 component "+?" } )))
- (section (if allow-angle
- (concat {3 quoted or unrestricted } )
- (concat {3 quoted or component "+" } )))
- (terminator (if allow-angle
- (concat " " (make-string terminator-length ?>))
- ">"))
- (link-re (concat "\\="
- { { text "|" ws "?" } "?"
- {
- url or
- { name { "/" section } "?" } or
- old-sect
- }
- }))
- (re (concat link-re terminator))
- (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 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 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))))))
+ (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-word nil)
@@ -331,7 +366,7 @@ Does better formatting than man pages, including
hyperlinks."
(pop-to-buffer perldoc-buffer)
(with-temp-buffer
;; for diagnostics comment out the previous line, and
- ;; uncomment the next. This makes the intermediate buffer
+ ;; uncomment the next. This makes the intermediate buffer
;; permanent for inspection in the pod- and html-phase.
;; (with-current-buffer (get-buffer-create (concat "**pod-" word "**"))
;; Fetch plain POD into a temporary buffer
@@ -371,7 +406,16 @@ Does better formatting than man pages, including
hyperlinks."
perl-doc-current-word word
perl-doc-current-section section)))
-;; Make elint-current-buffer happy
+;;;###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")
+ (perl-doc file)
+ )
+
+ ;; Make elint-current-buffer happy
(defvar text-scale-mode-amount) ; in face-remap.el, which we
require
(defun perl-doc--refresh (&optional _ignore-auto _noconfirm)
@@ -397,7 +441,7 @@ Does better formatting than man pages, including
hyperlinks."
(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))))
+ (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'.
@@ -411,13 +455,13 @@ browse-url."
(when url
(cond
((string-match (concat "^perldoc:///" ; our scheme
- "\\(?:\\(?1:[^/]*\\)" ; 1: page, may be empty
- "\\(?:#\\|/\\)" ; section separator
- "\\(?2:.+\\)" ; "/" + 2: nonzero section
- "\\|" ; or
- "\\(?1:.+\\)\\)$") ; 1: just a page
- url)
- ;; link to be handled by perl-doc
+ "\\(?:\\(?1:[^/]*\\)" ; 1: page, may be empty
+ "\\(?:#\\|/\\)" ; section separator
+ "\\(?2:.+\\)" ; "/" + 2: nonzero section
+ "\\|" ; or
+ "\\(?1:.+\\)\\)$") ; 1: just a page
+ url)
+ ;; link to be handled by perl-doc
(let ((page (match-string 1 url))
(section (match-string 2 url)))
(if (> (length page) 0)
@@ -430,11 +474,23 @@ browse-url."
;; local section created by pod2html
(if perl-doc-base
(perl-doc perl-doc-base
- (match-string-no-properties 1 url))
- (perl-doc-goto-section (match-string-no-properties 1 url))))
+ (match-string-no-properties 1 url))
+ (perl-doc-goto-section (match-string-no-properties 1 url))))
(t
(shr-browse-url))))))
+(defun perl-doc-view-source ()
+ "Visit the file which contains the POD source of the current buffer."
+ (interactive)
+ (let ((word perl-doc-current-word)
+ (pod-source))
+ (with-temp-buffer
+ (call-process perl-doc-perldoc-program nil t t "-l" word)
+ (setq pod-source (buffer-substring (point-min) (1- (point-max))))
+ (view-file pod-source)
+ )
+ ))
+
;;; perl-doc-mode Index functions
(defvar perl-doc--heading-face nil
@@ -461,7 +517,7 @@ browse-url."
(when heading-end-match
(setq to (prop-match-beginning heading-end-match))
(buffer-substring-no-properties from to))
- )))
+ )))
(defun perl-doc--prev-index-position ()
"Find the previous index position.
@@ -511,6 +567,6 @@ We don't care which heading, therefore the expected value
(first
(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)))))
-
+
(provide 'perl-doc)
;;; perl-doc.el ends here
diff --git a/test/perl-doc-tests.el b/test/perl-doc-tests.el
new file mode 100644
index 0000000000..46f4f6313e
--- /dev/null
+++ b/test/perl-doc-tests.el
@@ -0,0 +1,83 @@
+;;; perl-doc-tests.el --- Test for perl-doc -*- lexical-binding: t -*-
+
+;; Copyright (C) 2022 Free Software Foundation, Inc.
+
+;; Author: Harald Jörg <h...@posteo.de>
+;; Maintainer: Harald Jörg
+;; Keywords: languages
+;; URL: https://github.com/HaraldJoerg/emacs-perl-doc
+
+;; 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 is a collection of tests for perl-doc.el
+
+;;; Code:
+
+(require 'perl-doc)
+(require 'ert)
+(require 'ert-x)
+
+(ert-deftest perl-doc-test-l-grammar ()
+ "Tests the individual grammar elements for L<...> POD stuff."
+ (perl-doc-with-L-grammar
+ (let ((string "\\"))
+ (string-match (rx backslash) string)
+ (should (string= (match-string 0 string) "\\")))
+ ;; 'quoted' must recognize escaped quotes
+ (let ((string "text \\ \"quoted \\\"part\\\"\\\\\" more text"))
+ (string-match (rx quoted) string)
+ (should (string= (match-string 0 string) "\"quoted \\\"part\\\"\\\\\"")))
+ (let ((markup-testcases
+ '(("B<bold> xxx" . "B<bold>")
+ ("I<nestB<ed>>>" . "I<nestB<ed>>")
+ ("C<< extended with > >>>" . "C<< extended with > >>"))))
+ (dolist (markup-testcase markup-testcases)
+ (let ((string (car markup-testcase))
+ (match (cdr markup-testcase)))
+ (string-match (rx markup) string)
+ (should (string= (match-string 0 string) match)))))))
+
+(ert-deftest perl-doc-test-process-links ()
+ "Test various ways to write POD \"L<...>\" elements.
+The L markup is the weirdest of all POD elements, here are some
+ examples from real Perl and CPAN modules. Most examples are
+ from perlfunc.pod, with words abbreviated to avoid over-long
+ lines."
+ (let ((conversions
+ '(("L<perlrun>" . ; plain link to perldoc
+ "L<perlrun|perldoc:///perlrun>")
+ ("L<C<time>|/time>" . ; markup + label + local section
+ "L<C<time>|/time>")
+ ("L<http://www.cpan.org/>" . ; WWW link in perlintro.pod
+ "L<http://www.cpan.org/>")
+ ("L<CPAN|http://www.cpan.org/>" . ; WWW link with label
+ "L<CPAN|http://www.cpan.org/>")
+ ("L<C<trE<sol>E<sol>E<sol>>|/trE<sol>E<sol>E<sol>>" .
+ "L<C<trE<sol>E<sol>E<sol>>|/trE<sol>E<sol>E<sol>>")
+ ("L<C<\"switch\"> f|f/The 'switch' f>" . ; spaces
+ "L<C<\"switch\"> f|perldoc:///f/The-'switch'-f>")
+ ("L<fopen(3)>" . "L<fopen(3)|perldoc:///fopen(3)>")
+ ("L<pi/Files and I/O>" . ; in perlfunc.pod
+ "L<Files and I/O in pi|perldoc:///pi/Files-and-I/O>")
+ ("L<< Perl-R|https://g.com/orgs/Perl/teams/perl-r >>" .
+ "L<< Perl-R|https://g.com/orgs/Perl/teams/perl-r >>")))
+ (perl-doc--debug t))
+ (dolist (test conversions)
+ (with-temp-buffer
+ (insert (car test))
+ (perl-doc--process-links)
+ (should (string= (buffer-string) (cdr test)))))))
+
