[perl5.git] / Porting / pod_lib.pl

#!/usr/bin/perl -w

use strict;
use Digest::MD5 'md5';
use File::Find;

# make it clearer when we haven't run to completion, as we can be quite
# noisy when things are working ok

sub my_die {
    print STDERR "$0: ", @_;
    print STDERR "\n" unless $_[-1] =~ /\n\z/;
    print STDERR "ABORTED\n";
    exit 255;
}

sub open_or_die {
    my $filename = shift;
    open my $fh, '<', $filename or my_die "Can't open $filename: $!";
    return $fh;
}

sub slurp_or_die {
    my $filename = shift;
    my $fh = open_or_die($filename);
    binmode $fh;
    local $/;
    my $contents = <$fh>;
    die "Can't read $filename: $!" unless defined $contents and close $fh;
    return $contents;
}

sub write_or_die {
    my ($filename, $contents) = @_;
    open my $fh, '>', $filename or die "Can't open $filename for writing: $!";
    binmode $fh;
    print $fh $contents or die "Can't write to $filename: $!";
    close $fh or die "Can't close $filename: $!";
}

sub pods_to_install {
    # manpages not to be installed
    my %do_not_install = map { ($_ => 1) }
        qw(Pod::Functions XS::APItest XS::Typemap);

    my (%done, %found);

    File::Find::find({no_chdir=>1,
                      wanted => sub {
                          if (m!/t\z!) {
                              ++$File::Find::prune;
                              return;
                          }

                          # $_ is $File::Find::name when using no_chdir
                          return unless m!\.p(?:m|od)\z! && -f $_;
                          return if m!lib/Net/FTP/.+\.pm\z!; # Hi, Graham! :-)
                          # Skip .pm files that have corresponding .pod files
                          return if s!\.pm\z!.pod! && -e $_;
                          s!\.pod\z!!;
                          s!\Alib/!!;
                          s!/!::!g;

                          my_die("Duplicate files for $_, '$done{$_}' and '$File::Find::name'")
                              if exists $done{$_};
                          $done{$_} = $File::Find::name;

                          return if $do_not_install{$_};
                          return if is_duplicate_pod($File::Find::name);
                          $found{/\A[a-z]/ ? 'PRAGMA' : 'MODULE'}{$_}
                              = $File::Find::name;
                      }}, 'lib');
    return \%found;
}

my %state = (
             # Don't copy these top level READMEs
             ignore => {
                        micro => 1,
                        # vms => 1,
                       },
            );

{
    my (%Lengths, %MD5s);

    sub is_duplicate_pod {
        my $file = shift;

        # Initialise the list of possible source files on the first call.
        unless (%Lengths) {
            __prime_state() unless $state{master};
            foreach (@{$state{master}}) {
                next unless $_->[2]{dual};
                # This is a dual-life perl*.pod file, which will have be copied
                # to lib/ by the build process, and hence also found there.
                # These are the only pod files that might become duplicated.
                ++$Lengths{-s $_->[1]};
                ++$MD5s{md5(slurp_or_die($_->[1]))};
            }
        }

        # We are a file in lib. Are we a duplicate?
        # Don't bother calculating the MD5 if there's no interesting file of
        # this length.
        return $Lengths{-s $file} && $MD5s{md5(slurp_or_die($file))};
    }
}

