config root man

# ----------------------------------------------------------------------------
# "THE BEER-WARE LICENSE" (Revision 42)
# <tobez@tobez.org> wrote this file.  As long as you retain this notice you
# can do whatever you want with this stuff. If we meet some day, and you think
# this stuff is worth it, you can buy me a beer in return.   Anton Berezin
# ----------------------------------------------------------------------------
#
# $Id: Packlist.pm,v 1.3 2006/02/15 09:42:44 tobez Exp $
#
package BSDPAN::ExtUtils::Packlist;
#
# The pod documentation for this module is at the end of this file.
#
use strict;
use Carp;
use Fcntl;
use BSDPAN;
use BSDPAN::Override;

sub write {
	my $orig = shift;	# original ExtUtils::Packlist::write
	my $him = $_[0];	# ExtUtils::Packlist object

	# If it is a reference to a tied hash, obtain the underlying
	# ExtUtils::Packlist object
	$him = tied(%$him) || $him;

	# call the original write() with all parameters intact
	&$orig;

	# do nothing if p5- port is being built
	return if BSDPAN->builds_port;

	print "FreeBSD: Registering installation in the package database\n";

	my ($pkg_name,$pkg_comment,$pkg_descr,$distname) = gather_pkg_info($him);

	my ($ok, $comment_file, $descr_file, $packinglist_file);
	TRY: {
		last TRY unless $pkg_name;

		$comment_file = write_tmp_file($him, $pkg_comment);
		last TRY unless $comment_file;

		my $descr_file   = write_tmp_file($him, $pkg_descr);
		last TRY unless $descr_file;

		my @files = sort { $a cmp $b } get_file_list($him);
		my @dirs  = sort { length($b) <=> length ($a) }
		    get_dir_list($him, @files);

		my @packinglist;
		push @packinglist, "\@name $pkg_name\n", "\@cwd /\n";
		push @packinglist,
		    "\@comment This package was generated by BSDPAN\n";
		push @packinglist, "$_\n"
		    for @files;
		push @packinglist, "\@unexec rmdir $_ 2>/dev/null || true\n"
		    for @dirs;

		my $packinglist_file = write_tmp_file($him, join '', @packinglist);
		last TRY unless $packinglist_file;

		my $contents = `/usr/sbin/pkg_create -O -f $packinglist_file -c $comment_file -d $descr_file $pkg_name`;
		unless (($? >> 8) == 0) {
			warn("pkg_create exited with code " .
			    int($? >> 8) . "\n");
			last TRY;
		}

		my $pkg_db_dir = $ENV{'PKG_DBDIR'} // '/var/db/pkg';
		my $pkg_dir = "$pkg_db_dir/$pkg_name";
		unless (mkdir($pkg_dir, 0777)) {
			warn("Cannot create directory $pkg_dir: $!\n");
			last TRY;
		}

		write_file($him, "$pkg_dir/+CONTENTS", $contents) or last TRY;
		write_file($him, "$pkg_dir/+COMMENT", $pkg_comment) or last TRY;
		write_file($him, "$pkg_dir/+DESC", $pkg_descr) or last TRY;
		$ok = 1;

		if ($ENV{P5PORTER} && -d $ENV{P5PORTER} && -r _ && -w _) {
			require YAML;
			my $cfg = "$ENV{P5PORTER}/$distname.cfg";
			my $C = {};
			if (-f $cfg && -r _) {
				if (open my $fh, '<', $cfg) {
					local $/;
					my $yaml = <$fh>;
					$C = YAML::Load($yaml);
					close $fh;
				}
			}
			$C->{comment} = $pkg_comment;  chomp $C->{comment};
			$C->{files} = \@files;
			$C->{dirs} = \@dirs;
			$C->{description} = $pkg_descr;
			if (open my $fh, '>', $cfg) {
				print $fh YAML::Dump($C);
				close $fh;
			}
			make_port_template($C);
		}
	}
	unlink $descr_file if $descr_file;
	unlink $comment_file if $comment_file;
	unlink $packinglist_file if $packinglist_file;
}

sub write_file {
	my ($him, $pathname, $contents) = @_;

	my $fh = ExtUtils::Packlist::mkfh();

	unless (open(my $fh, '>', $pathname)) {
		carp("Cannot create file $pathname: $!");
		return;
	}
	print $fh $contents;
	close($fh);
	return 1;
}

