path: root/lib/Debian/Debhelper/Buildsystem.pm

# Defines debhelper build system class interface and implementation
# of common functionality.
#
# Copyright: © 2008-2009 Modestas Vainius
# License: GPL-2+

package Debian::Debhelper::Buildsystem;

use strict;
use warnings;
use Cwd ();
use File::Spec;
use Debian::Debhelper::Dh_Lib;

# Build system name. Defaults to the last component of the class
# name. Do not override this method unless you know what you are
# doing.
sub NAME {
	my ($this) = @_;
	my $class = ref($this);
	my $target_name;
	if ($class) {
		# Do not assume that the target buildsystem has been provided.
		# NAME could be called during an error in the constructor.
		if ($this->IS_GENERATOR_BUILD_SYSTEM and $this->get_targetbuildsystem) {
			$target_name = $this->get_targetbuildsystem->NAME;
		}
	} else {
		$class = $this;
	}
	if ($class =~ m/^.+::([^:]+)$/) {
		my $name = $1;
		return "${name}+${target_name}" if defined($target_name);
		return $name;
	}
	else {
		error("Invalid build system class name: $class");
	}
}

# Description of the build system to be shown to the users.
sub DESCRIPTION {
	error("class lacking a DESCRIPTION");
}

# Default build directory. Can be overridden in the derived
# class if really needed.
sub DEFAULT_BUILD_DIRECTORY {
	"obj-" . dpkg_architecture_value("DEB_HOST_GNU_TYPE");
}

# Return 1 if the build system generator
sub IS_GENERATOR_BUILD_SYSTEM {
	return 0;
}

# Generator build-systems only
# The name of the supported target systems.  The first one is
# assumed to be the default if DEFAULT_TARGET_BUILD_SYSTEM is
# not overridden.
sub SUPPORTED_TARGET_BUILD_SYSTEMS {
	error("class lacking SUPPORTED_TARGET_BUILD_SYSTEMS");
}

# Generator build-systems only
# Name of default target build system if target is unspecified
#  (e.g. --buildsystem=cmake instead of cmake+makefile).
sub DEFAULT_TARGET_BUILD_SYSTEM {
	my ($this) = @_;
	my @targets = $this->SUPPORTED_TARGET_BUILD_SYSTEMS;
	# Assume they are listed in order.
	return $targets[0];
}

# For regular build systems, the same as DESCRIPTION
# For generator based build systems, the DESCRIPTION of the generator build
# system + the target build system.  Do not override this method unless you
# know what you are doing.
sub FULL_DESCRIPTION {
	my ($this) = @_;
	my $description = $this->DESCRIPTION;
	return $description if not exists($this->{'targetbuildsystem'});
	my $target_build_system = $this->{'targetbuildsystem'};
	return $description if not defined($target_build_system);
	my $target_desc = $target_build_system->FULL_DESCRIPTION;
	return "${description} combined with ${target_desc}";
}