sub __prime_state {
    my $source = 'perldelta.pod';
    my $filename = "pod/$source";
    my $contents = slurp_or_die($filename);
    my @want =
        $contents =~ /perldelta - what is new for perl v(5)\.(\d+)\.(\d+)\n/;
    die "Can't extract version from $filename" unless @want;
    my $delta_leaf = join '', 'perl', @want, 'delta';
    $state{delta_target} = "$delta_leaf.pod";
    $state{delta_version} = \@want;

    # This way round so that keys can act as a MANIFEST skip list
    # Targets will always be in the pod directory. Currently we can only cope
    # with sources being in the same directory.
    $state{copies}{$state{delta_target}} = $source;

    # The default flags if none explicitly set for the current file.
    my $current_flags = '';
    my (%flag_set, @paths);

    my $master = open_or_die('pod/perl.pod');

    while (<$master>) {
        last if /^=begin buildtoc$/;
    }
    die "Can't find '=begin buildtoc':" if eof $master;

    while (<$master>) {
        next if /^$/ or /^#/;
        last if /^=end buildtoc/;
        my ($command, @args) = split ' ';
        if ($command eq 'flag') {
            # For the named pods, use these flags, instead of $current_flags
            my $flags = shift @args;
            my_die("Malformed flag $flags")
                unless $flags =~ /\A=([a-z]*)\z/;
            $flag_set{$_} = $1 foreach @args;
        } elsif ($command eq 'path') {
            # If the pod's name matches the regex, prepend the given path.
            my_die("Malformed path for /$args[0]/")
                unless @args == 2;
            push @paths, [qr/\A$args[0]\z/, $args[1]];
        } elsif ($command eq 'aux') {
            # The contents of perltoc.pod's "AUXILIARY DOCUMENTATION" section
            $state{aux} = [sort @args];
        } else {
            my_die("Unknown buildtoc command '$command'");
        }
    }

    foreach (<$master>) {
        next if /^$/ or /^#/;
        next if /^=head2/;
        last if /^=for buildtoc __END__$/;

        if (my ($action, $flags) = /^=for buildtoc flag ([-+])([a-z]+)/) {
            if ($action eq '+') {
                $current_flags .= $flags;
            } else {
                my_die("Attempt to unset [$flags] failed - flags are '$current_flags")
                    unless $current_flags =~ s/[\Q$flags\E]//g;
            }
        } elsif (my ($leafname, $desc) = /^\s+(\S+)\s+(.*)/) {
            my $podname = $leafname;
            my $filename = "pod/$podname.pod";
            foreach (@paths) {
                my ($re, $path) = @$_;
                if ($leafname =~ $re) {
                    $podname = $path . $leafname;
                    $filename = "$podname.pod";
                    last;
                }
            }

            # Keep this compatible with pre-5.10
            my $flags = delete $flag_set{$leafname};
            $flags = $current_flags unless defined $flags;

            my %flags;
            $flags{toc_omit} = 1 if $flags =~ tr/o//d;
            $flags{dual} = $podname ne $leafname;

            $state{generated}{"$podname.pod"}++ if $flags =~ tr/g//d;

            if ($flags =~ tr/r//d) {
                my $readme = $podname;
                $readme =~ s/^perl//;
                $state{readmes}{$readme} = $desc;
                $flags{readme} = 1;
            } else {
                $state{pods}{$podname} = $desc;
            }
            my_die "Unknown flag found in section line: $_" if length $flags;

            push @{$state{master}},
                [$leafname, $filename, \%flags];

            if ($podname eq 'perldelta') {
                local $" = '.';
                push @{$state{master}},
                    [$delta_leaf, "pod/$state{delta_target}"];
                $state{pods}{$delta_leaf} = "Perl changes in version @want";
            }

        } else {
            my_die("Malformed line: $_");
        }
    }
    close $master or my_die("close pod/perl.pod: $!");

    my_die("perl.pod sets flags for unknown pods: "
           . join ' ', sort keys %flag_set)
        if keys %flag_set;
}