sub write_tmp_file {
	my ($him, $contents) = @_;

	my $fh = ExtUtils::Packlist::mkfh();
	my $cnt = 0;
	my $pathname;

	until (defined(fileno($fh)) || $cnt > 20) {
		my $rnd = int(1000000 * rand);
		my $file = sprintf("packlist.%06d", $rnd);

		if (exists($ENV{PKG_TMPDIR}) &&
		    $ENV{PKG_TMPDIR} =~ "^/" &&
		    -d $ENV{PKG_TMPDIR}) {
			$pathname = "$ENV{PKG_TMPDIR}/$file";
			sysopen($fh, $pathname, O_WRONLY|O_EXCL|O_CREAT);
		}

		if (!defined(fileno($fh)) &&
		    exists($ENV{TMPDIR}) &&
		    $ENV{TMPDIR} =~ "^/" &&
		    -d $ENV{TMPDIR}) {
			$pathname = "$ENV{TMPDIR}/$file";
			sysopen($fh, $pathname, O_WRONLY|O_EXCL|O_CREAT);
		}

		if (!defined(fileno($fh)) &&
		    -d "/var/tmp") {
			$pathname = "/var/tmp/$file";
			sysopen($fh, $pathname, O_WRONLY|O_EXCL|O_CREAT);
		}

		if (!defined(fileno($fh)) &&
		    -d "/tmp") {
			$pathname = "/tmp/$file";
			sysopen($fh, $pathname, O_WRONLY|O_EXCL|O_CREAT);
		}

		if (!defined(fileno($fh)) &&
		    -d "/usr/tmp") {
			$pathname = "/usr/tmp/$file";
			sysopen($fh, $pathname, O_WRONLY|O_EXCL|O_CREAT);
		}
		$cnt++;
	}

	unless (defined fileno $fh) {
		carp("Can't create temporary file\n");
		return;
	}

	print $fh $contents;
	close($fh);
	return $pathname;
}

sub get_file_list {
	my ($him) = @_;

	my @files = ($him->{packfile});

	foreach my $key (keys(%{$him->{data}})) {
		push @files, $key if -f $key;
	}

	return @files;
}

sub get_dir_list {
	my ($him,@files) = @_;

	my %alldirs;

	for my $file (@files) {
		$file =~ s|/[^/]+$||;
		while (-d $file) {
			$file =~ s|/([^/]+)$||;
			my $last = $1;
			last if $last eq "bin";
			last if $last eq "auto";
			last if $last eq "man1";
			last if $last eq "man3";
			last if $last eq "site_perl";
			last if $last eq "mach";
			last if $last =~ /^[\d.]+$/;
			$alldirs{"$file/$last"}++;
		}
	}

	delete $alldirs{'/'};
	return keys %alldirs;
}

sub gather_pkg_info {
	my ($him) = @_;

	my ($distname, $version, $main_module) = get_makefile_pieces($him);
	return unless $distname;

	my $pkg_name = "bsdpan-$distname-$version";
	my ($comment, $descr) = get_description($him,$main_module);
	return ($pkg_name,$comment,$descr,$distname);
}

sub get_makefile_pieces {
	my ($him) = @_;

	my $fh = ExtUtils::Packlist::mkfh();
	unless (open($fh, '<', 'Makefile')) {
		carp("Can't open file Makefile: $!");
		return;
	}

	my ($distname,$version,$main_module);
	while (<$fh>) {
		/^DISTNAME\s*=\s*(\S+)\s*$/       and $distname = $1;
		/^VERSION\s*=\s*(\S+)\s*$/        and $version = $1;
		/^VERSION_FROM\s*=\s*(\S+)\s*$/   and $main_module = $1;
	}

	close($fh);

	$main_module = guess_main_module($him) unless defined $main_module;

	if (defined $distname &&
	    defined $version  &&
	    defined $main_module) {
		return ($distname,$version,$main_module);
	}
}

sub guess_main_module {
	my ($him) = @_;

	my @pm;

	for my $key (keys(%{$him->{data}})) {
		push @pm, $key if $key =~ /\.pm$/;
	}

	if (@pm == 0) {
		return undef;
	} elsif (@pm == 1) {
		return $pm[0];
	} else {
		return (sort { length($a) <=> length($b) } @pm)[0];
	}
}

