podwrapper.pl.in

   1 #!/usr/bin/env perl
   2 # podwrapper.pl
   3 # @configure_input@
   4 # Copyright (C) 2010-2021 Red Hat Inc.
   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/^nbdkit/;
  56 }
  57
  58 # The license for man pages in this package - see LICENSE below.
  59 my $package_license = "bsd";
  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 # Check cross-references to other nbdkit man pages exist.
 405 my @xrefs = $content =~ /L<(nbdkit-.*?\([1-9]\))>/g;
 406 foreach (@xrefs) {
 407     # Plugins can be in section 1 or 3.  Here we only check the plugin
 408     # name exists, but we should check the section (XXX).
 409     if (m/^nbdkit-(.*?)-plugin\(([13])\)$/) {
 410         my $name = $1;
 411         my $section = $2;
 412         die "$progname: $input: cannot find cross reference for $_\n"
 413             if ! -d "$abs_top_srcdir/plugins/$name"
 414     }
 415     # All filters should be in section 1, so we only need to check
 416     # they exist.
 417     elsif (m/^nbdkit-(.*?)-filter\(1\)$/) {
 418         my $name = $1;
 419         die "$progname: $input: cannot find cross reference for $_\n"
 420             if ! -d "$abs_top_srcdir/filters/$name"
 421     }
 422     # Other documentation in section 1.
 423     elsif (m/^nbdkit-(.*)\(1\)$/) {
 424         my $name = $1;
 425         die "$progname: $input: cannot find cross reference for $_\n"
 426             if ! -f "$abs_top_srcdir/docs/nbdkit-$name.pod"
 427     }
 428     elsif (m/^nbdkit-plugin\(3\)$/ || m/^nbdkit-filter\(3\)$/) {
 429         # nothing
 430     }
 431     else {
 432         die "$progname: $input: cannot find cross-reference for $_\n"
 433     }
 434 }
 435
 436 # Output man page.
 437 SUBMAN: {
 438     package Podwrapper::Man;
 439
 440     use vars qw(@ISA $VERSION);
 441     @ISA = qw(Pod::Man);
 442     $VERSION = $package_version;
 443
 444     # Override the L<> method.
 445     sub cmd_l
 446     {
 447         my ($self, $attrs, $text) = @_;
 448         return $text;
 449     }
 450 }
 451
 452 if ($man) {
 453     my $parser = Podwrapper::Man->new (
 454         name => $name,
 455         release => $release, section => $section,
 456         center => uc $package_name,
 457         date => $date,
 458         stderr => 1, utf8 => 1
 459     );
 460     my $output;
 461     $parser->no_errata_section (1);
 462     $parser->complain_stderr (1);
 463     $parser->output_string (\$output);
 464     $parser->parse_string_document ($content)
 465         or die "$progname: could not parse input document";
 466     open OUT, ">$man" or die "$progname: $man: $!";
 467     print OUT $output or die "$progname: $man: $!";
 468     close OUT or die "$progname: $man: $!";
 469     if ($parser->any_errata_seen) {
 470         unlink $man;
 471         die "$input: errors or warnings in this POD file, see messages above\n"
 472     }
 473     #print "$progname: wrote $man\n";
 474 }
 475
 476 # Output HTML.
 477 SUBHTML: {
 478     # Subclass Pod::Simple::XHTML.  See the documentation.
 479     package Podwrapper::XHTML;
 480
 481     use vars qw(@ISA $VERSION);
 482     @ISA = qw(Pod::Simple::XHTML);
 483     $VERSION = $package_version;
 484
 485     # Note this also allows links to related projects because they all
 486     # appear together under the http://libguestfs.org website.
 487     sub is_a_local_page
 488     {
 489         local $_ = shift;
 490
 491         return 1 if /^Sys::Guestfs/;
 492         return 0 if /^virt-install/;
 493         return 1 if /^virt-/;
 494         return 1 if /^libguestf/;
 495         return 1 if /^guestf/;
 496         return 1 if /^guestmount/;
 497         return 1 if /^guestunmount/;
 498         return 1 if /^hivex/;
 499         return 1 if /^supermin/;
 500         return 1 if /^libnbd/;
 501         return 1 if /^nbd/;
 502         return 0;
 503     }
 504
 505     sub resolve_man_page_link
 506     {
 507         my $self = shift;
 508         my $name = $_[0];   # eg. "foobar(3)", can be undef
 509         my $anchor = $_[1]; # eg. "SYNOPSIS", can be undef
 510         my $r = "";
 511         if (defined $name) {
 512             return $self->SUPER::resolve_man_page_link (@_)
 513                 unless is_a_local_page ($name);
 514             $name =~ s/\((.*)\)$/.$1/;
 515             $r .= "$name.html";
 516         }
 517         $r .= "#" . $self->idify ($anchor, 1) if defined $anchor;
 518         $r;
 519     }
 520 }
 521
 522 if ($html) {
 523     mkdir "$abs_top_builddir/html";
 524
 525     my $parser = Podwrapper::XHTML->new;
 526     my $output;
 527     $parser->no_errata_section (1);
 528     $parser->complain_stderr (1);
 529     $parser->force_title ($name[0]); # from @name above
 530     $parser->output_string (\$output);
 531     # Added in Pod::Simple 3.16, 2011-03-14.
 532     eval { $parser->html_charset ("UTF-8") };
 533     $parser->html_css ("pod.css");
 534     $parser->index (1);
 535     $parser->parse_string_document ($content);
 536
 537     # Hack for Perl 5.16.
 538     $output =~ s{/>pod.css<}{/>\n<};
 539
 540     open OUT, ">$html" or die "$progname: $html: $!";
 541     print OUT $output or die "$progname: $html: $!";
 542     close OUT or die "$progname: $html: $!";
 543     if ($parser->any_errata_seen) {
 544         unlink $html;
 545         die "$input: errors or warnings in this POD file, see messages above\n"
 546     }
 547     #print "$progname: wrote $html\n";
 548 }
 549
 550 # Output text.
 551 if ($text) {
 552     my $parser = Pod::Simple::Text->new;
 553     my $output;
 554     $parser->no_errata_section (1);
 555     $parser->complain_stderr (1);
 556     $parser->output_string (\$output);
 557     $parser->parse_string_document ($content);
 558     open OUT, ">$text" or die "$progname: $text: $!";
 559     binmode OUT, ":utf8";
 560     print OUT $output or die "$progname: $text: $!";
 561     close OUT or die "$progname: $text: $!";
 562     if ($parser->any_errata_seen) {
 563         unlink $text;
 564         die "$input: errors or warnings in this POD file, see messages above\n"
 565     }
 566     #print "$progname: wrote $text\n";
 567 }
 568
 569 sub read_whole_file
 570 {
 571     my $input = shift;
 572     local $/ = undef;
 573
 574     open FILE, "<:encoding(UTF-8)", $input or die "$progname: $input: $!";
 575     $_ = <FILE>;
 576     close FILE;
 577     $_;
 578 }
 579
 580 sub read_verbatim_file
 581 {
 582     my $input = shift;
 583     my @r = ();
 584
 585     open FILE, "<:encoding(UTF-8)", $input or die "$progname: $input: $!";
 586     while (<FILE>) {
 587         chomp;
 588         if (length) { push @r, " $_" } else { push @r, "" }
 589     }
 590     close FILE;
 591     return join ("\n", @r) . "\n";
 592 }
 593
 594 =head1 SEE ALSO
 595
 596 L<perlpod(1)>,
 597 L<Pod::Simple(3pm)>.
 598
 599 =head1 AUTHOR
 600
 601 Richard W.M. Jones.
 602
 603 =head1 COPYRIGHT
 604
 605 Copyright (C) 2010-2021 Red Hat Inc.