#!/usr/bin/perl -w
#
# apt-build 
#
#
# (c) 2002-2003 Julien Danjou <acid@debian.org>
# (c) 2003 Davor Ocelic <docelic@linux.hr> (apt-build rewrite)
#
#  $Id: apt-build,v 1.14 2003/09/09 12:59:34 docelic Exp $
#
# This package is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; version 2 dated June, 1991.
#
# This package is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this package; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
# 02111-1307, USA.
#

#
# The comments in the script have been made verbose on purpose, to help new
# developers get the grip on apt-build and Perl in general.
#

use strict;
use warnings;
use AppConfig qw/:expand :argcount/;
use Fatal qw/chdir open/;                           # see Fatal
use Env qw/$APT_BUILD_WRAPPER/;                     # perldoc Env 
use AptPkg::Config qw/$_config/;                    # see libapt-pkg-perl
use AptPkg::System qw/$_system/;                    #
use AptPkg::Version;
use AptPkg::Source;
use AptPkg::Cache;


# Initial
my $VERSION = "0.9.2";
my ($conf, %conf, @builddep, @apt_args);

@apt_args = qw/--yes/;     # and DEFAULT => 1, down in parse_config()

my @actions = qw/install source remove info update upgrade world
	build_repository clean_build moo find/;       # possible actions

$\ = "\n";                 # automatic newline after each print()

# Ok, we start here... 
parse_config() or die "Can't parse config\n"; # all config-related

my $cmd = shift or help(); # if no command specified, help is called and we exit
$cmd =~ s/-/_/g;           # replace all "-" in command name with "_"
@_ = @ARGV;                # For the "&$cmd" call, few lines below

-d $conf->build_dir or die "--build_dir must be a valid directory!\n";
chdir $conf->build_dir;    # use Fatal qw/chdir/ above takes care for this

# Initialize libapt now after basic checks were okay
$_config->init;                                   
$_system = $_config->system;
$_config->{quiet} = 2;
my $_cache = new AptPkg::Cache;
my $_version = $_system->versioning;
my $_source = new AptPkg::Source $conf->sources_list;

# 'no strict' makes it possible that we call "&$cmd" (so, if the user 
# specifies command 'source', we call sub source).
# As an additional verification step, command name must be listed in @actions
# (if we didn't check that, the script would break with non-friendly message).
# The whole work is then done in some of the functions listed below.
# Also, the whole block is surrounded by { and }, so that 'no strict' would
# be turned back to 'strict' at the exit of the block automatically.
# And note the way we use to call the function; we say "&$cmd" (prefixed with
# '&' and having no closing parentheses) - that will automatically make contents
# of our @_ variable available to called functions (and we did @_ = @ARGV above)
{ no strict 'refs'; help() unless grep {/^$cmd$/i} @actions; &$cmd }

exit 0;

# END # (helpers below)
#############################################################################


# Ok, let's serve the simple subroutines first
sub help {
print "Usage: apt-build [options] [command] <package>

Commands:
  update       - Update package lists
  upgrade      - Perform an upgrade
  install      - Build and install new packages
  source       - Download and extract source in build directory
  remove       - Remove packages
  clean-build  - Erase downloaded packages and temporary build files
  world        - Rebuild and reinstall all packages on your system
  info         - Build-related package information

Options:
  --reinstall       - Re-build and install already installed package
  --rebuild         - Rebuild package
  --remove-builddep - Remove build-dependencies installed by apt-build
  --nowrapper       - Do not use gcc/g++ wrapper
  --purge           - Use purge instead of remove
  --noupdate        - Do not run 'apt-get update' before package installation
  --build-command   - Use <command> to build package
  --patch <file>    - Apply patch <file>s before the build
  --patch-strip     - Striplevel for the patch files
  --yes         -y  - Assume yes
  --version     -v  - Show version and exit
  --source          - Do not download source (sources are extracted already)
  --build-only      - Do not install any of build dependencies or <package>
  --build-dir       - Specify build dir
  --repository-dir  - Specify the repository directory
  --target-release  - Distribution to fetch packages from
  --sources-list    - Specify sources.list file

";
exit 1
}

# Since shell returns 0 on success, and our script usually uses true values
# for the same, we use "!" here to invert the result - shell's success (0)
# becomes our success (1)
sub patch {
	print STDERR "-----> Patching (@_)<-----";
	!system "patch -p$conf{patch_strip} < $_" or return while $_ = shift;
}

sub clean_build {
	print STDERR "-----> Cleaning the build tree <-----";
	!system "rm -rf $conf{build_dir}/*"
}

sub remove {
	print STDERR "-----> Removing packages (@_)<-----";
	!system "apt-get @apt_args remove @_"
}

sub update {
	print STDERR "-----> Updating package lists <-----";
	!system "apt-get @apt_args update"
}

sub move_to_repository {
	print STDERR "-----> Moving packages to repository <-----";
	!system "mv $conf{build_dir}/*.deb $conf{repository_dir}"
}


# Find out [source] package download locations
# If called in void context, print to screen; otherwise return array
sub find {
	local $" = ", ";
	my @res;
 	for my $pkg (@_) {
		my @seen; # Skip multiple entries for the same pkg version
		my @list = $_source->find($pkg);
		for (@list) {
			my $ver = $$_{Version};
			grep {/$ver/} @seen and next; # Skip if seen
			push @seen, $ver;
			unless (defined wantarray) { # If we're called in void context
				print "Source: @$_{'Package','Section','Version','Maintainer'}";
				print "Binaries: @{$$_{Binaries}}";
			}
			my @files = @{ $$_{Files} };
			for (@files) {
				my $type = ucfirst $$_{Type};
				!defined wantarray?
					print "$type: $$_{ArchiveURI}" :
					push @res, $$_{ArchiveURI};
			}
			print '';
		}
		print '';
	}
	return @res if defined wantarray;
	1
}


sub info {
	my @size;

	for (@_) {
		my $pkg = $_;

		# (full explanation for read_apt_list is below)
		# We invoke apt-get here to determine package size
		push @size,
			read_apt_list("apt-get --print-uris @apt_args source $pkg |",
			"^'", \&extract_size);

		# and to determine package dependencies, and their cumulative size
		my (@size_deps, @deps);
		read_apt_list("apt-get --print-uris @apt_args build-dep $pkg |",
			"^'", sub {
				push @size_deps, extract_size($_);
				push @deps, extract_name($_);
			});

		# print summary
		my $sumsize = 0;
		$sumsize += $_ for @size;
		print "Package: $pkg";
		print "Source-size: $sumsize";
		$sumsize = 0;
		$sumsize += $_ for @size_deps;
		print "Depends-size: $sumsize";
		print "Depends: @deps ";
	}
	1
}

sub source
{
	my $pkg = shift or return;
	my ($srcpkg, $srcver, @packages);

	# apt-get here prints 3 lines, we pick the one talking about .dsc file.
	# (I search for .dsc in field 1, while old source searched in 
	# field 0. Can the info from those fields ever be different ?)
	read_apt_list("apt-get --print-uris @apt_args source $pkg |", "^'",
		sub {
			my ($n, $v) = extract_dsc($_) or return;
			($srcpkg, $srcver) = ($n, $v)
		});

	# And we retrieve the same information from apt-cache.
	# (XXX this info from 'apt-cache show' is from old source, I dont know why.
	# Since the test is made, I just added a print() if versions are not equal)
	my $new; # set to 1 if versions from here and above are not the same.
	my $oldver = $srcver;
	read_apt_list("apt-cache show $pkg |", "^Version:",
		sub { if (/^Version: (.+)$/ && !$new) { $srcver = $1; $new = 1 } });
	$new = 0 if $srcver eq $oldver;

	print STDERR "-----> Downloading $pkg source ($srcpkg $srcver) <-----";
	print STDERR "Taking version $srcver over $oldver\n" if $new;

	update() if $conf->update; # to be consistent with install()
	!system "apt-get @apt_args source ${srcpkg}=${srcver}"
}

sub build
{
	@_ == 3 or return;
	my ($pkg, $upver, $maintver) = @_;
	my ($control, @packages, $srcpkg, $srcver, $upverchdir);

	print STDERR "-----> Building $pkg <-----";

	chdir $conf{build_dir};

	read_apt_list("apt-get --print-uris @apt_args source $pkg |", "^'",
		sub {
			my ($n, $v) = extract_dsc($_) or return;
			($srcpkg, $srcver) = ($n, $v)
		});


	read_apt_list(
		"apt-get --print-uris @apt_args source $srcpkg=".$upver.$maintver." |",
		"^'", sub {
			my ($n, $v) = extract_dsc($_) or return;
      # remove epoch
			$v =~ s/^\d+://;
			# remove Debian revision
			$v =~ s/-[\d\+\.]+$//;
			($srcpkg, $upverchdir) = ($n, $v);
		});

	chdir "$srcpkg-$upverchdir";

	# Add an entry in changelog 
	system "debchange --append 'Built by apt-build'";
	for (@{$conf->patch}) {
		my $p = qx[basename $_];
		chomp $p;
		system "debchange --append 'Patched with $p'";
	}

	# Now build
	my  $r = !system $conf->build_command;
	chdir $conf{build_dir};

	$r
}


sub build_repository
{
	print STDERR "-----> Building repository <-----";

	chdir $conf->repository_dir;
	my $arch=qx[dpkg --print-architecture]; chomp $arch;

	system "ln -s . main" unless -e "main";
	system "ln -s . apt-build" unless -e "apt-build";
	system "ln -s . dists" unless -e "dists";
	system "ln -s . binary-$arch" unless -e "binary-$arch";
	make_release_file() unless -e "Release";

	system "apt-ftparchive packages . | gzip -9 > Packages.gz";
	chdir $conf->build_dir;
	1
}

sub make_release_file
{
	my $release;
	open RELEASE, "< /usr/share/apt-build/Release";
	while (<RELEASE>) {
		my $arch = qx[dpkg --print-architecture]; chomp $arch;
		s/__arch__/$arch/;
		$release .= $_;
	}
	close RELEASE;
	open RELEASEREPO, "> $conf{repository_dir}/Release";
	print RELEASEREPO $release;
	close RELEASEREPO;
	1
}

#sub clean_repository
#{
#	if($conf{repository_dir})
#	{
#		(! system("rm -fr $repository_dir/*.deb")) or die "Error: $!\n";
#	}
#	else { die "Error: what is build_dir ?";	}
#}

sub builddep
{
	my $pkg = shift or return;

	if ($conf->remove_builddep) {
		read_apt_list("apt-get --print-uris @apt_args build-dep $pkg |",
			"^'", \&extract_name);
	}

	print STDERR "-----> Installing build dependencies (for $pkg) <-----";
	!system "apt-get @apt_args build-dep $pkg"
}

sub install
{   
	my (@packages, @pkgs, $buildpkg);
	my (@pkglist) = @_;
	my $nopkgs_okay = 0;

	for (@_) {
		my $pkg = $_;
		open APTIN, "apt-get --print-uris @apt_args install $pkg |"; #2>&1 |

		AI: while (<APTIN>) {
			if ( /^Package .* is a virtual package provided by/ ) {
				system("apt-get @apt_args install $pkg");
				exit 0;

			} elsif ( /^\'(http|ftp|file|cdrom)/ ) {
				@packages = split /\s+/;
				$packages[1] =~ /^(.*)_(.*)_(.*)\.deb$/ or warn; # XXX
				my ($buildpkg, $version, $arch) = ($1, $2, $3);

				my $stripver; # What the hell was that?
				my $pkgstriped = "";

				if ( ($stripver) = ($version =~ /\%3a(.*)$/) ) {
					$pkgstriped = "${buildpkg}_${stripver}_${arch}.deb";
				} else {
					$pkgstriped = "${buildpkg}_${version}_${arch}.deb";
				};


				if ( $arch =~ /^all$/ ) { # If arch: all, no build needed
					print "Package $buildpkg does not need to be rebuilt";
					$nopkgs_okay++;

				} elsif ( -f "$conf{build_dir}/$packages[1]"
				&& !($conf->rebuild) ) {

					print "Package $buildpkg already built.";
					push(@pkgs, $packages[1]);
					move_to_repository(@pkgs);
					build_repository();

				} elsif ( -f "$conf{repository_dir}/$packages[1]"
				&& !($conf->rebuild) ) {

					print "Package $buildpkg already in repository.";
					push @pkgs, $packages[1];

				} elsif ( -f "$conf{repository_dir}/$pkgstriped"
				&& !($conf->rebuild) ) {

					print "Package $buildpkg already in repository.";
					push @pkgs, $packages[1];

				} else {
					push @pkgs, $packages[1];
					wait;

					builddep($buildpkg) unless $conf->build_only;
					source($buildpkg) if $conf->source;
					patch($_) for @{$conf->patch};

					# Now build the package
					my ($maintver, $upver);
					if ( $version =~ /(.*)(-.*)$/) {
						($upver, $maintver) = ($1, $2)
					} else {
						($upver) = ($version)
					}

					$upver =~ s/%3a/:/;
					if (build($buildpkg, $upver, $maintver)) {
						&move_to_repository(@pkgs);
						&build_repository;
					} else {
						warn "Error while building $pkg !\n" ; 
						pop @pkgs;
					}
				}
			}
		}
		close APTIN;
		wait;

		unless (@pkgs or $nopkgs_okay) {
			print STDERR "Sorry, can't find $pkg, is it already installed?";
			print STDERR "(Remove it first, or try running 'apt-get clean')"
		}
	}

	wait;

	# Remove builddep if asked
	remove(@builddep) if $conf->remove_builddep && !($conf->build_only);

	# If we have something to install, install
	if( @pkgs && !($conf->build_only) ) {
		update() if $conf->update;
		system("apt-get -t apt-build @apt_args install @pkglist");
	}
	1
}