sub get_pod_metadata {
    # Do we expect to find generated pods on disk?
    my $permit_missing_generated = shift;
    # Do they want a consistency report?
    my $callback = shift;

    __prime_state() unless $state{master};
    return \%state unless $callback;

    my %BuildFiles;

    foreach my $path (@_) {
        $path =~ m!([^/]+)$!;
        ++$BuildFiles{$1};
    }

    # Sanity cross check

    my (%disk_pods, %manipods, %manireadmes);
    my (%cpanpods, %cpanpods_leaf);
    my (%our_pods);

    # These are stub files for deleted documents. We don't want them to show up
    # in perl.pod, they just exist so that if someone types "perldoc perltoot"
    # they get some sort of pointer to the new docs.
    my %ignoredpods
        = map { ( "$_.pod" => 1 ) } qw( perlboot perlbot perltooc perltoot );

    # Convert these to a list of filenames.
    ++$our_pods{"$_.pod"} foreach keys %{$state{pods}};
    foreach (@{$state{master}}) {
        ++$our_pods{"$_->[0].pod"}
            if $_->[2]{readme};
    }

    opendir my $dh, 'pod';
    while (defined ($_ = readdir $dh)) {
        next unless /\.pod\z/;
        ++$disk_pods{$_};
    }

    # Things we copy from won't be in perl.pod
    # Things we copy to won't be in MANIFEST

    my $mani = open_or_die('MANIFEST');
    while (<$mani>) {
        chomp;
        s/\s+.*$//;
        if (m!^pod/([^.]+\.pod)!i) {
            ++$manipods{$1};
        } elsif (m!^README\.(\S+)!i) {
            next if $state{ignore}{$1};
            ++$manireadmes{"perl$1.pod"};
        } elsif (exists $our_pods{$_}) {
            ++$cpanpods{$_};
            m!([^/]+)$!;
            ++$cpanpods_leaf{$1};
            $disk_pods{$_}++
                if -e $_;
        }
    }
    close $mani or my_die "close MANIFEST: $!\n";

    # Are we running before known generated files have been generated?
    # (eg in a clean checkout)
    my %not_yet_there;
    if ($permit_missing_generated) {
        # If so, don't complain if these files aren't yet in place
        %not_yet_there = (%manireadmes, %{$state{generated}}, %{$state{copies}})
    }

    my @inconsistent;
    foreach my $i (sort keys %disk_pods) {
        push @inconsistent, "$0: $i exists but is unknown by buildtoc\n"
            unless $our_pods{$i};
        push @inconsistent, "$0: $i exists but is unknown by MANIFEST\n"
            if !$BuildFiles{'MANIFEST'} # Ignore if we're rebuilding MANIFEST
                && !$manipods{$i} && !$manireadmes{$i} && !$state{copies}{$i}
                    && !$state{generated}{$i} && !$cpanpods{$i};
    }
    foreach my $i (sort keys %our_pods) {
        push @inconsistent, "$0: $i is known by buildtoc but does not exist\n"
            unless $disk_pods{$i} or $BuildFiles{$i} or $not_yet_there{$i};
    }
    unless ($BuildFiles{'MANIFEST'}) {
        # Again, ignore these if we're about to rebuild MANIFEST
        foreach my $i (sort keys %manipods) {
            push @inconsistent, "$0: $i is known by MANIFEST but does not exist\n"
                unless $disk_pods{$i};
            push @inconsistent, "$0: $i is known by MANIFEST but is marked as generated\n"
                if $state{generated}{$i};
        }
    }
    &$callback(@inconsistent);
    return \%state;
}

1;

# Local variables:
# cperl-indent-level: 4
# indent-tabs-mode: nil
# End:
#
# ex: set ts=8 sts=4 sw=4 et:
Commit	Line	Data
d7816c47 NC	1	#!/usr/bin/perl -w
	2
	3	use strict;
449e2f79	4	use Digest::MD5 'md5';
9bbb230a	5	use File::Find;
d7816c47 NC	6
	7	# make it clearer when we haven't run to completion, as we can be quite
	8	# noisy when things are working ok
	9
	10	sub my_die {
	11	print STDERR "$0: ", @_;
	12	print STDERR "\n" unless $_[-1] =~ /\n\z/;
	13	print STDERR "ABORTED\n";
	14	exit 255;
	15	}
	16
	17	sub open_or_die {
	18	my $filename = shift;
	19	open my $fh, '<', $filename or my_die "Can't open $filename: $!";
	20	return $fh;
	21	}
	22
bcfe7366 NC	23	sub slurp_or_die {
	24	my $filename = shift;
	25	my $fh = open_or_die($filename);
	26	binmode $fh;
	27	local $/;
	28	my $contents = <$fh>;
	29	die "Can't read $filename: $!" unless defined $contents and close $fh;
	30	return $contents;
	31	}
	32
	33	sub write_or_die {
	34	my ($filename, $contents) = @_;
	35	open my $fh, '>', $filename or die "Can't open $filename for writing: $!";
	36	binmode $fh;
	37	print $fh $contents or die "Can't write to $filename: $!";
	38	close $fh or die "Can't close $filename: $!";
	39	}
	40
