#!/usr/bin/perl -w

# $OpenBSD: make-plist,v 1.32 2003/12/26 00:26:01 espie Exp $

#  Copyright (c) 1999 Marc Espie
# 
#  Redistribution and use in source and binary forms, with or without
#  modification, are permitted provided that the following conditions
#  are met:
#  1. Redistributions of source code must retain the above copyright
#     notice, this list of conditions and the following disclaimer.
#  2. Redistributions in binary form must reproduce the above copyright
#     notice, this list of conditions and the following disclaimer in the
#     documentation and/or other materials provided with the distribution.
# 
#  THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND
#  ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
#  IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
#  ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE
#  FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
#  DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
#  OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
#  HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
#  LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
#  OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
#  SUCH DAMAGE.
# 


use strict;


use IO::File;
use File::Find;
use File::Spec;
use File::Temp qw/ tempdir /;

my $manual = 0;
my %out;
my @has_shared;
my ($plist, $pshared);

{
package Annotation;

sub new {
    my $class = shift;
    bless {}, $class;
}

sub add {
    my $object = shift;
    my $key = shift;
    unless (defined $object->{$key}) {
    	$object->{$key} = [];
    }
    push(@{$object->{$key}}, @_);
}
}

my $annotated = new Annotation;
my $annotated_dir = new Annotation;
my $info_file = new Annotation;

sub annotate
{
	my $oldfh = shift;
	my $name = shift;
	my $newfh = shift;
	my $comment_printed = 0;
	my ($mode, $owner, $group, $nocheck) = ('', '', '', '');
	while(<$oldfh>) {
		chomp;
		if (m/^\@mode\s*/) {
			$mode = $';
		} elsif (m/^\@owner\s*/) {
			$owner = $';
		} elsif (m/^\@group\s*/) {
			$group = $';
		} elsif (m/^\@comment\s+no checksum$/) {
			$nocheck = 1;
		} elsif (m/^\@option no-default-conflict/||m/^\@pkgcfl/) {
			printf $newfh "$_\n";
		} elsif (m/^\@exec\s+/ || m/^\@unexec\s+/) {
			$_=$';
			# we don't warn for stuff we probably added...
			next if m/^mkdir -p/||m/^install-info /;
			$manual = 1;
		} elsif (m/^\@comment\s+\$OpenBSD\:.*\$$/) {
			print $newfh "$_\n";
			$comment_printed = 1;
			next;
		} elsif (m/^\@comment\s+/) {
			$_ = $';
			if (m/^\@dirrm\s+/) {
				$_ = $';
				$annotated_dir->add($_,  [ $name, $newfh, 'comment']);
				next;
			} else {
				$annotated->add($_, [ $name, $newfh, 'comment'] );
			}
			next;
		} elsif (m/^\@dirrm\s+/) {
			$_=$';
			$annotated_dir->add($_, [ $name, $newfh ]);
			next;
		} elsif (m/^\@/) {
			next;
		} elsif (m/^\!?\%\%(.*)\%\%/) {
			my $frag = $1;
			if ($frag ne "SHARED") {
				print $newfh "$_\n";
				$manual = 1;
			}
		} elsif (m/\$\{.*\}/) {
			$manual = 1;
		}

		if ("$mode$owner$group$nocheck" ne '') {
			$annotated->add($_, [ $name, $newfh, $mode, $owner, $group, $nocheck ]);
			$nocheck = '';
		} else {
			$annotated->add($_, [ $name, $newfh ]);
		}
		if (m/\.info$/) {
			$info_file->add($_, [ $name, $newfh ]);
		}
	}
	print $newfh "\@comment \$OpenBSD\$\n" unless $comment_printed;
}

# read an mtree file, and produce the corresponding directory hierarchy
sub parse_mtree 
{
		# start under current DESTDIR, usually
	my $current = shift;
	local(*FILE);
	my %mtree;
	open FILE, $ENV{MTREE_FILE};
	while(<FILE>) {
		chomp;
		s/^\s*//;
		next if /^\#/ || /^\//;
		s/\s.*$//;
		next if /^$/;
		if ($_ eq '..') {
			$current =~ s|/[^/]*$||;
			next;
		} else {
			$current.="/$_";
		}
		$_ = $current;
		while (s|/\./|/|)	{}
		$mtree{$_} = 1;
	}
	close FILE;
	return \%mtree;
}

# prefix to remove from everything
my $base = $ENV{PREFIX};
my @backsubst;

sub strip 
{
	local($_) = shift;
	s|^\Q$base\E/||;
	for my $l (@backsubst) {
		my $v = $l->[1];
		my $r = $l->[0];
		s/\Q$v\E/$r/g;
	}
	# If the resulting name is arch-dependent, we warn.
	# We don't fix it automatically, as this may need special handling.
	if (m/i386|m68k|sparc/) {
	    print STDERR "make-plist: generated plist contains arch-dependent\n"; 
	    print STDERR "\t$_\n";
	}
	return $_;
}