# Constructs a new build system object. Named parameters:
# - sourcedir-     specifies source directory (relative to the current (top)
#                  directory) where the sources to be built live. If not
#                  specified or empty, defaults to the current directory.
# - builddir -     specifies build directory to use. Path is relative to the
#                  current (top) directory. If undef or empty,
#                  DEFAULT_BUILD_DIRECTORY directory will be used.
# - parallel -     max number of parallel processes to be spawned for building
#                  sources (-1 = unlimited; 1 = no parallel)
# - targetbuildsystem -     The target build system for generator based build
#                           systems.  Only set for generator build systems.
# Derived class can override the constructor to initialize common object
# parameters. Do NOT use constructor to execute commands or otherwise
# configure/setup build environment. There is absolutely no guarantee the
# constructed object will be used to build something. Use pre_building_step(),
# $build_step() or post_building_step() methods for this.
sub new {
	my ($class, %opts)=@_;

	my $this = bless({ sourcedir => '.',
	                   builddir => undef,
	                   parallel => undef,
	                   cwd => Cwd::getcwd() }, $class);

	# Setup the target buildsystem early, so e.g. _set_builddir also
	# applies to the target build system.  Useful if the generator
	# and target does not agree on (e.g.) the default build dir.
	my $target_bs_name;
	if (exists $opts{targetbuildsystem}) {
		$target_bs_name = $opts{targetbuildsystem};
	}

	$target_bs_name //= $this->DEFAULT_TARGET_BUILD_SYSTEM if $this->IS_GENERATOR_BUILD_SYSTEM;

	if (defined($target_bs_name)) {
		my %target_opts = %opts;
		# Let the target know it is used as a target build system.
		# E.g. the makefile has special cases based on whether it is
		# the main or a target build system.
		delete($target_opts{'targetbuildsystem'});
		$target_opts{'_is_targetbuildsystem'} = 1;
		my $target_system =_create_buildsystem_instance($target_bs_name, 1, %target_opts);
		$this->set_targetbuildsystem($target_system);
	}

	$this->{'_is_targetbuildsystem'} = $opts{'_is_targetbuildsystem'}
	  if exists($opts{'_is_targetbuildsystem'});

	if (exists $opts{sourcedir}) {
		# Get relative sourcedir abs_path (without symlinks)
		my $abspath = Cwd::abs_path($opts{sourcedir});
		if (! -d $abspath || $abspath !~ /^\Q$this->{cwd}\E/) {
			error("invalid or non-existing path to the source directory: ".$opts{sourcedir});
		}
		$this->{sourcedir} = File::Spec->abs2rel($abspath, $this->{cwd});
	}
	if (exists $opts{builddir}) {
		$this->_set_builddir($opts{builddir});
	}
	if (defined $opts{parallel}) {
		$this->{parallel} = $opts{parallel};
	}

	return $this;
}

# Private method to set a build directory. If undef, use default.
# Do $this->{builddir} = undef or pass $this->get_sourcedir() to
# unset the build directory.
sub _set_builddir {
	my $this=shift;
	my $builddir=shift || $this->DEFAULT_BUILD_DIRECTORY;

	if (defined $builddir) {
		$builddir = $this->canonpath($builddir); # Canonicalize

		# Sanitize $builddir
		if ($builddir =~ m#^\.\./#) {
			# We can't handle those as relative. Make them absolute
			$builddir = File::Spec->catdir($this->{cwd}, $builddir);
		}
		elsif ($builddir =~ /\Q$this->{cwd}\E/) {
			$builddir = File::Spec->abs2rel($builddir, $this->{cwd});
		}

		# If build directory ends up the same as source directory, drop it
		if ($builddir eq $this->get_sourcedir()) {
			$builddir = undef;
		}
	}
	$this->{builddir} = $builddir;
	# Use get as guard because this method is (also) called from the
	# constructor before the target build system is setup.
	if ($this->get_targetbuildsystem) {
		$this->get_targetbuildsystem->{builddir} = $builddir;
	};
	return $builddir;
}

sub set_targetbuildsystem {
	my ($this, $target_system) = @_;
	my $ok = 0;
	my $target_bs_name = $target_system->NAME;
	if (not $this->IS_GENERATOR_BUILD_SYSTEM) {
		my $name = $this->NAME;
		error("Cannot set a target build system: Buildsystem ${name} is not a generator build system");
	}
	for my $supported_bs_name ($this->SUPPORTED_TARGET_BUILD_SYSTEMS) {
		if ($supported_bs_name eq $target_bs_name) {
			$ok = 1;
			last;
		}
	}
	if (not $ok) {
		my $name = $this->NAME;
		error("Buildsystem ${name} does not support ${target_bs_name} as target build system.");
	}
	$this->{'targetbuildsystem'} = $target_system
}

sub _is_targetbuildsystem {
	my ($this) = @_;
	return 0 if not exists($this->{'_is_targetbuildsystem'});
	return $this->{'_is_targetbuildsystem'};
}

# Returns the target build system if it is provided
sub get_targetbuildsystem {
	my $this = shift;
	return if not exists($this->{'targetbuildsystem'});
	return $this->{'targetbuildsystem'};
}