sub get_description {
	my ($him,$file) = @_;

	my $fh = ExtUtils::Packlist::mkfh();
	unless (open($fh, '<', $file)) {
		carp("Can't open file $file: $!");
		return;
	}

	my ($comment, $descr);
	$descr = '';
	my $state = 'seek-head';

	while (<$fh>) {
		s/\r//g;
		if (/^=head1\s+(.*)$/) {
			if ($1 eq 'NAME') {
				$state = 'get-comment';
			} elsif ($1 eq 'DESCRIPTION') {
				$state = 'get-description';
			} else {
				$state = 'seek-head';
			}
		} elsif ($state eq 'get-comment') {
			next if /^$/;
			next if /^=/;
			$comment = $_;
			$state = 'seek-head';
		} elsif ($state eq 'get-description') {
			next if /^=/;
			next if /^$/ && $descr eq '';
			if (/^$/) {
				$state = 'seek-head';
			} else {
				$descr .= $_;
			}
		}
	}

	close($fh);

	unless ($comment) {
		print "FreeBSD: Cannot determine short module description\n";
		$comment = 'Unknown perl module';
	}

	unless ($descr) {
		print "FreeBSD: Cannot determine module description\n";
		$descr = 'There is no description for the perl module';
	}

	return ($comment, $descr);
}

sub make_port_template
{
	my ($C) = @_;

	my (@files, @man3, @dirs);

	# massage files
	for my $file (@{$C->{files}}) {
		$_ = $file;
		if (m!/man/man3/([^/]+\.3)$!) {
			push @man3, $1;
		} else {
			s|^.*/perl5/site_perl/[\d.]+/|%%SITE_PERL%%/|;
			s|(_PERL%%)/mach/|$1/%%PERL_ARCH%%/|;
			push @files, $_;
		}
	}

	# massage dirs
	for my $dir (@{$C->{dirs}}) {
		$_ = $dir;
		if (m!/man/man3$!) {
			# skip
		} else {
			s|^.*/perl5/site_perl/[\d.]+/|%%SITE_PERL%%/|;
			s|(_PERL%%)/mach/|$1/%%PERL_ARCH%%/|;
			push @dirs, "\@dirrmtry $_";
		}
	}

	my $dir = "$ENV{P5PORTER}/p5-$C->{portname}";
	mkdir $dir;

	if (open my $fh, '>', "$dir/pkg-descr") {
		print $fh $C->{description};
		print $fh "\nWWW: http://search.cpan.org/dist/$C->{portname}\n";
		close $fh;
	} else {
		print "BSDPAN: error creating $dir/pkg-descr: $!\n";
	}

	if (open my $fh, '>', "$dir/pkg-plist") {
		for (@files) {
			print $fh "$_\n";
		}
		for (@dirs) {
			print $fh "$_\n";
		}
		close $fh;
	} else {
		print "BSDPAN: error creating $dir/pkg-plist: $!\n";
	}

	require Template;
	my $tt = Template->new(ABSOLUTE => 1);
	my $tt_vars = {%$C};
	$tt_vars->{man3} = join " \\\n\t", sort @man3;
	my $output = "";
	$tt->process("$ENV{P5PORTER}/Makefile.skeleton", $tt_vars, \$output) or $output = "ERROR: " . $tt->error;
	if (open my $fh, '>', "$dir/Makefile") {
		print $fh $output;
		close $fh;
	} else {
		print "BSDPAN: error creating $dir/Makefile: $!\n";
	}

	print "BSDPAN: port template created in $dir\n";
	print "BSDPAN: please carefully review it before submitting\n";
	print "BSDPAN: edit pkg-plist and use your judgement for rmdir/unexec alternatives\n";
	print "BSDPAN: also remember that some of the dependencies might be missing\n";
	print "BSDPAN: don't forget to test the port with different perls\n";
}

BEGIN {
	override 'write', \&write;
}

1;
=head1 NAME

BSDPAN::ExtUtils::Packlist - Override ExtUtils::Packlist functionality

=head1 SYNOPSIS

   None

=head1 DESCRIPTION

BSDPAN::ExtUtils::Packlist overrides write() sub of the standard perl
module ExtUtils::Packlist.

The overridden write() first calls the original write().  Then,
if the Perl port build is detected, it returns quietly.

If, however, the Perl module being built is not a port, write()
obtains the list of installed files that ExtUtils::Packlist internally
maintains.  Then it tries to deduce the distname, the version, and the
name of the main F<.pm> file.  Then it scans the F<*.pm> files that
constite the module, trying to find what to use as the module comment
(short description) and the description.

After gathering all this information, the overridden write() invokes
pkg_create(1), hereby registering the module with FreeBSD package
database.

If any of the above steps is unsuccessful, BSDPAN::ExtUtils::Packlist
quietly returns, with the result which is equivalent to pre-BSDPAN
functionality.

=head1 AUTHOR

Anton Berezin, tobez@tobez.org

=head1 SEE ALSO

perl(1), L<BSDPAN(3)>, L<BSDPAN::Override(3)>, pkg_create(1).

=cut