sub add_info 
{
	my ($header, $info_dir) = @_;
	for my $d (sort (keys %$info_dir) ) {
	    for my $f (sort @{$info_dir->{$d}}) {
		my $d2 = strip($d);
		my $f2 = "$d2/$f";
		if (defined $info_file->{$f2}) {
		    for my $l (@{$info_file->{$f2}}) {
			$l->[1]->print("$header --info-dir=\%D/$d2 \%D/$f2\n");
		    }
		} else {
		    $out{$plist}->print("$header --info-dir=\%D/$d2 \%D/$f2\n");
		}
	    }
	}
}

sub augment_mtree
{
	my ($mtree, $dst, $pkg) = @_;
	my $basepath;
	local(*FILE);
	system("tar zxqf $pkg +CONTENTS");
	open(FILE, '<', '+CONTENTS') or 
		die "Error in dependent package $pkg\n";
	while (<FILE>) {
		chomp;
		if (m/^\@dirrm\s+/) {
			die "Badly formed package: $pkg\n";
		} 
		if (m/^\@cwd\s+/) {
			$basepath = $';
			last;
		}
	}
	unless (defined $basepath and
	File::Spec->file_name_is_absolute($basepath)) {
		die "Badly formed package: $pkg\n";
	}
	while (<FILE>) {
		chomp;
		if (m/^\@dirrm\s+/) {
			my $filename= File::Spec->catfile($dst, $basepath, $');
			$mtree->{$filename} = $pkg;
		}
	}
	close(FILE);
	unlink('+CONTENTS');
}

sub handle_file
{
    my $fname = strip(shift);
    my $out = shift;
    my $string = "$fname\n";

    if (defined $annotated->{$fname}) {
    	for my $l (@{$annotated->{$fname}}) {
	    if (@$l == 3) {
		    $l->[1]->print("\@comment $string");
	    } elsif (@$l == 2) {
		    $l->[1]->print($string);
	    } else {
		my ($outname, $fh, $mode, $owner, $group, $nocheck) = @$l;
		if ($mode ne '') {
			$string="\@mode $mode\n$string\@mode\n";
		}
		if ($owner ne '') {
			$string="\@owner $owner\n$string\@owner\n";
		}
		if ($group ne '') {
			$string="\@group $group\n$string\@group\n";
		}
		if ($nocheck ne '') {
			$string="\@comment no checksum\n$string";
		}
		print $fh $string;
	    }
	}
    } else {
    	print $out $string;
    }
}

sub may_annotate_and_move
{
	my $p = shift;

	if (-e $p) {
	    if (defined $out{$p}) {
	    	die "File handle for $p already exists";
	    }
	    my $fh = new IO::File "<$p";
	    rename($p, "$p.orig") or die "Can't rename $p to $p.orig";
	    my $newfh = new IO::File ">$p";
	    annotate($fh, $p, $newfh);
	    close $fh;
	    $out{$p} = $newfh;
	    return 1;
    	} else {
		return 0;
	}
}


my (%newdir, %occupied, %ldconfig, %has_stuff, %info_dir, @files, @libfiles);
die "Update bsd.port.mk" if @ARGV == 0;
my $plistdir = shift;
die "Update bsd.port.mk" if -f $plistdir;
die "Update bsd.port.mk" 
    unless defined $ENV{'DEPS'} and defined $ENV{'PKGREPOSITORY'};
die "Update bsd.port.mk"
    unless defined $ENV{'PLIST'} and defined $ENV{'PFRAG'};
$plist = $ENV{'PLIST'};
$pshared = $ENV{'PFRAG'}.'.shared';
if (-e "$plist.orig" or -e "$pshared.orig") {
	die "You must clean up old files first";
}

my $destdir = $ENV{DESTDIR};

my $mtree = parse_mtree($destdir);

# and directories for dependencies as well
my $tmpdir = tempdir( CLEANUP => 1);
chdir($tmpdir);
for my $pkg (split(/\s+/, $ENV{'DEPS'})) {
	augment_mtree($mtree, $destdir, $ENV{'PKGREPOSITORY'}."/$pkg.tgz");
}

may_annotate_and_move($plist);
may_annotate_and_move($pshared) and push(@has_shared, $out{$plist});


# Subpackage rules... better way would be to ask bsd.port.mk directly
my $plist2 = $plist;
$plist2 =~ s/PLIST.*$/PLIST/;

my $multi = $ENV{'MULTI_PACKAGES'};
# Normalize
$multi =~ s/^\s+//;
$multi =~ s/\s+$//;
unless ($multi eq '') {
	for my $sub (split(/\s+/, $multi)) {
		may_annotate_and_move("$plist$sub") or 
		    may_annotate_and_move("$plist2$sub");
		may_annotate_and_move("$pshared$sub") and push(@has_shared, $out{"$plist$sub"});
	}
}

for (@ARGV) {
	if (m/\=/) {
		my $back = $`;
		my $v = $';
		push(@backsubst, ["\${$back}", $v]) if $v ne '';
	}
}

my ($name, $fh);
while (($name, $fh) = each %out) {
}

# compare all files against those dates
my @date = (stat $ENV{INSTALL_PRE_COOKIE})[9, 10];

my %okay_files=map { $_=>1 } split(/\s+/, $ENV{'OKAY_FILES'});

# check the installation directory, try to make certain there is
# no file or directory outside of $base
find(
	sub {
		if ($File::Find::name eq $base) {
			$File::Find::prune = 1;
			return;
		}
		if (-d $_) {
			return if $File::Find::name eq $destdir;
			if (defined $mtree->{$File::Find::name}) {
				return;
			} else {
				print STDERR "Bogus directory: $File::Find::name\n";
			}
		} else {
			return if defined $okay_files{$File::Find::name};
			print STDERR "Bogus file: $File::Find::name\n";
		}
	}, $destdir);

# recursive traversal: mark specific `info' dirs, `ldconfig' dirs,
# and potentially modified dirs

find(
	sub {
		my @cdate = (lstat $_)[9, 10];
		if ($cdate[0] >= $date[0] || $cdate[1] >= $date[1]) {
			$has_stuff{$File::Find::dir} = 1;
			if (-d _) {
				$newdir{$File::Find::name} = 1;
			} else {
				if (/\.so\.\d+\.\d+$/) {
					$ldconfig{$File::Find::dir} = 1;
					push(@libfiles, $File::Find::name);
				} else {
					push(@files, $File::Find::name);
					if (/\.info$/) {
						my $d = $File::Find::dir;
						$info_dir{$d} = [] unless defined $info_dir{$d};
						push(@{$info_dir{$d}}, $_);
					}
				}
			}
		} else {
			$occupied{$File::Find::dir} = 1;
		}
	}, $base);


# occupied marks a dir that was already there... 
# so all parents had to be around too
for my $d (keys %occupied) {
	while ($d ne '') {
		undef $newdir{$d} if defined $newdir{$d};
		$d =~ s|/.*?/?$||;
	}
}

# make sure mtree is removed 
for my $d (keys %$mtree) {
	undef $newdir{$d}
}

unless (defined $out{$plist}) {
	$out{$plist} = new IO::File ">$plist";
	$out{$plist}->print("\@comment \$OpenBSD\$\n");
}

add_info('@unexec install-info --delete', \%info_dir);

for my $f (sort @files) {
	handle_file($f, $out{$plist}) unless ($f =~ m|/dir$|) && (defined $info_dir{$`});
}

for my $fh (@has_shared) {
    	$fh->print("\%\%SHARED\%\%\n");
}


if (@libfiles > 0) {
	unless (defined $out{$pshared}) {
		$out{$pshared} = new IO::File ">$pshared";
		$out{$pshared}->print("\@comment \$OpenBSD\$\n");
	}

    	$out{$plist}->print("\%\%SHARED\%\%\n") if @has_shared == 0;
	for my $f (sort @libfiles) {
	    handle_file(strip($f), $out{$pshared});
	}
	for my $d (sort (keys %ldconfig)) {
		if (defined $newdir{$d}) {
			$out{$pshared}->print("NEWDYNLIBDIR(\%D/", strip($d), ")\n");
		} else {
			$out{$pshared}->print("DYNLIBDIR(\%D/", strip($d), ")\n");
		}
	}
}

for my $d (sort { $b cmp $a } (grep { $newdir{$_} } (keys %newdir) ) ) {
	my $dname = strip($d);
	if (defined $annotated_dir->{$dname}) {
		for my $l (@{$annotated_dir->{$dname}}) {
		    if (!$has_stuff{$d}) {
			    $l->[1]->print("\@exec mkdir -p \%D/$dname\n");
		    }
		    if (@$l == 3) {
			    $l->[1]->print("\@comment \@dirrm $dname\n");
		    } else {
			    $l->[1]->print("\@dirrm $dname\n");
		    }
		}
	} else {
		# case of new directory that does not hold anything: it's marked
		# for removal, but it must exist first
		if (!$has_stuff{$d}) {
			$out{$plist}->print("\@exec mkdir -p \%D/$dname\n");
		}
		$out{$plist}->print("\@dirrm $dname\n");
	}
}
	
add_info('@exec install-info', \%info_dir);

if ($manual) {
	print STDERR "make plist: subst/frag/exec/unexec spotted in original file\n";
	print STDERR "\tMay require manual intervention\n";
}
