From: Roderick Schertler <roderick@argon.org>
Date: Wed, 2 Apr 1997 04:41:55 +0000 (-0500)
Subject: Improve heuristics for pod2man titles
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=bbc6b0c70abf7d94d76d42e14766d95f09208cc9;p=p5sagit%2Fp5-mst-13.2.git

Improve heuristics for pod2man titles

Subject: Re: Strange headers from perldoc

On Mon, 31 Mar 1997 16:02:59 +0100, "M.J.T. Guy" <mjtg@cus.cam.ac.uk> said:
>
> When I go  "perldoc CPAN" (in perl5.003_94 as it happens), the header
> lines come out as
>
> ::home::mjtg::pUser Contr::home::mjtg::perl5.003_94::lib::CPAN(3)

Here's a fix for that.  It's just more heuristics, so it isn't perfect.

In a related vein, this still leaves

    Getopt::Long(3pUser Contributed Perl DocumentatiGetopt::Long(3pm)

in the page header on my system.  "User Contributed Perl Documentation"
is just too long.  Would anybody mind replacing this with something
shorter?  Say

    Getopt::Long(3pm)         User Perl Docs        Getopt::Long(3pm)

or

    Getopt::Long(3pm)      Wankel Rotary Engine     Getopt::Long(3pm)

or even

    Getopt::Long(3pm)                               Getopt::Long(3pm)

I'm partial the last of these, myself, but I'd be happy with anything
less than about 20 characters.  Patch happily supplied if nobody
objects.

p5p-msgid: pzn2ri9gto.fsf@eeyore.ibcinc.com
---

diff --git a/pod/pod2man.PL b/pod/pod2man.PL
index bd4dd41..cd14ce2 100644
--- a/pod/pod2man.PL
+++ b/pod/pod2man.PL
@@ -404,7 +404,22 @@ if ($section =~ /^1/) {
     $name = uc File::Basename::basename($name);
 }
 $name =~ s/\.(pod|p[lm])$//i;
-$name =~ s(/)(::)g; # translate Getopt/Long to Getopt::Long, etc.
+
+# Lose everything up to the first of
+#     */lib/*perl*	standard or site_perl module
+#     */*perl*/lib	from -D prefix=/opt/perl
+#     */*perl*/		random module hierarchy
+# which works.
+$name =~ s-//+-/-g;
+if ($name =~ s-^.*?/lib/[^/]*perl[^/]*/--i
+	or $name =~ s-^.*?/[^/]*perl[^/]*/lib/--i
+	or $name =~ s-^.*?/[^/]*perl[^/]*/--i) {
+    # Lose ^arch/version/.
+    $name =~ s-^[^/]+/\d+\.\d+/--;
+}
+
+# Translate Getopt/Long to Getopt::Long, etc.
+$name =~ s(/)(::)g;
 
 if ($name ne 'something') {
     FCHECK: {