podwrapper.pl.in

   1 #!/usr/bin/env perl
   2 # podwrapper.pl
   3 # @configure_input@
   4 # Copyright Red Hat
   5 #
   6 # Redistribution and use in source and binary forms, with or without
   7 # modification, are permitted provided that the following conditions are
   8 # met:
   9 #
  10 # * Redistributions of source code must retain the above copyright
  11 # notice, this list of conditions and the following disclaimer.
  12 #
  13 # * Redistributions in binary form must reproduce the above copyright
  14 # notice, this list of conditions and the following disclaimer in the
  15 # documentation and/or other materials provided with the distribution.
  16 #
  17 # * Neither the name of Red Hat nor the names of its contributors may be
  18 # used to endorse or promote products derived from this software without
  19 # specific prior written permission.
  20 #
  21 # THIS SOFTWARE IS PROVIDED BY RED HAT AND CONTRIBUTORS ''AS IS'' AND
  22 # ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
  23 # THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
  24 # PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL RED HAT OR
  25 # CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
  26 # SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
  27 # LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF
  28 # USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
  29 # ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
  30 # OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT
  31 # OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
  32 # SUCH DAMAGE.
  33
  34 use warnings;
  35 use strict;
  36
  37 #use Carp;
  38 #$SIG{ __DIE__ } = sub { Carp::confess( @_ ) };
  39
  40 use Pod::Usage;
  41 use Getopt::Long;
  42 use Pod::Man;
  43 use Pod::Simple;
  44 use Pod::Simple::Text;
  45 use Pod::Simple::XHTML;
  46 use File::Basename;
  47
  48 # https://www.redhat.com/archives/libguestfs/2013-May/thread.html#00088
  49 eval { $Text::Wrap::huge = "overflow" };
  50
  51 # All man page names must match this function.
  52 sub validate_name_field
  53 {
  54     local $_ = shift;
  55     $_ =~ m/^libnbd/ || $_ =~ m/^nbd/;
  56 }
  57
  58 # The license for man pages in this package - see LICENSE below.
  59 my $package_license = "lgplv2plus";
  60
  61 =head1 NAME
  62
  63 podwrapper.pl - generate documentation from POD input files
  64
  65 =head1 SYNOPSIS
  66
  67  EXTRA_DIST = foo.pod
  68
  69  if HAVE_POD
  70
  71  man_MANS = foo.1
  72  CLEANFILES += $(man_MANS)
  73
  74  foo.1: foo.pod
  75          $(PODWRAPPER) --section 1 --man $@ \
  76            --html $(top_builddir)/html/$@.html \
  77            $<
  78
  79  endif HAVE_POD
  80
  81 =head1 DESCRIPTION
  82
  83 podwrapper.pl is a Perl script that generates various output formats
  84 from POD input files that this project uses for most documentation.
  85
  86 You must specify one input file, and one or more output formats.  The
  87 output options are I<--man>, I<--html> and I<--text> (see below).
  88
  89 In C<Makefile.am> files, use a variation of the boilerplate shown in
  90 the L</SYNOPSIS> section above.
  91
  92 For information about the POD format, see L<perlpod(1)>.
  93
  94 =head1 OPTIONS
  95
  96 =over 4
  97
  98 =cut
  99
 100 my $help;
 101
 102 =item B<--help>
 103
 104 Display brief help.
 105
 106 =cut
 107
 108 my $allow_long_lines;
 109
 110 =item B<--allow-long-lines>
 111
 112 Allow lines longer than 76 characters in the input.  Use this
 113 if the man page is not written by hand.
 114
 115 =cut
 116
 117 my $html;
 118
 119 =item B<--html> output.html
 120
 121 Write a web page to F<output.html>.  If this option is not
 122 given, then no web page output is produced.
 123
 124 =cut
 125
 126 my @inserts;
 127
 128 =item B<--insert> filename:__PATTERN__
 129
 130 In the input file, replace the literal text C<__PATTERN__> with the
 131 replacement file F<filename>.  You can give this option multiple
 132 times.
 133
 134 The contents of F<filename> are treated as POD.
 135 Compare and contrast with I<--verbatim>.
 136
 137 Although it is conventional to use C<__...__> (double underscores) for
 138 patterns, in fact you can use any string as the pattern.
 139
 140 =cut
 141
 142 my $man;
 143
 144 =item B<--man> output.n
 145
 146 Write a man page to F<output.n> (C<n> is the manual section number).
 147 If this option is not given, then no man page output is produced.
 148
 149 =cut
 150
 151 my $name;
 152
 153 =item B<--name> NAME
 154
 155 Set the name of the man page.  If not set, defaults to the basename
 156 of the input file.
 157
 158 =cut
 159
 160 my $section;
 161
 162 =item B<--section> N
 163
 164 Set the section of the man page (a number such as C<1> for
 165 command line utilities or C<3> for C API documentation).  If
 166 not set, defaults to C<1>.
 167
 168 =cut
 169
 170 my $text;
 171
 172 =item B<--text> output.txt
 173
 174 Write a text file to F<output.txt>.  If this option is not
 175 given, then no text output is produced.
 176
 177 =cut
 178
 179 my @verbatims;
 180
 181 =item B<--verbatim> filename:__PATTERN__
 182
 183 In the input file, replace the literal text C<__PATTERN__> with the
 184 replacement file F<filename>.  You can give this option multiple
 185 times.
 186
 187 The contents of F<filename> are inserted as verbatim text, and
 188 are I<not> interpreted as POD.
 189 Compare and contrast with I<--insert>.
 190
 191 Although it is conventional to use C<__...__> (double underscores) for
 192 patterns, in fact you can use any string as the pattern.
 193
 194 =cut
 195
 196 # Clean up the program name.
 197 my $progname = $0;
 198 $progname =~ s{.*/}{};
 199
 200 # Parse options.
 201 GetOptions ("help|?" => \$help,
 202             "allow-long-lines" => \$allow_long_lines,
 203             "html=s" => \$html,
 204             "insert=s" => \@inserts,
 205             "man=s" => \$man,
 206             "name=s" => \$name,
 207             "section=s" => \$section,
 208             "text=s" => \$text,
 209             "verbatim=s" => \@verbatims,
 210     ) or pod2usage (2);
 211 pod2usage (1) if $help;
 212
 213 die "$progname: missing argument: podwrapper input.pod\n" unless @ARGV == 1;
 214 my $input = $ARGV[0];
 215
 216 # There should be at least one output.
 217 die "$progname: $input: no output format specified.  Use --man and/or --html and/or --text.\n"
 218     unless defined $man || defined $html || defined $text;
 219
 220 # Default for $name and $section.
 221 $name = basename ($input, ".pod") unless defined $name;
 222 $section = 1 unless defined $section;
 223
 224 # Note that these @...@ are substituted by ./configure.
 225 my $abs_top_srcdir = "@abs_top_srcdir@";
 226 my $abs_top_builddir = "@abs_top_builddir@";
 227 my $package_name = "@PACKAGE_NAME@";
 228 my $package_version = "@PACKAGE_VERSION@";
 229
 230 die "$progname: ./configure substitutions were not performed"
 231     unless $abs_top_srcdir && $abs_top_builddir &&
 232     $package_name && $package_version;
 233
 234 # Create a stable date (thanks Hilko Bengen).
 235 my $date;
 236 my $filename = "$abs_top_srcdir/.git";
 237 if (!$date && -d $filename) {
 238     local $ENV{GIT_DIR} = $filename;
 239     $date = `git show -O/dev/null -s --format=format:%cs`;
 240 }
 241 if (!$date) {
 242     my ($day, $month, $year) = (gmtime($ENV{SOURCE_DATE_EPOCH} || time))[3,4,5];
 243     $date = sprintf ("%04d-%02d-%02d", $year+1900, $month+1, $day);
 244 }
 245
 246 # Create a release string.
 247 my $release = "$package_name-$package_version";
 248
 249 #print "input=$input\n";
 250 #print "name=$name\n";
 251 #print "section=$section\n";
 252 #print "date=$date\n";
 253
 254 # Read the input.
 255 my $content = read_whole_file ($input);
 256
 257 # Perform @inserts.
 258 foreach (@inserts) {
 259     my @a = split /:/, $_, 2;
 260     die "$progname: $input: no colon in parameter of --insert\n" unless @a >= 2;
 261     my $replacement = read_whole_file ($a[0]);
 262     my $oldcontent = $content;
 263     $content =~ s/$a[1]/$replacement/ge;
 264     die "$progname: $input: could not find pattern '$a[1]' in input file\n"
 265         if $content eq $oldcontent;
 266 }
 267
 268 # Turn external links to this man page into simple cross-section links.
 269 $content =~ s,\QL<$name($section)/\E,L</,g;
 270
 271 # Perform @verbatims.
 272 foreach (@verbatims) {
 273     my @a = split /:/, $_, 2;
 274     die "$progname: $input: no colon in parameter of --verbatim\n" unless @a >= 2;
 275     my $replacement = read_verbatim_file ($a[0]);
 276     my $oldcontent = $content;
 277     $content =~ s/$a[1]/$replacement/ge;
 278     die "$progname: $input: could not find pattern '$a[1]' in input file\n"
 279         if $content eq $oldcontent;
 280 }
 281
 282 # Check the content is valid UTF8.
 283 die "$progname: $input: is not valid utf8" unless utf8::is_utf8 ($content);
 284
 285 # There should be no =encoding line present in the content.
 286 die "$progname: $input: =encoding must not be present in input\n"
 287     if $content =~ /^=encoding/m;
 288
 289 # Don't permit trailing whitespace.
 290 die "$progname: $input: trailing whitespace in input\n"
 291     if $content =~ /[ \t]$/m;
 292
 293 # We may add an encoding line, but this breaks RHEL 6-era Pod::Simple
 294 # with the error "Cannot decode string with wide characters".
 295 $content =~ s/^=(.*)/\n=encoding utf8\n\n=$1/m
 296     if $] >= 5.011;             # Perl >= 5.11
 297
 298 # Verify sections present / not present.
 299 die "$progname: $input: missing NAME section\n"
 300     if $content !~ /^=head1 NAME/m;
 301 die "$progname: $input: missing DESCRIPTION section\n"
 302     if $content !~ /^=head1 DESCRIPTION/m;
 303 die "$progname: $input: missing AUTHOR or AUTHORS section\n"
 304     unless $content =~ /^=head1 AUTHOR/m;
 305 die "$progname: $input: missing SEE ALSO section\n"
 306     unless $content =~ /^=head1 SEE ALSO/m;
 307 die "$progname: $input: missing COPYRIGHT section\n"
 308     unless $content =~ /^=head1 COPYRIGHT/m;
 309 die "$progname: $input: BUGS is now added automatically, do not add it to the POD file\n"
 310     if $content =~ /^=head1 (REPORTING )?BUGS/m;
 311 die "$progname: $input: LICENSE is now added automatically, do not add it to the POD file\n"
 312     if $content =~ /^=head1 LICENSE/m;
 313
 314 # Check NAME section conformity.
 315 my @lines = split /\n/, $content;
 316 my @name;
 317 foreach (@lines) {
 318     push @name, $_ if /^=head1 NAME/../^=head1 (?!NAME)/
 319 }
 320 shift @name;                    # remove =head1 and empty line
 321 shift @name;                    # from beginning and end
 322 pop @name;
 323 pop @name;
 324 die "$progname: $input: empty NAME section\n"
 325     unless @name >= 1;
 326 die "$progname: $input: NAME doesn't start with $package_name\n"
 327     unless validate_name_field ($name[0]);
 328 die "$progname: $input: NAME does not conform with Linux man pages standard\n"
 329     if $name[0] !~ m/- [a-z]/ || $name[@name-1] =~ m/\.$/;
 330
 331 # Add standard LICENSE section at the end.
 332 my $license_lgplv2plus = "\
 333 This library is free software; you can redistribute it and/or
 334 modify it under the terms of the GNU Lesser General Public
 335 License as published by the Free Software Foundation; either
 336 version 2 of the License, or (at your option) any later version.
 337
 338 This library is distributed in the hope that it will be useful,
 339 but WITHOUT ANY WARRANTY; without even the implied warranty of
 340 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 341 Lesser General Public License for more details.
 342
 343 You should have received a copy of the GNU Lesser General Public
 344 License along with this library; if not, write to the Free Software
 345 Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
 346 ";
 347
 348 my $license_bsd = "\
 349 Redistribution and use in source and binary forms, with or without
 350 modification, are permitted provided that the following conditions are
 351 met:
 352
 353 =over 4
 354
 355 =item *
 356
 357 Redistributions of source code must retain the above copyright
 358 notice, this list of conditions and the following disclaimer.
 359
 360 =item *
 361
 362 Redistributions in binary form must reproduce the above copyright
 363 notice, this list of conditions and the following disclaimer in the
 364 documentation and/or other materials provided with the distribution.
 365
 366 =item *
 367
 368 Neither the name of Red Hat nor the names of its contributors may be
 369 used to endorse or promote products derived from this software without
 370 specific prior written permission.
 371
 372 =back
 373
 374 THIS SOFTWARE IS PROVIDED BY RED HAT AND CONTRIBUTORS ''AS IS'' AND
 375 ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
 376 THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
 377 PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL RED HAT OR
 378 CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
 379 SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
 380 LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF
 381 USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
 382 ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
 383 OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT
 384 OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
 385 SUCH DAMAGE.
 386 ";
 387
 388 $content .= "\n=head1 LICENSE\n";
 389 $content .= eval "\$license_$package_license";
 390
 391 @lines = split /\n/, $content;
 392 unless ($allow_long_lines) {
 393     # Check no over-long lines in the input.  (As a special exception
 394     # this is permitted in verbatim sections or if the line contains a
 395     # URL).
 396     foreach (@lines) {
 397         die "$progname: $input: line too long:\n$_\n"
 398             if length $_ > 76 &&
 399             substr ($_, 0, 1) ne ' ' &&
 400             ! m/https?:/;
 401     }
 402 }
 403
 404 # Output man page.
 405 SUBMAN: {
 406     package Podwrapper::Man;
 407
 408     use vars qw(@ISA $VERSION);
 409     @ISA = qw(Pod::Man);
 410     $VERSION = $package_version;
 411
 412     # Override the L<> method.
 413     sub cmd_l
 414     {
 415         my ($self, $attrs, $text) = @_;
 416         return $text;
 417     }
 418 }
 419
 420 if ($man) {
 421     my $parser = Podwrapper::Man->new (
 422         name => $name,
 423         release => $release, section => $section,
 424         center => uc $package_name,
 425         date => $date,
 426         stderr => 1, utf8 => 1
 427     );
 428     my $output;
 429     $parser->no_errata_section (1);
 430     $parser->complain_stderr (1);
 431     $parser->output_string (\$output);
 432     $parser->parse_string_document ($content)
 433         or die "$progname: could not parse input document";
 434     open OUT, ">$man" or die "$progname: $man: $!";
 435     print OUT $output or die "$progname: $man: $!";
 436     close OUT or die "$progname: $man: $!";
 437     if ($parser->any_errata_seen) {
 438         unlink $man;
 439         die "$input: errors or warnings in this POD file, see messages above\n"
 440     }
 441     #print "$progname: wrote $man\n";
 442 }
 443
 444 # Output HTML.
 445 SUBHTML: {
 446     # Subclass Pod::Simple::XHTML.  See the documentation.
 447     package Podwrapper::XHTML;
 448
 449     use vars qw(@ISA $VERSION);
 450     @ISA = qw(Pod::Simple::XHTML);
 451     $VERSION = $package_version;
 452
 453     # Note this also allows links to related projects because they all
 454     # appear together under the http://libguestfs.org website.
 455     sub is_a_local_page
 456     {
 457         local $_ = shift;
 458
 459         return 1 if /^Sys::Guestfs/;
 460         return 0 if /^virt-install/;
 461         return 1 if /^virt-/;
 462         return 1 if /^libguestf/;
 463         return 1 if /^guestf/;
 464         return 1 if /^guestmount/;
 465         return 1 if /^guestunmount/;
 466         return 1 if /^hivex/;
 467         return 1 if /^supermin/;
 468         return 1 if /^libnbd/;
 469         return 1 if /^nbd/;
 470         return 0;
 471     }
 472
 473     sub resolve_man_page_link
 474     {
 475         my $self = shift;
 476         my $name = $_[0];   # eg. "foobar(3)", can be undef
 477         my $anchor = $_[1]; # eg. "SYNOPSIS", can be undef
 478         my $r = "";
 479         if (defined $name) {
 480             return $self->SUPER::resolve_man_page_link (@_)
 481                 unless is_a_local_page ($name);
 482             $name =~ s/\((.*)\)$/.$1/;
 483             $r .= "$name.html";
 484         }
 485         $r .= "#" . $self->idify ($anchor, 1) if defined $anchor;
 486         $r;
 487     }
 488 }
 489
 490 if ($html) {
 491     mkdir "$abs_top_builddir/html";
 492
 493     my $parser = Podwrapper::XHTML->new;
 494     my $output;
 495     $parser->no_errata_section (1);
 496     $parser->complain_stderr (1);
 497     $parser->force_title ($name[0]); # from @name above
 498     $parser->output_string (\$output);
 499     # Added in Pod::Simple 3.16, 2011-03-14.
 500     eval { $parser->html_charset ("UTF-8") };
 501     $parser->html_css ("pod.css");
 502     $parser->index (1);
 503     $parser->parse_string_document ($content);
 504
 505     # Hack for Perl 5.16.
 506     $output =~ s{/>pod.css<}{/>\n<};
 507
 508     open OUT, ">$html" or die "$progname: $html: $!";
 509     print OUT $output or die "$progname: $html: $!";
 510     close OUT or die "$progname: $html: $!";
 511     if ($parser->any_errata_seen) {
 512         unlink $html;
 513         die "$input: errors or warnings in this POD file, see messages above\n"
 514     }
 515     #print "$progname: wrote $html\n";
 516 }
 517
 518 # Output text.
 519 if ($text) {
 520     my $parser = Pod::Simple::Text->new;
 521     my $output;
 522     $parser->no_errata_section (1);
 523     $parser->complain_stderr (1);
 524     $parser->output_string (\$output);
 525     $parser->parse_string_document ($content);
 526     open OUT, ">$text" or die "$progname: $text: $!";
 527     binmode OUT, ":utf8";
 528     print OUT $output or die "$progname: $text: $!";
 529     close OUT or die "$progname: $text: $!";
 530     if ($parser->any_errata_seen) {
 531         unlink $text;
 532         die "$input: errors or warnings in this POD file, see messages above\n"
 533     }
 534     #print "$progname: wrote $text\n";
 535 }
 536
 537 sub read_whole_file
 538 {
 539     my $input = shift;
 540     local $/ = undef;
 541
 542     open FILE, "<:encoding(UTF-8)", $input or die "$progname: $input: $!";
 543     $_ = <FILE>;
 544     close FILE;
 545     $_;
 546 }
 547
 548 sub read_verbatim_file
 549 {
 550     my $input = shift;
 551     my @r = ();
 552
 553     open FILE, "<:encoding(UTF-8)", $input or die "$progname: $input: $!";
 554     while (<FILE>) {
 555         chomp;
 556         if (length) { push @r, " $_" } else { push @r, "" }
 557     }
 558     close FILE;
 559     return join ("\n", @r) . "\n";
 560 }
 561
 562 =head1 SEE ALSO
 563
 564 L<perlpod(1)>,
 565 L<Pod::Simple(3pm)>.
 566
 567 =head1 AUTHOR
 568
 569 Richard W.M. Jones.
 570
 571 =head1 COPYRIGHT
 572
 573 Copyright Red Hat