# This instance method is called to check if the build system is able
# to build a source package. It will be called during the build
# system auto-selection process, inside the root directory of the debian
# source package. The current build step is passed as an argument.
# Return 0 if the source is not buildable, or a positive integer
# otherwise.
#
# Generally, it is enough to look for invariant unique build system
# files shipped with clean source to determine if the source might
# be buildable or not. However, if the build system is derived from
# another other auto-buildable build system, this method
# may also check if the source has already been built with this build
# system partially by looking for temporary files or other common
# results the build system produces during the build process. The
# latter checks must be unique to the current build system and must
# be very unlikely to be true for either its parent or other build
# systems. If it is determined that the source has already built
# partially with this build system, the value returned must be
# greater than the one of the SUPER call.
sub check_auto_buildable {
	my $this=shift;
	my ($step)=@_;
	return 0;
}

# Derived class can call this method in its constructor
# to enforce in source building even if the user requested otherwise.
sub enforce_in_source_building {
	my $this=shift;
	if ($this->get_builddir()) {
		$this->{warn_insource} = 1;
		$this->{builddir} = undef;
	}
	if ($this->IS_GENERATOR_BUILD_SYSTEM) {
		$this->get_targetbuildsystem->enforce_in_source_building(@_);
		# Only warn in one build system.
		delete($this->{warn_insource});
	}
}

# Derived class can call this method in its constructor to *prefer*
# out of source building. Unless build directory has already been
# specified building will proceed in the DEFAULT_BUILD_DIRECTORY or
# the one specified in the 'builddir' named parameter (which may
# match the source directory). Typically you should pass @_ from
# the constructor to this call.
sub prefer_out_of_source_building {
	my $this=shift;
	my %args=@_;
	if (!defined $this->get_builddir()) {
		if (!$this->_set_builddir($args{builddir}) && !$args{builddir}) {
			# If we are here, DEFAULT_BUILD_DIRECTORY matches
			# the source directory, building might fail.
			error("default build directory is the same as the source directory." .
			      " Please specify a custom build directory");
		}
		if ($this->IS_GENERATOR_BUILD_SYSTEM) {
			$this->get_targetbuildsystem->prefer_out_of_source_building(@_);
		}
	}
}

# Enhanced version of File::Spec::canonpath. It collapses ..
# too so it may return invalid path if symlinks are involved.
# On the other hand, it does not need for the path to exist.
sub canonpath {
	my ($this, $path)=@_;
	my @canon;
	my $back=0;
	foreach my $comp (split(m%/+%, $path)) {
		if ($comp eq '.') {
			next;
		}
		elsif ($comp eq '..') {
			if (@canon > 0) { pop @canon; }  else { $back++; }
		}
		else {
			push @canon, $comp;
		}
	}
	return (@canon + $back > 0) ? join('/', ('..')x$back, @canon) : '.';
}

# Given both $path and $base are relative to the $root, converts and
# returns path of $path being relative to the $base. If either $path or
# $base is absolute, returns another $path (converted to) absolute.
sub _rel2rel {
	my ($this, $path, $base, $root)=@_;
	$root = $this->{cwd} unless defined $root;

	if (File::Spec->file_name_is_absolute($path)) {
		return $path;
	}
	elsif (File::Spec->file_name_is_absolute($base)) {
		return File::Spec->rel2abs($path, $root);
	}
	else {
		return File::Spec->abs2rel(
			File::Spec->rel2abs($path, $root),
			File::Spec->rel2abs($base, $root)
		);
	}
}

# Get path to the source directory
# (relative to the current (top) directory)
sub get_sourcedir {
	my $this=shift;
	return $this->{sourcedir};
}

# Convert path relative to the source directory to the path relative
# to the current (top) directory.
sub get_sourcepath {
	my ($this, $path)=@_;
	return File::Spec->catfile($this->get_sourcedir(), $path);
}