9bbb230a NC	41	sub pods_to_install {
	42	# manpages not to be installed
	43	my %do_not_install = map { ($_ => 1) }
	44	qw(Pod::Functions XS::APItest XS::Typemap);
	45
	46	my (%done, %found);
	47
	48	File::Find::find({no_chdir=>1,
	49	wanted => sub {
65e5b016 NC	50	if (m!/t\z!) {
	51	++$File::Find::prune;
	52	return;
	53	}
	54
9bbb230a NC	55	# $_ is $File::Find::name when using no_chdir
9bbb230a NC	56	return unless m!\.p(?:m\|od)\z! && -f $_;
9bbb230a NC	57	return if m!lib/Net/FTP/.+\.pm\z!; # Hi, Graham! :-)
	58	# Skip .pm files that have corresponding .pod files
	59	return if s!\.pm\z!.pod! && -e $_;
	60	s!\.pod\z!!;
	61	s!\Alib/!!;
	62	s!/!::!g;
	63
	64	my_die("Duplicate files for $_, '$done{$_}' and '$File::Find::name'")
	65	if exists $done{$_};
	66	$done{$_} = $File::Find::name;
	67
	68	return if $do_not_install{$_};
	69	return if is_duplicate_pod($File::Find::name);
	70	$found{/\A[a-z]/ ? 'PRAGMA' : 'MODULE'}{$_}
	71	= $File::Find::name;
	72	}}, 'lib');
	73	return \%found;
	74	}
9887f448 NC	75
	76	my %state = (
	77	# Don't copy these top level READMEs
	78	ignore => {
	79	micro => 1,
	80	# vms => 1,
	81	},
	82	);
	83
