X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pod%2Fpod2man.PL;h=7494c2659522a7cfbb288ba38af125f40cbb7a16;hb=04251ce85fbe7037c3a7ca309ab31a0207c941b3;hp=934d525cd8a442b1dd8b2abe604afb88197f1630;hpb=70601ba7efda70ba5ebb1437a5143452aa1d6802;p=p5sagit%2Fp5-mst-13.2.git diff --git a/pod/pod2man.PL b/pod/pod2man.PL index 934d525..7494c26 100644 --- a/pod/pod2man.PL +++ b/pod/pod2man.PL @@ -2,16 +2,19 @@ use Config; use File::Basename qw(&basename &dirname); +use Cwd; # List explicitly here the variables you want Configure to # generate. Metaconfig only looks for shell variables, so you # have to mention them as if they were shell variables, not # %Config entries. Thus you write # $startperl +# $man3ext # to ensure Configure will look for $Config{startperl}. # This forces PL files to create target in same directory as PL file. # This is so that make depend always knows where to find PL derivatives. +$origdir = cwd; chdir dirname($0); $file = basename($0, '.PL'); $file .= '.com' if $^O eq 'VMS'; @@ -27,6 +30,8 @@ print OUT <<"!GROK!THIS!"; $Config{startperl} eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}' if \$running_under_some_shell; + +\$DEF_PM_SECTION = '$Config{man3ext}' || '3'; !GROK!THIS! # In the following, perl variables are not expanded during extraction. @@ -46,6 +51,7 @@ B [ B<--date=>I ] [ B<--fixed=>I ] [ B<--official> ] +[ B<--lax> ] I =head1 DESCRIPTION @@ -105,6 +111,10 @@ best if you put your Perl man pages in a separate tree, like F. By default, section 1 will be used unless the file ends in F<.pm> in which case section 3 will be selected. +=item lax + +Don't complain when required sections aren't present. + =back =head1 Anatomy of a Proper Man Page @@ -302,13 +312,18 @@ Tom Christiansen such that Larry probably doesn't recognize it anymore. $/ = ""; $cutting = 1; +@Indices = (); # We try first to get the version number from a local binary, in case we're # running an installed version of Perl to produce documentation from an # uninstalled newer version's pod files. -if ($^O ne 'plan9') { - ($version,$patch) = - `\PATH=.:..:\$PATH; perl -v` =~ /version (\d\.\d{3})(?:_(\d{2}))?/; +if ($^O ne 'plan9' and $^O ne 'dos' and $^O ne 'os2' and $^O ne 'MSWin32') { + my $perl = (-x './perl' && -f './perl' ) ? + './perl' : + ((-x '../perl' && -f '../perl') ? + '../perl' : + ''); + ($version,$patch) = `$perl -e 'print $]'` =~ /^(\d\.\d{3})(\d{2})?/ if $perl; } # No luck; we'll just go with the running Perl's version ($version,$patch) = $] =~ /^(.{5})(\d{2})?/ unless $version; @@ -320,6 +335,7 @@ sub makedate { my $secs = shift; my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($secs); my $mname = (qw{Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec})[$mon]; + $year += 1900; return "$mday/$mname/$year"; } @@ -329,6 +345,7 @@ $DEF_SECTION = 1; $DEF_CENTER = "User Contributed Perl Documentation"; $STD_CENTER = "Perl Programmers Reference Guide"; $DEF_FIXED = 'CW'; +$DEF_LAX = 0; sub usage { warn "$0: @_\n" if @_; @@ -341,6 +358,7 @@ Options are: --date=string (default "$DEF_DATE") --fixed=font (default "$DEF_FIXED") --official (default NOT) + --lax (default NOT) EOF } @@ -351,6 +369,7 @@ $uok = GetOptions( qw( date=s fixed=s official + lax help)); $DEF_DATE = makedate((stat($ARGV[0]))[9] || time()); @@ -359,9 +378,11 @@ usage("Usage error!") unless $uok; usage() if $opt_help; usage("Need one and only one podpage argument") unless @ARGV == 1; -$section = $opt_section || ($ARGV[0] =~ /\.pm$/ ? 3 : $DEF_SECTION); +$section = $opt_section || ($ARGV[0] =~ /\.pm$/ + ? $DEF_PM_SECTION : $DEF_SECTION); $RP = $opt_release || $DEF_RELEASE; $center = $opt_center || ($opt_official ? $STD_CENTER : $DEF_CENTER); +$lax = $opt_lax || $DEF_LAX; $CFont = $opt_fixed || $DEF_FIXED; @@ -375,7 +396,6 @@ else { die "roff font should be 1 or 2 chars, not `$CFont_embed'"; } -$section = $opt_section || $DEF_SECTION; $date = $opt_date || $DEF_DATE; for (qw{NAME DESCRIPTION}) { @@ -392,7 +412,26 @@ 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 ^site(_perl)?/. + $name =~ s-^site(_perl)?/--; + # Lose ^arch/. (XXX should we use Config? Just for archname?) + $name =~ s~^(.*-$^O|$^O-.*)/~~o; + # Lose ^version/. + $name =~ s-^\d+\.\d+/--; +} + +# Translate Getopt/Long to Getopt::Long, etc. +$name =~ s(/)(::)g; if ($name ne 'something') { FCHECK: { @@ -404,15 +443,23 @@ if ($name ne 'something') { unless (/\s*-+\s+/) { $oops++; warn "$0: Improper man page - no dash in NAME header in paragraph $. of $ARGV[0]\n" - } else { - %namedesc = split /\s+-+\s+/; - } + } else { + my @n = split /\s+-+\s+/; + if (@n != 2) { + $oops++; + warn "$0: Improper man page - malformed NAME header in paragraph $. of $ARGV[0]\n" + } + else { + %namedesc = @n; + } + } last FCHECK; } next if /^=cut\b/; # DB_File and Net::Ping have =cut before NAME - die "$0: Invalid man page - 1st pod line is not NAME in $ARGV[0]\n"; + next if /^=pod\b/; # It is OK to have =pod before NAME + die "$0: Invalid man page - 1st pod line is not NAME in $ARGV[0]\n" unless $lax; } - die "$0: Invalid man page - no documentation in $ARGV[0]\n"; + die "$0: Invalid man page - no documentation in $ARGV[0]\n" unless $lax; } close F; } @@ -465,16 +512,36 @@ print <<"END"; .if (\\n(.H=4u)&(1m=20u) .ds -- \\(*W\\h'-12u'\\(*W\\h'-8u'-\\" diablo 12 pitch .ds L" "" .ds R" "" +''' \\*(M", \\*(S", \\*(N" and \\*(T" are the equivalent of +''' \\*(L" and \\*(R", except that they are used on ".xx" lines, +''' such as .IP and .SH, which do another additional levels of +''' double-quote interpretation +.ds M" """ +.ds S" """ +.ds N" """"" +.ds T" """"" .ds L' ' .ds R' ' +.ds M' ' +.ds S' ' +.ds N' ' +.ds T' ' 'br\\} .el\\{\\ .ds -- \\(em\\| .tr \\*(Tr .ds L" `` .ds R" '' +.ds M" `` +.ds S" '' +.ds N" `` +.ds T" '' .ds L' ` .ds R' ' +.ds M' ` +.ds S' ' +.ds N' ` +.ds T' ' .ds PI \\(*p 'br\\} END @@ -500,13 +567,14 @@ END print <<"END"; .TH $name $section "$RP" "$date" "$center" -.IX Title "$name $section" .UC END +push(@Indices, qq{.IX Title "$name $section"}); + while (($name, $desc) = each %namedesc) { for ($name, $desc) { s/^\s+//; s/\s+$//; } - print qq(.IX Name "$name - $desc"\n); + push(@Indices, qq(.IX Name "$name - $desc"\n)); } print <<'END'; @@ -610,6 +678,25 @@ $indent = 0; $begun = ""; +# Unrolling [^-=A-Z>]|[A-Z](?!<)|[-=](?![A-Z]<)[\x00-\xFF] gives: // MRE pp 165. +my $nonest = q{(?x) # Turn on /x mode. + (?: # Group + [^-=A-Z>]* # Anything that isn't a dash, equal sign or + # closing hook isn't special. Eat as much as + # we can. + (?: # Group. + (?: # Group. + [-=] # We want to recognize -> and =>. + (?![A-Z]<) # So, as long as it isn't followed by markup + [\x00-\xFF] # anything may follow - and = + | + [A-Z] # Capitals are fine too, + (?!<) # But not if they start markup. + ) # End of special sequences. + [^-=A-Z>]* # Followed by zero or more non-special chars. + )* # And we can repeat this as often as we can. + )}; # That's all folks. + while (<>) { if ($cutting) { next unless /^=/; @@ -672,10 +759,14 @@ while (<>) { # trofficate backslashes; must do it before what happens below s/\\/noremap('\\e')/ge; + # protect leading periods and quotes against *roff + # mistaking them for directives + s/^(?:[A-Z]<)?[.']/\\&$&/gm; + # first hide the escapes in case we need to # intuit something and get it wrong due to fmting - s/([A-Z]<[^<>]*>)/noremap($1)/ge; + 1 while s/([A-Z]<$nonest>)/noremap($1)/ge; # func() is a reference to a perl function s{ @@ -732,13 +823,16 @@ while (<>) { while ($maxnest-- && /[A-Z]]*)>/font($1) . $2 . font('R')/eg; + s/([BI])<($nonest)>/font($1) . $2 . font('R')/eg; # files and filelike refs in italics - s/F<([^<>]*)>/I<$1>/g; + s/F<($nonest)>/I<$1>/g; # no break -- usually we want C<> for this - s/S<([^<>]*)>/nobreak($1)/eg; + s/S<($nonest)>/nobreak($1)/eg; + + # LREF: a la HREF L + s:L<([^|>]+)\|[^>]+>:$1:g; # LREF: a manpage(3f) s:L<([a-zA-Z][^\s\/]+)(\([^\)]+\))?>:the I<$1>$2 manpage:g; @@ -789,7 +883,7 @@ while (<>) { s/Z<>/\\&/g; # comes last because not subject to reprocessing - s/C<([^<>]*)>/noremap("${CFont_embed}${1}\\fR")/eg; + s/C<($nonest)>/noremap("${CFont_embed}${1}\\fR")/eg; } if (s/^=//) { @@ -799,8 +893,19 @@ while (<>) { ($Cmd, $_) = split(' ', $_, 2); + $dotlevel = 1; + if ($Cmd eq 'head1') { + $dotlevel = 1; + } + elsif ($Cmd eq 'head2') { + $dotlevel = 1; + } + elsif ($Cmd eq 'item') { + $dotlevel = 2; + } + if (defined $_) { - &escapes; + &escapes($dotlevel); s/"/""/g; } @@ -813,11 +918,11 @@ while (<>) { s/\s+$//; delete $wanna_see{$_} if exists $wanna_see{$_}; print qq{.SH "$_"\n}; - print qq{.IX Header "$_"\n}; + push(@Indices, qq{.IX Header "$_"\n}); } elsif ($Cmd eq 'head2') { print qq{.Sh "$_"\n}; - print qq{.IX Subsection "$_"\n}; + push(@Indices, qq{.IX Subsection "$_"\n}); } elsif ($Cmd eq 'over') { push(@indent,$indent); @@ -836,7 +941,7 @@ while (<>) { s/[^"]""([^"]+?)""[^"]/'$1'/g; # here do something about the $" in perlvar? print STDOUT qq{.Ip "$_" $indent\n}; - print qq{.IX Item "$_"\n}; + push(@Indices, qq{.IX Item "$_"\n}); } elsif ($Cmd eq 'pod') { # this is just a comment @@ -849,7 +954,7 @@ while (<>) { if ($needspace) { &makespace; } - &escapes; + &escapes(0); clear_noremap(1); print $_, "\n"; $needspace = 1; @@ -861,7 +966,7 @@ print <<"END"; .rn }` '' END -if (%wanna_see) { +if (%wanna_see && !$lax) { @missing = keys %wanna_see; warn "$0: $Filename is missing required section" . (@missing > 1 && "s") @@ -869,6 +974,8 @@ if (%wanna_see) { $oops++; } +foreach (@Indices) { print "$_\n"; } + exit; #exit ($oops != 0); @@ -881,6 +988,7 @@ sub nobreak { } sub escapes { + my $indot = shift; s/X<(.*?)>/mkindex($1)/ge; @@ -893,9 +1001,19 @@ sub escapes { s/([^"])--"/$1\\*(--"/g; # fix up quotes; this is somewhat tricky + my $dotmacroL = 'L'; + my $dotmacroR = 'R'; + if ( $indot == 1 ) { + $dotmacroL = 'M'; + $dotmacroR = 'S'; + } + elsif ( $indot >= 2 ) { + $dotmacroL = 'N'; + $dotmacroR = 'T'; + } if (!/""/) { - s/(^|\s)(['"])/noremap("$1\\*(L$2")/ge; - s/(['"])($|[\-\s,;\\!?.])/noremap("\\*(R$1$2")/ge; + s/(^|\s)(['"])/noremap("$1\\*($dotmacroL$2")/ge; + s/(['"])($|[\-\s,;\\!?.])/noremap("\\*($dotmacroR$1$2")/ge; } #s/(?!")(?:.)--(?!")(?:.)/\\*(--/g; @@ -945,13 +1063,7 @@ sub escapes { # make troff just be normal, but make small nroff get quoted # decided to just put the quotes in the text; sigh; sub ccvt { - local($_,$prev) = @_; - if ( /^\W+$/ && !/^\$./ ) { - ($prev && "\n") . noremap(qq{.CQ $_ \n\\&}); - # what about $" ? - } else { - noremap(qq{${CFont_embed}$_\\fR}); - } + local($_,$prev) = @_; noremap(qq{.CQ "$_" \n\\&}); } @@ -967,11 +1079,7 @@ sub makespace { sub mkindex { my ($entry) = @_; my @entries = split m:\s*/\s*:, $entry; - print ".IX Xref "; - for $entry (@entries) { - print qq("$entry" ); - } - print "\n"; + push @Indices, ".IX Xref " . join ' ', map {qq("$_")} @entries; return ''; } @@ -1026,6 +1134,7 @@ sub clear_noremap { sub internal_lrefs { local($_) = shift; + local $trailing_and = s/and\s+$// ? "and " : ""; s{L]+)>}{$1}g; my(@items) = split( /(?:,?\s+(?:and\s+)?)/ ); @@ -1038,7 +1147,11 @@ sub internal_lrefs { } $retstr .= " entr" . ( @items > 1 ? "ies" : "y" ) - . " elsewhere in this document "; # terminal space to avoid words running together (pattern used strips terminal spaces) + . " elsewhere in this document"; + # terminal space to avoid words running together (pattern used + # strips terminal spaces) + $retstr .= " " if length $trailing_and; + $retstr .= $trailing_and; return $retstr; @@ -1121,3 +1234,4 @@ BEGIN { close OUT or die "Can't close $file: $!"; chmod 0755, $file or die "Can't reset permissions for $file: $!\n"; exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':'; +chdir $origdir;