# Get path to the build directory if it was specified
# (relative to the current (top) directory). undef if the same
# as the source directory.
sub get_builddir {
	my $this=shift;
	return $this->{builddir};
}

# Convert path that is relative to the build directory to the path
# that is relative to the current (top) directory.
# If $path is not specified, always returns build directory path
# relative to the current (top) directory regardless if builddir was
# specified or not.
sub get_buildpath {
	my ($this, $path)=@_;
	my $builddir = $this->get_builddir() || $this->get_sourcedir();
	if (defined $path) {
		return File::Spec->catfile($builddir, $path);
	}
	return $builddir;
}

# When given a relative path to the source directory, converts it
# to the path that is relative to the build directory. If $path is
# not given, returns a path to the source directory that is relative
# to the build directory.
sub get_source_rel2builddir {
	my $this=shift;
	my $path=shift;

	my $dir = '.';
	if ($this->get_builddir()) {
		$dir = $this->_rel2rel($this->get_sourcedir(), $this->get_builddir());
	}
	if (defined $path) {
		return File::Spec->catfile($dir, $path);
	}
	return $dir;
}

sub get_parallel {
	my $this=shift;
	return $this->{parallel};
}

# This parallel support for the given step
sub disable_parallel {
	my ($this) = @_;
	$this->{parallel} = 1;
	if ($this->IS_GENERATOR_BUILD_SYSTEM) {
		$this->get_targetbuildsystem->disable_parallel;
	}
}

# When given a relative path to the build directory, converts it
# to the path that is relative to the source directory. If $path is
# not given, returns a path to the build directory that is relative
# to the source directory.
sub get_build_rel2sourcedir {
	my $this=shift;
	my $path=shift;

	my $dir = '.';
	if ($this->get_builddir()) {
		$dir = $this->_rel2rel($this->get_builddir(), $this->get_sourcedir());
	}
	if (defined $path) {
		return File::Spec->catfile($dir, $path);
	}
	return $dir;
}

# Creates a build directory.
sub mkdir_builddir {
	my $this=shift;
	if ($this->get_builddir()) {
		install_dir($this->get_builddir());
	}
}

sub check_auto_buildable_clean_oos_buildir {
	my $this = shift;
	my ($step) = @_;
	# This only applies to clean
	return 0 if $step ne 'clean';
	my $builddir = $this->get_builddir;
	# If there is no builddir, then this rule does not apply.
	return 0 if not defined($builddir) or not -d $builddir;
	return 1;
}

sub _generic_doit_in_dir {
	my ($this, $dir, $sub, @args) = @_;
	my %args;
	if (ref($args[0])) {
		%args = %{shift(@args)};
	}
	$args{chdir} = $dir;
	return $sub->(\%args, @args);
}

# Changes working directory to the source directory (if needed),
# calls print_and_doit(@_) and changes working directory back to the
# top directory.
sub doit_in_sourcedir {
	my ($this, @args) = @_;
	$this->_generic_doit_in_dir($this->get_sourcedir, \&print_and_doit, @args);
	return 1;
}

# Changes working directory to the source directory (if needed),
# calls print_and_doit(@_) and changes working directory back to the
# top directory. Errors are ignored.
sub doit_in_sourcedir_noerror {
	my ($this, @args) = @_;
	return $this->_generic_doit_in_dir($this->get_sourcedir, \&print_and_doit_noerror, @args);
}

# Changes working directory to the build directory (if needed),
# calls print_and_doit(@_) and changes working directory back to the
# top directory.
sub doit_in_builddir {
	my ($this, @args) = @_;
	$this->_generic_doit_in_dir($this->get_buildpath, \&print_and_doit, @args);
	return 1;
}

# Changes working directory to the build directory (if needed),
# calls print_and_doit(@_) and changes working directory back to the
# top directory. Errors are ignored.
sub doit_in_builddir_noerror {
	my ($this, @args) = @_;
	return $this->_generic_doit_in_dir($this->get_buildpath, \&print_and_doit_noerror, @args);
}