4027e27b NC	84	{
	85	my (%Lengths, %MD5s);
	86
	87	sub is_duplicate_pod {
	88	my $file = shift;
	89
	90	# Initialise the list of possible source files on the first call.
	91	unless (%Lengths) {
	92	__prime_state() unless $state{master};
	93	foreach (@{$state{master}}) {
2ce3647c	94	next unless $_->[2]{dual};
4027e27b NC	95	# This is a dual-life perl*.pod file, which will have be copied
	96	# to lib/ by the build process, and hence also found there.
	97	# These are the only pod files that might become duplicated.
2ce3647c NC	98	++$Lengths{-s $_->[1]};
2ce3647c NC	99	++$MD5s{md5(slurp_or_die($_->[1]))};
4027e27b NC	100	}
	101	}
	102
	103	# We are a file in lib. Are we a duplicate?
	104	# Don't bother calculating the MD5 if there's no interesting file of
	105	# this length.
	106	return $Lengths{-s $file} && $MD5s{md5(slurp_or_die($file))};
	107	}
449e2f79 NC	108	}
449e2f79 NC	109
9887f448	110	sub __prime_state {
d7816c47 NC	111	my $source = 'perldelta.pod';
d7816c47 NC	112	my $filename = "pod/$source";
64587559	113	my $contents = slurp_or_die($filename);
d7816c47	114	my @want =
bcfe7366	115	$contents =~ /perldelta - what is new for perl v(5)\.(\d+)\.(\d+)\n/;
d7816c47	116	die "Can't extract version from $filename" unless @want;
0aef0fe5 NC	117	my $delta_leaf = join '', 'perl', @want, 'delta';
0aef0fe5 NC	118	$state{delta_target} = "$delta_leaf.pod";
bcfe7366	119	$state{delta_version} = \@want;
d7816c47 NC	120
	121	# This way round so that keys can act as a MANIFEST skip list
	122	# Targets will always be in the pod directory. Currently we can only cope
	123	# with sources being in the same directory.
	124	$state{copies}{$state{delta_target}} = $source;
	125
0aef0fe5 NC	126	# The default flags if none explicitly set for the current file.
	127	my $current_flags = '';
	128	my (%flag_set, @paths);
d7816c47	129
0aef0fe5 NC	130	my $master = open_or_die('pod/perl.pod');
	131
	132	while (<$master>) {
	133	last if /^=begin buildtoc$/;
	134	}
	135	die "Can't find '=begin buildtoc':" if eof $master;
	136
	137	while (<$master>) {
	138	next if /^$/ or /^#/;
	139	last if /^=end buildtoc/;
	140	my ($command, @args) = split ' ';
	141	if ($command eq 'flag') {
	142	# For the named pods, use these flags, instead of $current_flags
	143	my $flags = shift @args;
	144	my_die("Malformed flag $flags")
	145	unless $flags =~ /\A=([a-z]*)\z/;
	146	$flag_set{$_} = $1 foreach @args;
	147	} elsif ($command eq 'path') {
	148	# If the pod's name matches the regex, prepend the given path.
	149	my_die("Malformed path for /$args[0]/")
	150	unless @args == 2;
	151	push @paths, [qr/\A$args[0]\z/, $args[1]];
	152	} elsif ($command eq 'aux') {
	153	# The contents of perltoc.pod's "AUXILIARY DOCUMENTATION" section
4e604983	154	$state{aux} = [sort @args];
0aef0fe5 NC	155	} else {
	156	my_die("Unknown buildtoc command '$command'");
	157	}
	158	}
d7816c47 NC	159
d7816c47 NC	160	foreach (<$master>) {
0aef0fe5 NC	161	next if /^$/ or /^#/;
	162	next if /^=head2/;
	163	last if /^=for buildtoc __END__$/;
	164
	165	if (my ($action, $flags) = /^=for buildtoc flag ([-+])([a-z]+)/) {
	166	if ($action eq '+') {
	167	$current_flags .= $flags;
	168	} else {
	169	my_die("Attempt to unset [$flags] failed - flags are '$current_flags")
	170	unless $current_flags =~ s/[\Q$flags\E]//g;
	171	}
	172	} elsif (my ($leafname, $desc) = /^\s+(\S+)\s+(.*)/) {
	173	my $podname = $leafname;
	174	my $filename = "pod/$podname.pod";
	175	foreach (@paths) {
	176	my ($re, $path) = @$_;
	177	if ($leafname =~ $re) {
	178	$podname = $path . $leafname;
	179	$filename = "$podname.pod";
	180	last;
	181	}
	182	}
	183
	184	# Keep this compatible with pre-5.10
	185	my $flags = delete $flag_set{$leafname};
	186	$flags = $current_flags unless defined $flags;
	187
	188	my %flags;
d7816c47	189	$flags{toc_omit} = 1 if $flags =~ tr/o//d;
dc437300	190	$flags{dual} = $podname ne $leafname;
d7816c47 NC	191
	192	$state{generated}{"$podname.pod"}++ if $flags =~ tr/g//d;
	193
	194	if ($flags =~ tr/r//d) {
	195	my $readme = $podname;
	196	$readme =~ s/^perl//;
64587559	197	$state{readmes}{$readme} = $desc;
d7816c47	198	$flags{readme} = 1;
d7816c47 NC	199	} else {
	200	$state{pods}{$podname} = $desc;
	201	}
	202	my_die "Unknown flag found in section line: $_" if length $flags;
449e2f79	203
d7816c47	204	push @{$state{master}},
2ce3647c	205	[$leafname, $filename, \%flags];
0aef0fe5 NC	206
	207	if ($podname eq 'perldelta') {
	208	local $" = '.';
0aef0fe5	209	push @{$state{master}},
2ce3647c	210	[$delta_leaf, "pod/$state{delta_target}"];
dc437300	211	$state{pods}{$delta_leaf} = "Perl changes in version @want";
0aef0fe5 NC	212	}
0aef0fe5 NC	213
d7816c47	214	} else {
0aef0fe5	215	my_die("Malformed line: $_");
d7816c47 NC	216	}
d7816c47 NC	217	}
0aef0fe5 NC	218	close $master or my_die("close pod/perl.pod: $!");
	219
	220	my_die("perl.pod sets flags for unknown pods: "
	221	. join ' ', sort keys %flag_set)
	222	if keys %flag_set;
9887f448 NC	223	}
	224
	225	sub get_pod_metadata {
	226	# Do we expect to find generated pods on disk?
	227	my $permit_missing_generated = shift;
	228	# Do they want a consistency report?
	229	my $callback = shift;
d7816c47	230
9887f448	231	__prime_state() unless $state{master};
d4c6b7ae NC	232	return \%state unless $callback;
d4c6b7ae NC	233
9887f448 NC	234	my %BuildFiles;
	235
	236	foreach my $path (@_) {
	237	$path =~ m!([^/]+)$!;
	238	++$BuildFiles{$1};
	239	}
	240
d7816c47 NC	241	# Sanity cross check
d7816c47 NC	242
0aef0fe5	243	my (%disk_pods, %manipods, %manireadmes);
852355fc	244	my (%cpanpods, %cpanpods_leaf);
d7816c47 NC	245	my (%our_pods);
	246
	247	# These are stub files for deleted documents. We don't want them to show up
	248	# in perl.pod, they just exist so that if someone types "perldoc perltoot"
	249	# they get some sort of pointer to the new docs.
	250	my %ignoredpods
	251	= map { ( "$_.pod" => 1 ) } qw( perlboot perlbot perltooc perltoot );
	252
	253	# Convert these to a list of filenames.
64587559 NC	254	++$our_pods{"$_.pod"} foreach keys %{$state{pods}};
64587559 NC	255	foreach (@{$state{master}}) {
2ce3647c NC	256	++$our_pods{"$_->[0].pod"}
2ce3647c NC	257	if $_->[2]{readme};
d7816c47 NC	258	}
	259
	260	opendir my $dh, 'pod';
	261	while (defined ($_ = readdir $dh)) {
	262	next unless /\.pod\z/;
d7816c47 NC	263	++$disk_pods{$_};
	264	}
	265
	266	# Things we copy from won't be in perl.pod
	267	# Things we copy to won't be in MANIFEST
	268
	269	my $mani = open_or_die('MANIFEST');
	270	while (<$mani>) {
	271	chomp;
	272	s/\s+.*$//;
	273	if (m!^pod/([^.]+\.pod)!i) {
6fdb59a5	274	++$manipods{$1};
d7816c47 NC	275	} elsif (m!^README\.(\S+)!i) {
d7816c47 NC	276	next if $state{ignore}{$1};
6fdb59a5	277	++$manireadmes{"perl$1.pod"};
d7816c47	278	} elsif (exists $our_pods{$_}) {
852355fc NC	279	++$cpanpods{$_};
	280	m!([^/]+)$!;
	281	++$cpanpods_leaf{$1};
d7816c47 NC	282	$disk_pods{$_}++
	283	if -e $_;
	284	}
	285	}
	286	close $mani or my_die "close MANIFEST: $!\n";
	287
c26a697b NC	288	# Are we running before known generated files have been generated?
	289	# (eg in a clean checkout)
	290	my %not_yet_there;
	291	if ($permit_missing_generated) {
	292	# If so, don't complain if these files aren't yet in place
	293	%not_yet_there = (%manireadmes, %{$state{generated}}, %{$state{copies}})
	294	}
	295
d7816c47 NC	296	my @inconsistent;
	297	foreach my $i (sort keys %disk_pods) {
	298	push @inconsistent, "$0: $i exists but is unknown by buildtoc\n"
	299	unless $our_pods{$i};
	300	push @inconsistent, "$0: $i exists but is unknown by MANIFEST\n"
9e241592 NC	301	if !$BuildFiles{'MANIFEST'} # Ignore if we're rebuilding MANIFEST
	302	&& !$manipods{$i} && !$manireadmes{$i} && !$state{copies}{$i}
	303	&& !$state{generated}{$i} && !$cpanpods{$i};
d7816c47 NC	304	}
	305	foreach my $i (sort keys %our_pods) {
	306	push @inconsistent, "$0: $i is known by buildtoc but does not exist\n"
c26a697b	307	unless $disk_pods{$i} or $BuildFiles{$i} or $not_yet_there{$i};
d7816c47	308	}
9e241592 NC	309	unless ($BuildFiles{'MANIFEST'}) {
	310	# Again, ignore these if we're about to rebuild MANIFEST
	311	foreach my $i (sort keys %manipods) {
	312	push @inconsistent, "$0: $i is known by MANIFEST but does not exist\n"
	313	unless $disk_pods{$i};
	314	push @inconsistent, "$0: $i is known by MANIFEST but is marked as generated\n"
	315	if $state{generated}{$i};
	316	}
d7816c47	317	}
d4c6b7ae	318	&$callback(@inconsistent);
d7816c47 NC	319	return \%state;
	320	}
	321
	322	1;
	323
	324	# Local variables:
	325	# cperl-indent-level: 4
	326	# indent-tabs-mode: nil
	327	# End:
	328	#
	329	# ex: set ts=8 sts=4 sw=4 et: