#!/usr/bin/perl

use strict;
our $verbose = 0;

sub pod_files ($) {
	my $dir = shift;
	my %files; our %seen;
	my $wanted = sub {
		return unless /\.(?:pod|pm)\z/;
		return unless -f;
		$seen{$_}++ or $files{$_}++;
	};
	use File::Find qw(find);
	find { no_chdir => 1, wanted => $wanted } => $dir;

	# when both $_.pod and $_.pm are present, ignore $_.pm
	for (map { /(.+)\./ } keys %files) {
		if (exists $files{"$_.pod"} and exists $files{"$_.pm"}) {
			warn "$_.pod and $_.pm both exist, ignoring pm\n"
				if $verbose > 1;
			delete $files{"$_.pm"};
		}
	}
	return [ sort keys %files ];
}	

sub find_pods () {
	use Config qw(%Config);
	my @dirs = @Config{qw{ privlib archlib vendorlib vendorarch }};
	@dirs = sort { length($b) <=> length($a) } @dirs;
	return map { $_ => pod_files($_) } @dirs;
}

sub guess_name ($$) {
	my ($dir, $f) = @_;
	$f =~ m#/(perl\w*)\.pod\z#
		and return ($1, 1);
	$f =~ s#\Q$dir/##
		or die "dir=$dir, f=$f, no match\n";
	$f =~ s#\.pm\z## or $f =~ s#\.pod\z##
		or die "f=$f, bad suffix\n";
	$f =~ s#/#::#g;
	return ($f, "3pm");
}

sub has_pod ($) {
	my $f = shift;
	open my $fh, "<", $f
		or die "$f: $!\n";
	local $_;
	while (<$fh>) {
		return 1 if /^=head/;
	}
	warn "$f: no head section, skip\n"
		if $verbose > 1;
	return;
}

sub genpage ($$) {
	my ($f, $dest) = @_;
	my $gz = "$dest.gz";

	require RPM::Database;
	our $rpmdb ||= RPM::Database->new
		or die $RPM::err;
	my @release;
	if (my ($pkg) = $rpmdb->find_by_file($f)) {
		my $name;
		if ($$pkg{URL} =~ m#search[.]cpan[.]org/dist/([^/]+)#) {
			$name = $1;
		}
		else {
			$name = $$pkg{SOURCERPM};
			$name =~ s/\Q-$$pkg{VERSION}-\E.*//;
			$name =~ s/^perl-//;
		}
		@release = (release => "$name $$pkg{VERSION}")
			if $name and $name ne "perl";
	}

	require Pod::Man;
	my $parser = Pod::Man->new(center => "Perl Programmer's Manual", @release);
	$parser->parse_from_file($f, $dest)
		or die "pod2man failed\n";
	system("gzip", "-9nf", $dest) == 0
		or die "gzip failed\n";
	my @stamp = (stat $f)[8,9] 
		or die "stat $f: $!\n";
	utime @stamp => "$gz"
		or die "utime $gz: $!\n";
}

sub do_gen ($) {
	my $mandir = shift;
	my @mandir = ("$mandir/man1", "$mandir/man3");
	my @pods = find_pods;
	my %pages;
	while (my ($dir, $files) = splice(@pods, 0, 2)) {
		foreach my $f (@$files) {
			my ($name, $section) = guess_name($dir, $f);
			my $destdir = $section eq 1 ? $mandir[0] : $mandir[1];
			my $dest = "$destdir/$name.$section";
			my $gz = "$dest.gz";
			
			if ($pages{$gz}) {
				warn "$f: page $gz already generated for $pages{$gz}\n"
					if $verbose > 1;
				next;
			}
			if (-f $gz and -M $f == -M $gz) {
				warn "$f: $gz is up to date"
					if $verbose > 1;
				$pages{$gz} = $f;
				next;
			}
			next unless has_pod($f);

			warn "$f -> $gz\n" if $verbose;
			genpage($f, $dest);
			$pages{$gz} = $f;
		}
	}
	for my $f (map { glob "$_/*.gz" } @mandir) {
		next if $pages{$f};
		warn "unlink $f\n" if $verbose;
		unlink $f or die "unlink $f: $!\n";
	}
}

sub usage ($) {
	my $rc = shift;
	print { $rc ? *STDERR : *STDOUT } <<__EOF__;
$0 - generate manual pages for all perl modules and pod files
Usage:
	$0 [-v|--verbose] MANDIR
__EOF__
	exit $rc;
}

use Getopt::Long 2.24 qw(GetOptions :config gnu_getopt);
GetOptions
	"h|help"	=> \my $help,
	"v|verbose+"	=> \$verbose
		or usage 2;
usage 0 if $help;
usage 2 unless @ARGV == 1;

my $mandir = shift;
do_gen($mandir);
