mirror of
https://github.com/libguestfs/libguestfs.git
synced 2026-03-21 22:53:37 +00:00
307c83177c
Run the following command over the source: perl -pi.bak -e 's/(20[01][0-9])-2015/$1-2016/g' `git ls-files`
586 lines
16 KiB
Perl
Executable File
586 lines
16 KiB
Perl
Executable File
#!/usr/bin/env perl
|
|
# podwrapper.pl
|
|
# Copyright (C) 2010-2016 Red Hat Inc.
|
|
# @configure_input@
|
|
#
|
|
# This program is free software; you can redistribute it and/or modify
|
|
# it under the terms of the GNU General Public License as published by
|
|
# the Free Software Foundation; either version 2 of the License, or
|
|
# (at your option) any later version.
|
|
#
|
|
# This program is distributed in the hope that it will be useful,
|
|
# but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
# GNU General Public License for more details.
|
|
#
|
|
# You should have received a copy of the GNU General Public License
|
|
# along with this program; if not, write to the Free Software
|
|
# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
|
|
|
|
use warnings;
|
|
use strict;
|
|
|
|
use Pod::Usage;
|
|
use Getopt::Long;
|
|
use Pod::Man;
|
|
use Pod::Simple;
|
|
use Pod::Simple::Text;
|
|
use Pod::Simple::XHTML;
|
|
use File::Basename;
|
|
|
|
# https://www.redhat.com/archives/libguestfs/2013-May/thread.html#00088
|
|
eval { $Text::Wrap::huge = "overflow" };
|
|
|
|
=head1 NAME
|
|
|
|
podwrapper.pl - Generate libguestfs documentation from POD input files
|
|
|
|
=head1 SYNOPSIS
|
|
|
|
man_MANS = virt-foo.1
|
|
|
|
virt-foo.1 $(top_builddir)/website/virt-foo.1.html: stamp-virt-foo.pod
|
|
|
|
stamp-virt-foo.pod: virt-foo.pod
|
|
$(PODWRAPPER) \
|
|
--section 1 \
|
|
--man virt-foo.1 \
|
|
--html $(top_builddir)/website/virt-foo.1.html \
|
|
--license GPLv2+ \
|
|
$<
|
|
touch $@
|
|
|
|
CLEANFILES += stamp-virt-foo.pod
|
|
|
|
=head1 DESCRIPTION
|
|
|
|
podwrapper.pl is a Perl script that generates various output formats
|
|
from POD input files that libguestfs uses for most documentation.
|
|
|
|
You must specify one input file, and one or more output formats. The
|
|
output options are I<--man>, I<--html> and I<--text> (see below).
|
|
|
|
In C<Makefile.am> files, use a variation of the boilerplate shown in
|
|
the L</SYNOPSIS> section above.
|
|
|
|
For information about the POD format, see L<perlpod(1)>.
|
|
|
|
=head1 OPTIONS
|
|
|
|
=over 4
|
|
|
|
=cut
|
|
|
|
my $help;
|
|
|
|
=item B<--help>
|
|
|
|
Display brief help.
|
|
|
|
=cut
|
|
|
|
my $html;
|
|
|
|
=item B<--html output.html>
|
|
|
|
Write a web page to C<output.html>. If this option is not
|
|
given, then no web page output is produced.
|
|
|
|
=cut
|
|
|
|
my @inserts;
|
|
|
|
=item B<--insert filename:__PATTERN__>
|
|
|
|
In the input file, replace the literal text C<__PATTERN__> with the
|
|
replacement file C<filename>. You can give this option multiple
|
|
times.
|
|
|
|
The contents of C<filename> are treated as POD.
|
|
Compare and contrast with I<--verbatim>.
|
|
|
|
Although it is conventional to use C<__...__> (double underscores) for
|
|
patterns, in fact you can use any string as the pattern.
|
|
|
|
=cut
|
|
|
|
my @licenses;
|
|
|
|
=item B<--license GPLv2+>
|
|
|
|
=item B<--license LGPLv2+>
|
|
|
|
=item B<--license examples>
|
|
|
|
Add the given license to the end of the man page. This parameter
|
|
is required. The parameter may be given multiple times (eg. for
|
|
mixed content).
|
|
|
|
=cut
|
|
|
|
my $man;
|
|
|
|
=item B<--man output.n>
|
|
|
|
Write a man page to C<output.n> (C<n> is the manual section number).
|
|
If this option is not given, then no man page output is produced.
|
|
|
|
=cut
|
|
|
|
my $name;
|
|
|
|
=item B<--name name>
|
|
|
|
Set the name of the man page. If not set, defaults to the basename
|
|
of the input file.
|
|
|
|
=cut
|
|
|
|
my $section;
|
|
|
|
=item B<--section N>
|
|
|
|
Set the section of the man page (a number such as C<1> for
|
|
command line utilities or C<3> for C API documentation). If
|
|
not set, defaults to C<1>.
|
|
|
|
=cut
|
|
|
|
my $strict_checks = 1;
|
|
|
|
=item B<--no-strict-checks>
|
|
|
|
Disable strict checks of the man page. This is only used
|
|
when generating the translated man pages in the C<po-docs>
|
|
subdirectory.
|
|
|
|
=cut
|
|
|
|
my $text;
|
|
|
|
=item B<--text output.txt>
|
|
|
|
Write a text file to C<output.txt>. If this option is not
|
|
given, then no text output is produced.
|
|
|
|
=cut
|
|
|
|
my @verbatims;
|
|
|
|
=item B<--verbatim filename:__PATTERN__>
|
|
|
|
In the input file, replace the literal text C<__PATTERN__> with the
|
|
replacement file C<filename>. You can give this option multiple
|
|
times.
|
|
|
|
The contents of C<filename> are inserted as verbatim text, and
|
|
are I<not> interpreted as POD.
|
|
Compare and contrast with I<--insert>.
|
|
|
|
Although it is conventional to use C<__...__> (double underscores) for
|
|
patterns, in fact you can use any string as the pattern.
|
|
|
|
=cut
|
|
|
|
=back
|
|
|
|
=cut
|
|
|
|
# Clean up the program name.
|
|
my $progname = $0;
|
|
$progname =~ s{.*/}{};
|
|
|
|
# Parse options.
|
|
GetOptions ("help|?" => \$help,
|
|
"html=s" => \$html,
|
|
"license=s" => \@licenses,
|
|
"insert=s" => \@inserts,
|
|
"man=s" => \$man,
|
|
"name=s" => \$name,
|
|
"section=s" => \$section,
|
|
"strict-checks!" => \$strict_checks,
|
|
"text=s" => \$text,
|
|
"verbatim=s" => \@verbatims
|
|
) or pod2usage (2);
|
|
pod2usage (1) if $help;
|
|
|
|
die "$progname: missing argument: podwrapper input.pod\n" unless @ARGV == 1;
|
|
my $input = $ARGV[0];
|
|
|
|
die "$progname: $input: missing argument: --license parameter is required\n"
|
|
if $strict_checks && @licenses == 0;
|
|
|
|
# There should be at least one output.
|
|
die "$progname: $input: no output format specified. Use --man and/or --html and/or --text.\n"
|
|
unless defined $man || defined $html || defined $text;
|
|
|
|
# Default for $name and $section.
|
|
$name = basename ($input, ".pod") unless defined $name;
|
|
$section = 1 unless defined $section;
|
|
|
|
# Note that these @...@ are substituted by ./configure.
|
|
my $abs_top_srcdir = "@abs_top_srcdir@";
|
|
my $abs_top_builddir = "@abs_top_builddir@";
|
|
my $package_name = "@PACKAGE_NAME@";
|
|
my $package_version = "@PACKAGE_VERSION@";
|
|
|
|
die "$progname: ./configure substitutions were not performed"
|
|
unless $abs_top_srcdir && $abs_top_builddir &&
|
|
$package_name && $package_version;
|
|
|
|
# Create a stable date (thanks Hilko Bengen).
|
|
my $date;
|
|
my $filename = "$abs_top_srcdir/ChangeLog";
|
|
if (-r $filename) {
|
|
open FILE, $filename or die "$progname: $filename: $!";
|
|
while (<FILE>) {
|
|
if (/^Date:\s+...\s+(...)\s+(\d+)\s+..:..:..\s+(\d{4})\s+.*$/) {
|
|
my $i = 0;
|
|
my %month =
|
|
map { $_ => ++$i }
|
|
(qw< Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec >);
|
|
$date = sprintf '%04d-%02d-%02d', $3, $month{$1}, $2;
|
|
last;
|
|
}
|
|
}
|
|
close FILE;
|
|
}
|
|
$filename = "$abs_top_srcdir/.git";
|
|
if (!$date && -d $filename) {
|
|
local $ENV{GIT_DIR} = $filename;
|
|
$_ = `git show -s --format=%ci`;
|
|
$date = $1 if /^(\d+-\d+-\d+)\s/;
|
|
}
|
|
if (!$date) {
|
|
my ($day, $month, $year) = (localtime)[3,4,5];
|
|
$date = sprintf ("%04d-%02d-%02d", $year+1900, $month+1, $day);
|
|
}
|
|
|
|
# Create a release string.
|
|
my $release = "$package_name-$package_version";
|
|
|
|
#print "input=$input\n";
|
|
#print "name=$name\n";
|
|
#print "section=$section\n";
|
|
#print "date=$date\n";
|
|
|
|
# Read the input.
|
|
my $content = read_whole_file ($input);
|
|
|
|
# Perform @inserts.
|
|
foreach (@inserts) {
|
|
my @a = split /:/, $_, 2;
|
|
die "$progname: $input: no colon in parameter of --insert\n" unless @a >= 2;
|
|
my $replacement = read_whole_file ($a[0]);
|
|
my $oldcontent = $content;
|
|
$content =~ s/$a[1]/$replacement/ge;
|
|
die "$progname: $input: could not find pattern '$a[1]' in input file\n"
|
|
if $content eq $oldcontent;
|
|
}
|
|
|
|
# Turn external links to this man page into simple cross-section links.
|
|
$content =~ s,\QL<$name($section)/\E,L</,g;
|
|
|
|
# Perform @verbatims.
|
|
foreach (@verbatims) {
|
|
my @a = split /:/, $_, 2;
|
|
die "$progname: $input: no colon in parameter of --verbatim\n" unless @a >= 2;
|
|
my $replacement = read_verbatim_file ($a[0]);
|
|
my $oldcontent = $content;
|
|
$content =~ s/$a[1]/$replacement/ge;
|
|
die "$progname: $input: could not find pattern '$a[1]' in input file\n"
|
|
if $content eq $oldcontent;
|
|
}
|
|
|
|
# There should be no =encoding line present in the content (we will add one).
|
|
die "$progname: $input: =encoding must not be present in input\n"
|
|
if $content =~ /^=encoding/m;
|
|
|
|
$content =~ s/^=(.*)/\n=encoding utf8\n\n=$1/m;
|
|
|
|
if ($strict_checks) {
|
|
# Verify sections present / not present.
|
|
die "$progname: $input: missing AUTHOR or AUTHORS section\n"
|
|
unless $content =~ /^=head1 AUTHOR/m;
|
|
die "$progname: $input: missing SEE ALSO section\n"
|
|
unless $content =~ /^=head1 SEE ALSO/m;
|
|
die "$progname: $input: missing COPYRIGHT section\n"
|
|
unless $content =~ /^=head1 COPYRIGHT/m;
|
|
die "$progname: $input: BUGS is now added automatically, do not add it to the POD file\n"
|
|
if $content =~ /^=head1 (REPORTING )?BUGS/m;
|
|
die "$progname: $input: LICENSE is now added automatically, do not add it to the POD file\n"
|
|
if $content =~ /^=head1 LICENSE/m;
|
|
die "$progname: $input: GPL/LGPL should be specified using the --license parameter, not included in the POD file\n"
|
|
if $content =~ /^This program is free software/ ||
|
|
$content =~ /^This library is free software/;
|
|
}
|
|
|
|
# Add standard LICENSE and BUGS sections.
|
|
my $LGPLv2plus =
|
|
"This library is free software; you can redistribute it and/or modify it
|
|
under the terms of the GNU Lesser General Public License as published
|
|
by the Free Software Foundation; either version 2 of the License, or
|
|
(at your option) any later version.
|
|
|
|
This library is distributed in the hope that it will be useful, but
|
|
WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
|
Lesser General Public License for more details.
|
|
|
|
You should have received a copy of the GNU Lesser General Public
|
|
License along with this library; if not, write to the Free Software
|
|
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
|
|
02110-1301 USA
|
|
";
|
|
|
|
my $GPLv2plus =
|
|
"This program is free software; you can redistribute it and/or modify it
|
|
under the terms of the GNU General Public License as published by the
|
|
Free Software Foundation; either version 2 of the License, or (at your
|
|
option) any later version.
|
|
|
|
This program is distributed in the hope that it will be useful, but
|
|
WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
|
General Public License for more details.
|
|
|
|
You should have received a copy of the GNU General Public License along
|
|
with this program; if not, write to the Free Software Foundation, Inc.,
|
|
51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
|
|
";
|
|
|
|
my $examples_license =
|
|
"This manual page contains examples which we hope you will use in
|
|
your programs. The examples may be freely copied, modified and
|
|
distributed for any purpose without any restrictions.
|
|
";
|
|
|
|
my $reporting_bugs =
|
|
"=head1 BUGS
|
|
|
|
To get a list of bugs against libguestfs, use this link:
|
|
L<https://bugzilla.redhat.com/buglist.cgi?component=libguestfs&product=Virtualization+Tools>
|
|
|
|
To report a new bug against libguestfs, use this link:
|
|
L<https://bugzilla.redhat.com/enter_bug.cgi?component=libguestfs&product=Virtualization+Tools>
|
|
|
|
When reporting a bug, please supply:
|
|
|
|
\=over 4
|
|
|
|
\=item *
|
|
|
|
The version of libguestfs.
|
|
|
|
\=item *
|
|
|
|
Where you got libguestfs (eg. which Linux distro, compiled from source, etc)
|
|
|
|
\=item *
|
|
|
|
Describe the bug accurately and give a way to reproduce it.
|
|
|
|
\=item *
|
|
|
|
Run L<libguestfs-test-tool(1)> and paste the B<complete, unedited>
|
|
output into the bug report.
|
|
|
|
\=back
|
|
";
|
|
|
|
$content .= "\n\n=head1 LICENSE\n\n";
|
|
|
|
foreach (@licenses) {
|
|
if ($_ eq "LGPLv2+") {
|
|
$content .= $LGPLv2plus . "\n\n";
|
|
}
|
|
elsif ($_ eq "GPLv2+") {
|
|
$content .= $GPLv2plus . "\n\n";
|
|
}
|
|
elsif ($_ eq "examples") {
|
|
$content .= $examples_license . "\n\n";
|
|
}
|
|
else {
|
|
die "$progname: $input: invalid --license parameter: $_\n";
|
|
}
|
|
}
|
|
|
|
$content .= "\n\n$reporting_bugs";
|
|
|
|
# Output man page.
|
|
SUBMAN: {
|
|
package Podwrapper::Man;
|
|
|
|
use vars qw(@ISA $VERSION);
|
|
@ISA = qw(Pod::Man);
|
|
$VERSION = $package_version;
|
|
|
|
# Override the L<> method.
|
|
sub cmd_l
|
|
{
|
|
my ($self, $attrs, $text) = @_;
|
|
return $text;
|
|
}
|
|
}
|
|
|
|
if ($man) {
|
|
my $parser = Podwrapper::Man->new (
|
|
name => $name,
|
|
release => $release, section => $section,
|
|
center => "Virtualization Support",
|
|
date => $date,
|
|
stderr => 1, utf8 => 1
|
|
);
|
|
my $output;
|
|
$parser->output_string (\$output);
|
|
$parser->parse_string_document ($content)
|
|
or die "$progname: could not parse input document";
|
|
open OUT, ">$man" or die "$progname: $man: $!";
|
|
print OUT $output or die "$progname: $man: $!";
|
|
close OUT or die "$progname: $man: $!";
|
|
print "$progname: wrote $man\n";
|
|
}
|
|
|
|
# Output HTML.
|
|
SUBHTML: {
|
|
# Subclass Pod::Simple::XHTML. See the documentation.
|
|
package Podwrapper::XHTML;
|
|
|
|
use vars qw(@ISA $VERSION);
|
|
@ISA = qw(Pod::Simple::XHTML);
|
|
$VERSION = $package_version;
|
|
|
|
# Pod::Simple::XHTML returns uppercase identifiers, whereas the
|
|
# old pod2html returns lowercase ones.
|
|
sub idify
|
|
{
|
|
my $self = shift;
|
|
my $id = $self->SUPER::idify (@_);
|
|
lc ($id);
|
|
}
|
|
|
|
sub is_a_libguestfs_page
|
|
{
|
|
local $_ = shift;
|
|
|
|
return 1 if /^Sys::Guestfs/;
|
|
return 0 if /^virt-install/;
|
|
return 1 if /^virt-/;
|
|
return 1 if /^libguestf/;
|
|
return 1 if /^guestf/;
|
|
return 1 if /^guestmount/;
|
|
return 1 if /^guestunmount/;
|
|
return 1 if /^hivex/;
|
|
return 1 if /^supermin/;
|
|
return 0;
|
|
}
|
|
|
|
sub resolve_pod_page_link
|
|
{
|
|
my $self = shift;
|
|
my $podname = $_[0]; # eg. "Sys::Guestfs", can be undef
|
|
my $anchor = $_[1]; # eg. "SYNOPSIS", can be undef
|
|
my $r = "";
|
|
if (defined $podname) {
|
|
return $self->SUPER::resolve_pod_page_link (@_)
|
|
unless is_a_libguestfs_page ($podname);
|
|
$r .= "$podname.3.html"
|
|
}
|
|
$r .= "#" . $self->idify ($anchor, 1) if defined $anchor;
|
|
$r;
|
|
}
|
|
|
|
sub resolve_man_page_link
|
|
{
|
|
my $self = shift;
|
|
my $name = $_[0]; # eg. "virt-make-fs(1)", can be undef
|
|
my $anchor = $_[1]; # eg. "SYNOPSIS", can be undef
|
|
my $r = "";
|
|
if (defined $name) {
|
|
return $self->SUPER::resolve_man_page_link (@_)
|
|
unless is_a_libguestfs_page ($name);
|
|
$name =~ s/\((.*)\)$/.$1/;
|
|
$r .= "$name.html";
|
|
}
|
|
$r .= "#" . $self->idify ($anchor, 1) if defined $anchor;
|
|
$r;
|
|
}
|
|
|
|
# For some reason Pod::Simple::XHTML usually cannot find a
|
|
# title for the page. This defaults the HTML <title> field
|
|
# to the same as the man page name.
|
|
sub default_title { $name }
|
|
}
|
|
|
|
if ($html) {
|
|
mkdir "$abs_top_builddir/website";
|
|
|
|
my $parser = Podwrapper::XHTML->new;
|
|
my $output;
|
|
$parser->output_string (\$output);
|
|
# Added in Pod::Simple 3.16, 2011-03-14.
|
|
eval { $parser->html_charset ("UTF-8") };
|
|
$parser->html_css ("pod.css");
|
|
$parser->index (1);
|
|
$parser->parse_string_document ($content);
|
|
|
|
# Hack for Perl 5.16.
|
|
$output =~ s{/>pod.css<}{/>\n<};
|
|
|
|
open OUT, ">$html" or die "$progname: $html: $!";
|
|
print OUT $output or die "$progname: $html: $!";
|
|
close OUT or die "$progname: $html: $!";
|
|
print "$progname: wrote $html\n";
|
|
}
|
|
|
|
# Output text.
|
|
if ($text) {
|
|
my $parser = Pod::Simple::Text->new;
|
|
my $output;
|
|
$parser->output_string (\$output);
|
|
$parser->parse_string_document ($content);
|
|
open OUT, ">$text" or die "$progname: $text: $!";
|
|
binmode OUT, ":utf8";
|
|
print OUT $output or die "$progname: $text: $!";
|
|
close OUT or die "$progname: $text: $!";
|
|
print "$progname: wrote $text\n";
|
|
}
|
|
|
|
sub read_whole_file
|
|
{
|
|
my $input = shift;
|
|
local $/ = undef;
|
|
|
|
open FILE, $input or die "$progname: $input: $!";
|
|
$_ = <FILE>;
|
|
close FILE;
|
|
$_;
|
|
}
|
|
|
|
sub read_verbatim_file
|
|
{
|
|
my $input = shift;
|
|
my $r = "";
|
|
|
|
open FILE, $input or die "$progname: $input: $!";
|
|
while (<FILE>) {
|
|
$r .= " $_";
|
|
}
|
|
close FILE;
|
|
$r;
|
|
}
|
|
|
|
=head1 SEE ALSO
|
|
|
|
L<perlpod(1)>,
|
|
L<Pod::Simple(3pm)>,
|
|
libguestfs.git/README.
|
|
|
|
=head1 AUTHOR
|
|
|
|
Richard W.M. Jones.
|
|
|
|
=head1 COPYRIGHT
|
|
|
|
Copyright (C) 2012-2016 Red Hat Inc.
|