# In case of out of source tree building, whole build directory
# gets wiped (if it exists) and 1 is returned. If build directory
# had 2 or more levels, empty parent directories are also deleted.
# If build directory does not exist, nothing is done and 0 is returned.
sub rmdir_builddir {
	my $this=shift;
	my $only_empty=shift;
	if ($this->get_builddir()) {
		my $buildpath = $this->get_buildpath();
		if (-d $buildpath) {
			my @dir = File::Spec->splitdir($this->get_build_rel2sourcedir());
			my $peek;
			if (not $only_empty) {
				doit("rm", "-rf", $buildpath);
				pop @dir;
			}
			# If build directory is relative and had 2 or more levels, delete
			# empty parent directories until the source or top directory level.
			if (not File::Spec->file_name_is_absolute($buildpath)) {
				while (($peek=pop @dir) && $peek ne '.' && $peek ne '..') {
					my $dir = $this->get_sourcepath(File::Spec->catdir(@dir, $peek));
					doit("rmdir", "--ignore-fail-on-non-empty", $dir);
					last if -d $dir;
				}
			}
		}
		return 1;
	}
	return 0;
}

# Instance method that is called before performing any step (see below).
# Action name is passed as an argument. Derived classes overriding this
# method should also call SUPER implementation of it.
sub pre_building_step {
	my $this=shift;
	my ($step)=@_;

	# Warn if in source building was enforced but build directory was
	# specified. See enforce_in_source_building().
	if ($this->{warn_insource}) {
		warning("warning: " . $this->NAME() .
		    " does not support building out of source tree. In source building enforced.");
		delete $this->{warn_insource};
	}
	if ($this->IS_GENERATOR_BUILD_SYSTEM) {
		$this->get_targetbuildsystem->pre_building_step(@_);
	}
}

# Instance method that is called after performing any step (see below).
# Action name is passed as an argument. Derived classes overriding this
# method should also call SUPER implementation of it.
sub post_building_step {
	my $this=shift;
	my ($step)=@_;
	if ($this->IS_GENERATOR_BUILD_SYSTEM) {
		$this->get_targetbuildsystem->post_building_step(@_);
	}
}

# The instance methods below provide support for configuring,
# building, testing, install and cleaning source packages.
# In case of failure, the method may just error() out.
#
# These methods should be overridden by derived classes to
# implement build system specific steps needed to build the
# source. Arbitrary number of custom step arguments might be
# passed. Default implementations do nothing.
#
# Note: For generator build systems, the default is to
# delegate the step to the target build system for all
# steps except configure.
sub configure {
	my $this=shift;
}

sub build {
	my $this=shift;
	if ($this->IS_GENERATOR_BUILD_SYSTEM) {
		$this->get_targetbuildsystem->build(@_);
	}
}

sub test {
	my $this=shift;
	if ($this->IS_GENERATOR_BUILD_SYSTEM) {
		$this->get_targetbuildsystem->test(@_);
	}
}

# destdir parameter specifies where to install files.
sub install {
	my $this=shift;
	my ($destdir) = @_;

	if ($this->IS_GENERATOR_BUILD_SYSTEM) {
		$this->get_targetbuildsystem->install(@_);
	}
}

sub clean {
	my $this=shift;

	if ($this->IS_GENERATOR_BUILD_SYSTEM) {
		$this->get_targetbuildsystem->clean(@_);
	}
}


sub _create_buildsystem_instance {
	my ($full_name, $required, %bsopts) = @_;
	my @parts = split(m{[+]}, $full_name, 2);
	my $name = $parts[0];
	my $module = "Debian::Debhelper::Buildsystem::$name";
	if (@parts > 1) {
		if (exists($bsopts{'targetbuildsystem'})) {
			error("Conflicting target buildsystem for ${name} (load as ${full_name}, but target configured in bsopts)");
		}
		$bsopts{'targetbuildsystem'} = $parts[1];
	}

	eval "use $module";
	if ($@) {
		return if not $required;
		error("unable to load build system class '$name': $@");
	}
	return $module->new(%bsopts);
}

1