sub world
{
	print STDERR "-----> Rebuilding the world ! <-----";
	print STDERR "-----> Building package list <-----";
	open IGNORELIST, "< /etc/apt/apt-build.list";
	install(<IGNORELIST>);
	close IGNORELIST;
	1
}

sub upgrade
{
	print STDERR "-----> Upgrading (@_) <-----";
	@_ or @_ = read_apt_list(
			"apt-get --print-uris @apt_args upgrade |", "^'", \&extract_name);

	@_ ? install(@_) : print STDERR "No packages need to be upgraded";
	1
}

# the funny characters here are color sequences, to look nice when printed on
# the terminal ;)
sub moo
{
    print << "EOM";
         (__)    \e[32m~\e[0m
         (oo)   /
     _____\\/___/
    /  /\\ / /
   \e[32m~\e[0m  /  \e[33m*\e[0m /
     / ___/
*----/\\
    /  \\
   /   /
  ~    ~
..."Have you danced today ? Discow !"...
EOM
}

#sub change_version
#{
#	$_ = shift;
#	$_ =~ s/^(.*_)(.*%3a)?(.*)(_.*\.deb)$/$1$3\.0$4/;
#	return($_);
#}


# The core of our config is the AppConfig module (available from CPAN).
# The whole $conf = AppConfig->new() block is related to AppConfig. So, see
# perldoc AppConfig for more. (AppConfig is very well documented and the man
# page is easy to understand).
sub parse_config
{   
	$conf = AppConfig->new(
		{
			CASE => 1,
			DEBUG => 0,
			CREATE => 0,
			GLOBAL => {
				ARGCOUNT => ARGCOUNT_NONE,
				DEFAULT => 0,
			}
		},
		# ALIAS =>, so imperfect and universe-breaking, and we still need it.
		"config|cfg=s",       { DEFAULT => "/etc/apt/apt-build.conf" },
		"remove_builddep!",   { ALIAS => "remove-builddep" },
    "wrapper!",           { DEFAULT => 0 },
		"purge!",             { ACTION => \&apt_args_modify },
		"build_command=s",    { DEFAULT=> "dpkg-buildpackage -b -us -uc",
		                        ALIAS => "build-command" },
		"reinstall|r!",       { ACTION => \&apt_args_modify },
		"yes|y!",             { ACTION => \&apt_args_modify, DEFAULT => 1 },
		"patch=s@",           { },
		"patch_strip|p=i",    { DEFAULT => 1, ALIAS => "patch-strip" },
		"target_release|t=s", { ACTION => \&apt_args_modify,
		                        ALIAS => "target-release" },
		"source!",            { DEFAULT => 1 },
		"build_only!",        { ALIAS => "build-only" },
		"rebuild!",           { DEFAULT => 1 },
		"build_dir=s",        { DEFAULT => "/var/cache/apt-build/build/",
		                        ALIAS => "build-dir" },
		"repository_dir=s",   { DEFAULT => "/var/cache/apt-build/repository/",
		                        ALIAS => "repository-dir" },
		"sources_list=s",     { DEFAULT => "/etc/apt/sources.list" },
		"update!",            { DEFAULT => 1 },
		"Olevel=s",           {},
		"march=s",            {},
		"mcpu=s",             {},
		"options",          {},
		"version",            {
			ACTION => sub { print "apt-build version $VERSION"; exit 0 }
		},
	) or die "Can't initialize the AppConfig object\n";

	tie %conf, 'AptBuild::ObjHash', \$conf; # see AptBuild::ObjHash below

	$conf->file($conf->cfg) if -r $conf->cfg;   # read the config file
	$conf->getopt;                              # parse command line

	$APT_BUILD_WRAPPER++ unless $conf->wrapper; # define ENV var
	1
}


# Okay, this is the core of the script. (Note that this will be abandoned
# when we switch to libapt-pkg-perl (since we won't call external commands any
# more), but it's still worth explaining:
# You pass the script three arguments:
# 1 - command to execute
# 2 - output pattern filter
# 3 - subroutine to parse lines
# So basically, read_apt_list runs a command ("apt-get ...something" usually),
# then it discards the output lines which do not match $pattern, and it calls
# &$handler function for each remaining line to extract results.
# Filtering can be done in the handler function as well, but this pre-filter
# step is just a small convenience.
# The trick is that $handler is a function reference, which can be specified
# by either passing \&func_name as argument, or by including the whole 
# subroutine directly, in-place as the 3rd argument.
# The info() function has an example of both (passing a reference and specifying
# sub{} in-place).
# This greatly simplifies things because we concentrate on functionality, and
# don't have to bother with opening & closing files, etc.
# The return value of read_apt_list (if you want to use it) is an array
# containing all non-empty results from invocation of $&handler.
sub read_apt_list {
	my ($line, $pattern, $handler) = @_;
	my @results;
	open IN, "$line";
	while (local $_ = <IN>) {
		if (/$pattern/i) { local $_ = &$handler(); push @results, $_ if $_ }
	}
	close IN;
	return @results
}


# self-explanatory, those functions take apt-get output as input and
# try to extract information.
sub extract_name { ($_ = (split /\s+/)[1]) =~ s/_.*// if /_/; $_ }

sub extract_filename { return (split /\s+/)[1] }

sub extract_size { return (split /\s+/)[2] }
	
sub extract_dsc {
	my $t = (split /\s+/)[1]; 
	$t =~ /^(.+)_(.+)\.dsc$/ or return;
	my $n = $1; ( my $v = $2 ) =~ s/%3a/:/;
	($n, $v)
}


# This function modifies @apt_args (either adds or removes arguments
# from it).
sub apt_args_modify {
	my ($self, $name, $value) = @_;

	if (!( $self->{ARGCOUNT}->{$name} )) { # if option takes no argument
		if ($value) { push @apt_args, "--$name" }
		else { @apt_args = grep {!/^--$name$/} @apt_args }

	} elsif ($self->{ARGCOUNT}->{$name} == ARGCOUNT_ONE) { # or if takes 1 arg
		@apt_args = grep {!/^--$name /} @apt_args; # just to be sure
		push @apt_args, "--$name $value";
	}
}


# This fine chunk "extends" the AppConfig object. In addition to doing
# $conf->variable and $conf->variable(value), it's now possible to do:
# $conf{variable} and $conf{variable} = value
# This is very handy inside strings, because this would be invalid:
#  print "$c->build_dir" (inside strings, the -> has no special meaning).
# But thanks to AptBuild::ObjHash, we can get the intended results with:
#  print "$c{build_dir}" (which is a valid syntax). 
# For more info on how it all works, perldoc perltie
package AptBuild::ObjHash;

use strict;
use warnings;

use base qw/Tie::Hash/;

sub TIEHASH {
    return 0 unless ref $_[1];
    return bless [ $_[1] ] => $_[0]
}

sub FETCH {
    my ($self, $key) = @_;
    return ${@$self[0]}->get("$key")
}

sub STORE {
    my ($self, $key, $val) = @_;
    return ${@$self[0]}->set("$key", $val)
}

