Improve diagnostics.pm’s link rendering.

The number of L<foo/bar> links in perldiag has grown over time, and
diagnostics.pm has never been updated to render them nicely, resulting
in output like this:

Lexing code attempted to stuff non-Latin-1 character into Latin-1 input at
 	lib/diagnostics.t line 36 (#3)
     (F) An extension is attempting to insert text into the current parse
     (using lex_stuff_pvn_flags|perlapi/lex_stuff_pvn_flags or similar), but
     tried to insert a character that couldn't be part of the current input.
     This is an inherent pitfall of the stuffing mechanism, and one of the
     reasons to avoid it.  Where it is necessary to stuff, stuffing only
     plain ASCII is recommended.

I’ve implemented some rudimentary L<> parsing, which should suffice
for perldiag. I think using a real POD processor would be overkill.

diff --git a/lib/diagnostics.pm b/lib/diagnostics.pm
index b485114..cd4e7b6 100644 (file)
--- a/lib/diagnostics.pm
+++ b/lib/diagnostics.pm
@@ -185,7 +185,7 @@ use 5.009001;
 use Carp;
 $Carp::Internal{__PACKAGE__.""}++;
 
-our $VERSION = '1.21';
+our $VERSION = '1.22';
 our $DEBUG;
 our $VERBOSE;
 our $PRETTY;
@@ -322,16 +322,37 @@ my %msg;
     my $for_item;
     while (<POD_DIAG>) {
 
+       sub _split_pod_link {
+           $_[0] =~ '(?:([^|]*)\|)?([^/]*)(?:/("?)(.*)\3)?';
+           ($1,$2,$4);
+       }
+
        unescape();
        if ($PRETTY) {
            sub noop   { return $_[0] }  # spensive for a noop
            sub bold   { my $str =$_[0];  $str =~ s/(.)/$1\b$1/g; return $str; } 
            sub italic { my $str = $_[0]; $str =~ s/(.)/_\b$1/g;  return $str; } 
            s/C<<< (.*?) >>>|C<< (.*?) >>|[BC]<(.*?)>/bold($+)/ges;
-           s/[LIF]<(.*?)>/italic($1)/ges;
+           s/[IF]<(.*?)>/italic($1)/ges;
+           s/L<(.*?)>/
+              my($text,$page,$sect) = _split_pod_link($1);
+              defined $text
+               ? $text
+               : defined $sect
+                  ? italic($sect) . ' in ' . italic($page)
+                  : italic($page)
+            /ges;
        } else {
            s/C<<< (.*?) >>>|C<< (.*?) >>|[BC]<(.*?)>/$+/gs;
-           s/[LIF]<(.*?)>/$1/gs;
+           s/[IF]<(.*?)>/$1/gs;
+           s/L<(.*?)>/
+              my($text,$page,$sect) = _split_pod_link($1);
+              defined $text
+               ? $text
+               : defined $sect
+                  ? qq '"$sect" in $page'
+                  : $page
+            /ges;
        } 
        unless (/^=/) {
            if (defined $header) { 

diff --git a/lib/diagnostics.t b/lib/diagnostics.t
index ee0c160..81896cd 100644 (file)
--- a/lib/diagnostics.t
+++ b/lib/diagnostics.t
@@ -5,7 +5,7 @@ BEGIN {
     @INC = 'lib';
 }
 
-use Test::More tests => 3;
+use Test::More tests => 5;
 
 BEGIN { use_ok('diagnostics') }
 
@@ -23,3 +23,16 @@ open STDERR, ">", \my $warning
     or die "Couldn't redirect STDERR to var: $!";
 warn('gmtime(nan) too large');
 like $warning, qr/\(W overflow\) You called/, '%0.f patterns';
+
+# L<foo/bar> links
+seek STDERR, 0,0;
+$warning = '';
+warn("accept() on closed socket spanner");
+like $warning, qr/"accept" in perlfunc/, 'L<foo/bar> links';
+
+# L<foo|bar/baz> links
+seek STDERR, 0,0;
+$warning = '';
+warn
+ 'Lexing code attempted to stuff non-Latin-1 character into Latin-1 input';
+like $warning, qr/using lex_stuff_pvn_flags or similar/, 'L<foo|bar/baz>';