Start of big rewrite of pkg tweaking.

The current setup is only really good for modifying PKGBUILD fields. The
modification of PKGBUILD funcs is hackish. Instead, the tweaks will be
written in a scripting language (like Io) where both PKGBUILD fields
and function code can be easily modified.

Fields should be able to be modified just like arrays, but with easier
package matching going on. PKGBUILD bash functions are simply arrays
of lines, but they are not as sophisticated. Instead they can only be
appended to.

Package files are represented as trees. Each file (PKGBUILD pkg.install)
is a child of the top-level node of the tree. Each child of the file
node is a section of the file (intro, body, end). Each section can
also have its own intro, body, and end node. In this way each bash
function is a node with its own intro, body, and end node. Prepending
to a function appends to its intro node. Appending to a function appends
to its end child node. The body cannot be modified.

1 files changed, 136 insertions, 108 deletions

diff --git a/metas/perl.d/perl-dist b/metas/perl.d/perl-dist
index 312b14a..99d187b 100755
--- a/metas/perl.d/perl-dist
+++ b/metas/perl.d/perl-dist
@@ -4,6 +4,7 @@ use warnings 'FATAL' => 'all';
 use strict;
 
 my $PROG = 'metas/perl.d/perl-dist';
+my $FUNCPROG = 'perl-dist-funcs';
 
 sub DBG {}
 if(exists $ENV{'GENDBG'}){
@@ -43,20 +44,20 @@ my %OVERRIDE =
 
 sub dist2pkg
 {
-	my ($name, $ver) = @_;
+	my($name, $ver) = @_;
 	return dist_pkgname($name), dist_pkgver($ver);
 }
 
 # Copied from CPANPLUS::Dist::Arch
 sub dist_pkgname
 {
-	my ($distname) = @_;
+	my($distname) = @_;
 
-	return $OVERRIDE{$distname} if(exists($OVERRIDE{$distname}));
+	return $OVERRIDE{$distname} if(exists $OVERRIDE{$distname});
 
 	# Package names should be lowercase and consist of alphanumeric
 	# characters only (and hyphens!)...
-	$distname = lc($distname);
+	$distname = lc $distname;
 	$distname =~ tr/_+/--/;
 	$distname =~ tr/-a-z0-9//cd; # Delete all other chars
 	$distname =~ tr/-/-/s;
@@ -66,7 +67,7 @@ sub dist_pkgname
 	$distname =~ s/-\z//;
 
 	die qq{Dist name '$distname' completely violates packaging standards}
-		if(length($distname) == 0);
+		if(length $distname == 0);
 
 	# Don't prefix the package with perl- if it IS perl...
 	$distname = "perl-$distname" unless($distname eq 'perl');
@@ -76,7 +77,7 @@ sub dist_pkgname
 
 sub dist_pkgver
 {
-	my ($version) = @_;
+	my($version) = @_;
 
 	# Remove developer versions because pacman has no special logic
 	# to handle comparing them to regular versions such as perl uses.
@@ -96,7 +97,7 @@ sub dist_pkgver
 # Decide if the dist. is named after the module.
 sub _ismainmod
 {
-	my ($mod_name, $dist_name) = @_;
+	my($mod_name, $dist_name) = @_;
 
 	$mod_name =~ tr/:/-/s;
 	return lc($mod_name) eq lc($dist_name);
@@ -106,11 +107,11 @@ sub _ismainmod
 # Merges the right-hand deps into the left-hand deps.
 sub _merge
 {
-	my ($left_deps, $right_deps) = @_;
+	my($left_deps, $right_deps) = @_;
 
 	MERGE_LOOP:
-	while(my ($pkg, $ver) = each(%$right_deps)) {
-		if($left_deps->{$pkg}) {
+	while(my($pkg, $ver) = each %$right_deps){
+		if($left_deps->{$pkg}){
 			my $leftver = version->parse($left_deps->{$pkg});
 			my $rightver = version->parse($ver);
 			next MERGE_LOOP if $leftver > $rightver;
@@ -125,10 +126,10 @@ sub _merge
 # Merge duplicate deps into $left always storing the greatest version there.
 sub _mergedups
 {
-	my ($left, $right) = @_;
+	my($left, $right) = @_;
 
-	for my $name (keys %$left) {
-		my $rver = delete($right->{$name}) or next;
+	for my $name (keys %$left){
+		my $rver = delete $right->{$name} or next;
 		my $lver = $left->{$name};
 		my $lvo = ($lver ? version->parse($lver) : 0);
 		my $rvo = ($rver ? version->parse($rver) : 0);
@@ -140,12 +141,12 @@ sub _mergedups
 
 sub _filterdeps(&$)
 {
-	my ($fsub, $deps) = @_;
+	my($fsub, $deps) = @_;
 	my %fed;
 
 	my @pkgs = keys(%$deps);
 	for my $dname (grep { $fsub->() } @pkgs){
-		my $dver = delete($deps->{$dname});
+		my $dver = delete $deps->{$dname};
 		$fed{$dname} = $dver if(defined $dver);
 	}
 
@@ -163,7 +164,7 @@ sub _yankcheckers
 # form that the official ArchLinux perl package uses.
 sub _perldepver
 {
-	my ($perlver) = @_;
+	my($perlver) = @_;
 
 	# Fix perl-style vstrings which have a leading "v".
 	return $perlver if($perlver =~ s/\Av//);
@@ -171,7 +172,7 @@ sub _perldepver
 
 	# Re-apply the missing trailing zeroes.
 	my $patch = $3;
-	$patch .= q{0} x (3 - length($patch));
+	$patch .= q{0} x (3 - length $patch);
 	return sprintf('%d.%d.%d', $1, $2, $patch);
 }
 
@@ -179,8 +180,8 @@ sub _perldepver
 # Translates CPAN module dependencies into ArchLinux package dependencies.
 sub _reqs2deps
 {
-	my ($prereqs) = @_;
-	my (@mods, %pkgdeps);
+	my($prereqs) = @_;
+	my(@mods, %pkgdeps);
 
 	# Filter out deps on 'perl' and any core modules that we can.
 	while(my ($name, $ver) = each(%$prereqs)) {
@@ -224,16 +225,17 @@ sub _reqs2deps
 
 sub prereqs
 {
-	my ($pkgname, $prereqs) = @_;
+	my($pkgname, $prereqs) = @_;
 
 	# maps perl names for different dependencies to ArchLinux's names
 	my %namemap = ('configure' => 'makedepends',
-				   'build' => 'makedepends',
-				   'test' => 'checkdepends',
-				   'runtime' => 'depends');
+	  'build' => 'makedepends',
+	  'test' => 'checkdepends',
+	  'runtime' => 'depends',
+	);
 
 	my %pkgdeps;
-	while (my ($perl, $arch) = each(%namemap)) {
+	while (my($perl, $arch) = each(%namemap)) {
 		my $reqs = $prereqs->{$perl}{'requires'};
 		my $deps; $deps = _reqs2deps($reqs) if($reqs);
 
@@ -248,14 +250,16 @@ sub prereqs
 	# ArchLinux now has a separate array for dependencies that we only
 	# need for checking (aka "testing"). Older perl METAs do not
 	# have this separated. Force any test modules to be checkdepends.
-	if(!$pkgdeps{'checkdepends'} && $pkgname !~ /\Aperl-test-/) {
+	if(!$pkgdeps{'checkdepends'} && $pkgname !~ /\Aperl-test-/){
 		my $checkdeps = {};
-		_merge($checkdeps, _yankcheckers($pkgdeps{$_})) for(qw/makedepends depends/);
+		for(qw/makedepends depends/){
+			_merge($checkdeps, _yankcheckers($pkgdeps{$_})) 
+		}
 		$pkgdeps{'checkdepends'} = $checkdeps;
 	}
 
 	# We at least require perl, if nothing else.
-	unless(grep { scalar(keys(%$_)) > 0 } values(%pkgdeps)) {
+	unless(grep { scalar keys %$_ > 0 } values %pkgdeps){
 		$pkgdeps{'depends'}{'perl'} = 0;
 	}
 
@@ -263,7 +267,7 @@ sub prereqs
 	_mergedups(@pkgdeps{'depends', 'makedepends'});
 
 	# Convert all deps into arrays of strings.
-	for my $deptype (keys(%pkgdeps)) {
+	for my $deptype (keys(%pkgdeps)){
 		$pkgdeps{$deptype} = _stringify($pkgdeps{$deptype});
 	}
 
@@ -273,13 +277,13 @@ sub prereqs
 #---HELPER FUNCTION---
 sub _stringify
 {
-	my ($deps) = @_;
+	my($deps) = @_;
 
 	my @depstrs;
-	for my $pkg (sort(keys(%$deps))) {
+	for my $pkg (sort keys %$deps){
 		my $ver = $deps->{$pkg};
 		my $str = ($ver eq '0' ? $pkg : "$pkg>=$ver");
-		push(@depstrs, $str);
+		push @depstrs, $str;
 	}
 
 	return \@depstrs;
@@ -287,21 +291,21 @@ sub _stringify
 
 sub _distsofmods
 {
-	my (@mods) = @_;
+	my(@mods) = @_;
 
 	return () if(@mods == 0);
 	@mods = _nocore(@mods);
 
 	my $var = _vardir();
-	open(my $fh, '<', "$var/cpanmods")
-		or die "$PROG: failed to open $var/cpanmods: $!";
+	open my $fh, '<', "$var/cpanmods"
+	  or die "$PROG: failed to open $var/cpanmods: $!";
 
 	my %mods = map { ($_ => 1) } @mods;
 	my %dists;
 	local $/ = '';
 
 	RECLOOP:
-	while(my $rec = <$fh>) {
+	while(my $rec = <$fh>){
 		last RECLOOP unless(keys %mods > 0);
 
 		my($dist, @mvs) = split(/\n/, $rec);
@@ -314,19 +318,17 @@ sub _distsofmods
 	}
 
 	my @lost = keys %mods;
-	if(@lost){
-		for my $m (@lost){
-			print STDERR "$PROG: failed to find module $m\n";
-		}
-		exit 1;
-	}
+	return %dists unless(@lost);
 
-	return %dists;
+	for my $m (@lost){
+		print STDERR "$PROG: failed to find module $m\n";
+	}
+	exit 1;
 }
 
 sub _nocore
 {
-	my (@mods) = @_;
+	my(@mods) = @_;
 
 	my $path = _vardir() . '/coremods';
 	unless(-f $path){
@@ -338,15 +340,15 @@ sub _nocore
 ";
 		exit 1;
 	}
-	open(my $if, '<', $path) or die "$PROG: open $path: $!";
+	open my $if, '<', $path or die "$PROG: open $path: $!";
 
 	my %mods = map { ($_ => 1) } @mods;
 	while(<$if>){
-		my ($m) = split;
+		my($m) = split;
 		delete $mods{$m};
 	}
 
-	close($if);
+	close $if;
 	return keys %mods;
 }
 
@@ -361,7 +363,7 @@ sub _vardir
 package main;
 
 use File::Basename qw(basename dirname);
-use File::Spec::Functions qw(catfile catdir);
+use File::Spec::Functions qw(catfile catdir rel2abs);
 use File::Find qw(find);
 
 use JSON::XS qw(decode_json); # for META.json
@@ -371,56 +373,79 @@ use Pod::Select (); # search POD for description
 use Digest::MD5 (); # for md5sums & sha512sums
 use Digest::SHA ();
 
+sub printdata
+{
+	my($pbvars) = @_;
+	print "options\n!emptydirs\n\n";
+	printmeta($pbvars);
+	return;
+}
+
+sub printfuncs
+{
+	my($ddir) = @_;
+	my $dtype = (-f "$ddir/Build.PL" ? "MB" : "MM");
+	exec $FUNCPROG => $dtype
+	  or die "$PROG: $FUNCPROG failed to execute!\n";
+}
+
 sub main
 {
-	my $distpath = shift() or die "Usage: $PROG [path to cpan dist file]\n";
+	my $distpath = shift or die "Usage: $PROG [path to cpan dist file]\n";
+	$distpath = rel2abs($distpath);
 	my $dir = dirname($distpath);
 	my $file = basename($distpath);
 	my $info = distinfo($file);
 
 	chsrcdir(catdir($dir, 'src'), $file);
-	$dir = extractdist($file);
+	my $distdir = extractdist($file);
 
-	my $meta = loadmeta($dir);
+	my $meta = loadmeta($distdir);
 	my $desc = $meta->{'abstract'};
-	if(!$desc || $desc eq '~' || $desc eq 'unknown') {
-		$meta->{'abstract'} = distdesc($dir, $info->{'mod'});
+	if(!$desc || $desc eq '~' || $desc eq 'unknown'){
+		$meta->{'abstract'} = distdesc($distdir, $info->{'mod'});
 	}
 
-	my ($name, $ver) = Convert::dist2pkg(@{$info}{'name', 'ver'});
+	my($name, $ver) = Convert::dist2pkg(@{$info}{'name', 'ver'});
 	my $deps = Convert::prereqs($name, $meta->{'prereqs'});
 
 	my %pbvars =
 		('pkgver'  => $ver,
 		 'pkgdesc' => $meta->{'abstract'},
-		 'arch' => (xsdist($dir) ? ['i686', 'x86_64'] : 'any'),
+		 'arch' => (xsdist($distdir) ? ['i686', 'x86_64'] : 'any'),
 		 'md5sums' => md5sums($file),
 		 'sha512sums' => sha512sums($file),
-		 'distdir' => $dir,
+		 'distdir' => $distdir,
 		 %$deps,
 		 );
 
-	# Since this is a perl distribution, use the perl-pkg template.
-	printf("template\nperl-pkg %s\n\n", (-f "$dir/Build.PL" ? "MB" : "MM"));
-	print("options\n!emptydirs\n\n");
+	print STDERR "DBG: \$dir = $dir\n";
+	chdir $dir or die "chdir: $!";
+
+	close STDOUT or die "close STDOUT: $!";
+	open STDOUT, '>', 'PKGDATA' or die "open PKGDATA: $!";
+	printdata(\%pbvars);
 
-	printmeta(\%pbvars);
-	return 0;
+	close STDOUT or die "close STDOUT: $!";
+	open STDOUT, '>', 'PKGFUNC', or die "open PKGFUNC: $!";
+	exit printfuncs($dir);
 }
 
 # Create the src/ directory and tarball symlink. Then chdir into it.
 
 sub chsrcdir
 {
-	my ($srcdir, $distfile) = @_;
+	my($srcdir, $distfile) = @_;
 
-	if (-e $srcdir) {
-		system("rm", "-fr", $srcdir) == 0 or die "failed to rm $srcdir\n";
+	if(-e $srcdir){
+		system 'rm' => ('-fr', $srcdir);
+		die "failed to rm $srcdir\n" unless($? == 0);
 	}
 	mkdir $srcdir or die "mkdir $srcdir: $!";
-	chdir($srcdir) or die "chdir $srcdir: $!";
+	chdir $srcdir or die "chdir $srcdir: $!";
 	unless(-f $distfile) {
-		symlink(catfile('..', $distfile), $distfile) or die "symlink $distfile: $!";
+		symlink(catfile('..', $distfile), $distfile)
+		  or die "symlink $distfile: $!";
 	}
 
 	return $srcdir;
@@ -428,11 +453,11 @@ sub chsrcdir
 
 sub distinfo
 {
-	my ($distfile) = @_;
+	my($distfile) = @_;
 
-	my @c = split(/-/, $distfile);
-	my $ver = pop(@c);
-	my $name = join(q{-}, @c);
+	my @c = split /-/, $distfile;
+	my $ver = pop @c;
+	my $name = join q{-}, @c;
 	my $mod = $name;
 	$mod =~ s/-/::/g;
 	return { 'name' => $name, 'ver' => $ver, 'mod' => $mod };
@@ -440,53 +465,52 @@ sub distinfo
 
 sub extractdist
 {
-	my ($file) = @_;
+	my($file) = @_;
 
-	system("bsdtar -xf $file");
+	system 'bsdtar' => ('-xf', $file);
 	die "$PROG: bsdtar failed to extract $file\n" unless($? == 0);
 
-	opendir(my $srcdir, '.') or die "opendir: $!";
-	my @dirs = grep { -d $_ && !/\A[.]/ } readdir($srcdir);
-	closedir($srcdir);
+	opendir my $srcdir, '.' or die "opendir: $!";
+	my @dirs = grep { -d $_ && !/\A[.]/ } readdir $srcdir;
+	closedir $srcdir;
 
-	die("$PROG: many dirs (@dirs) inside the tarball $file\n")
-		if(@dirs > 1);
-	die("$PROG: no dirs found in tarball $file\n") if(@dirs == 0);
+	die "$PROG: many dirs (@dirs) inside the tarball $file\n" if(@dirs > 1);
+	die "$PROG: no dirs found in tarball $file\n" if(@dirs == 0);
 	return $dirs[0];
 }
 
 sub printmeta
 {
-	my ($pbvars) = @_;
-	while(my ($name, $val) = each(%$pbvars)) {
-		if(!defined($val) || $val eq q{}) {
-			warn("$PROG: warning: $name is undefined\n");
+	my($pbvars) = @_;
+	while(my($name, $val) = each %$pbvars) {
+		if(!defined $val || $val eq q{}) {
+			warn "$PROG: warning: $name is undefined\n";
 			$val = q{};
 		}
-		print($name, "\n");
-		print("$_\n") for (ref $val ? @$val : $val);
-		print("\n");
+		print $name, "\n";
+		print "$_\n" for (ref $val ? @$val : $val);
+		print "\n";
 	}
 
 	# TODO: autodetect license type
-	printf("license\n%s\n\n", join("\n", qw/PerlArtistic GPL/));
+	printf("license\n%s\n\n", join "\n", qw/PerlArtistic GPL/);
 }
 
 sub loadmeta
 {
-	my ($distdir) = @_;
+	my($distdir) = @_;
 
-	for my $metaext (qw/json yml/) {
+	for my $metaext (qw/json yml/){
 		my $path = "$distdir/META.$metaext";
-		next unless -f $path;
+		next unless(-f $path);
 
-		open(my $metafh, '<', $path) or die "open: $!";
+		open my $metafh, '<', $path or die "open: $!";
 		my $meta = do { local $/; <$metafh> };
-		close($metafh);
+		close $metafh;
 
 		$meta = ($metaext eq 'json' ? decode_json($meta) :
-			$metaext eq 'yml' ? YAML::XS::Load($meta) :
-			die "internal error: unknown \$metaext: $metaext");
+		  $metaext eq 'yml' ? YAML::XS::Load($meta) :
+		  die "internal error: unknown \$metaext: $metaext");
 
 		upgrademeta($meta);
 		return $meta;
@@ -497,12 +521,13 @@ sub loadmeta
 
 sub upgrademeta
 {
-	my ($meta) = @_;
+	my($meta) = @_;
 
-	return if(exists($meta->{'prereqs'}));
+	return if(exists $meta->{'prereqs'});
 
 	my $prereqs;
-	$prereqs->{'configure'}{'requires'} = delete($meta->{'configure_requires'});
+	$prereqs->{'configure'}{'requires'}
+	  = delete $meta->{'configure_requires'};
 	$prereqs->{'build'}{'requires'} = delete($meta->{'build_requires'});
 	$prereqs->{'runtime'}{'requires'} = delete($meta->{'requires'});
 
@@ -512,9 +537,10 @@ sub upgrademeta
 
 sub xsdist
 {
-	my ($dir) = @_;
+	my($dir) = @_;
 	my $isxs;
-	find({ 'wanted' => sub { $isxs = 1 if(/[.]xs$/) }, 'no_chdir' => 1 }, $dir);
+	find({ 'wanted' => sub { $isxs = 1 if(/[.]xs$/) }, 'no_chdir' => 1 },
+	  $dir);
 	return $isxs;
 }
 
@@ -522,13 +548,13 @@ sub xsdist
 
 sub distdesc
 {
-	my ($dir, $modname) = @_;
+	my($dir, $modname) = @_;
 	return _poddesc($dir, $modname) || _readmedesc($dir, $modname);
 }
 
 sub _poddesc
 {
-	my ($dir, $modname) = @_;
+	my($dir, $modname) = @_;
 
 	my $podselect = Pod::Select->new;
 	$podselect->select('NAME');
@@ -544,18 +570,18 @@ sub _poddesc
 	my @possible = glob("$dir/{lib/,}{$moddir/,}$modfile.{pod,pm}");
 
 	PODSEARCH:
-	for my $podpath (@possible) {
+	for my $podpath (@possible){
 		next PODSEARCH unless(-f $podpath);
 
 		# Read the NAME section of the POD into a scalar.
 		my $namesect = q{};
-		open(my $podfile, '<', $podpath) or next PODSEARCH;
-		open(my $podout, '>', \$namesect) or die "open: $!";
+		open my $podfile, '<', $podpath or next PODSEARCH;
+		open my $podout, '>', \$namesect or die "open: $!";
 
 		$podselect->parse_from_filehandle($podfile, $podout);
 
-		close($podfile);
-		close($podout) or die "close: $!";
+		close $podfile;
+		close $podout or die "close: $!";
 
 		next PODSEARCH unless($namesect);
 
@@ -573,13 +599,13 @@ sub _poddesc
 #---HELPER FUNCTION---
 sub _readmedesc
 {
-	my ($dir, $modname) = @_;
+	my($dir, $modname) = @_;
 
 	my $path = catfile($dir, 'README');
 	return undef unless(-f $path);
-	open(my $fh, '<', $path) or die "open: $!";
+	open my $fh, '<', $path or die "open: $!";
 
-	while (<$fh>) {
+	while(<$fh>){
 		chomp;
 		next unless((/\ANAME/ ... /\A[A-Z]+/)
 			&& / \A \s* ${modname} [\s\-]+ (.+) \z /x);
@@ -595,8 +621,10 @@ sub _readmedesc
 sub md5sums
 {
 	return [ map {
-		open(my $fh, '<', $_) or die "open: $!";
+		open my $fh, '<', $_ or die "open: $!";
 		my $md5 = Digest::MD5->new()->addfile($fh)->hexdigest;
+		close $fh;
+		$md5;
 	} @_ ]
 }