path: root/gnu/usr.bin/perl/BSDPAN/ExtUtils/Packlist.pm

# ----------------------------------------------------------------------------
# "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
# ----------------------------------------------------------------------------
#
# $FreeBSD$
#
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) = 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;
	}
	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($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|/[^/]+$||;
		$alldirs{$file}++ if -d $file;
	}

	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);
}

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>) {
		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);
}

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