dh-linktree 0.1 / usr / bin / dh_linktree

#!/usr/bin/perl -w

# Copyright © 2011-2012 Raphaël Hertzog <hertzog@debian.org>
#
# This program 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, either version 3 of the License, or
# (at your option) any later version.
#
# 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 program. If not, see <http://www.gnu.org/licenses/>.

=head1 NAME

dh_linktree - create symlink trees to embed files from other packages

=cut

use strict;
use File::Find;
use File::Spec;
use File::Compare;
use Debian::Debhelper::Dh_Lib;
use Dpkg::IPC;

=head1 SYNOPSIS

B<dh_linktree> [S<I<debhelper options>>] [B<-A>] [B<-X>I<item>] [S<I<action source destination> ...>]

=head1 DESCRIPTION

B<dh_linktree> is a debhelper program that creates symlink trees in package build
directories. The symlinks points to files provided by other packages and who
have to be present during build. As such you have to put the packages providing
the destination files in the build dependencies.

B<dh_linktree> accepts arguments by set of 3. One action followed by
source and destination file/directories. Symlinking files works just like
B<dh_link> but symlinking directories will recreate the same directory
hierarchy and all individual files will be turned into symlinks.

The source files are the already existing files that will be symlinked from.
The destination files are the symlinks that will be created. There B<must> be
an equal number of source and destination files specified.

Be sure you B<do> specify the full filename to both the source and
destination files (unlike you would do if you were using something like
L<ln(1)>).

B<dh_linktree> will generate symlinks that comply with Debian policy - absolute
when policy says they should be absolute, and relative links with as short
a path as possible. It will also create any subdirectories it needs to to put
the symlinks in.

=head1 FILES

=over 4

=item debian/I<package>.linktrees

Lists source and destination trees to be symlinked. Each line consists
of 3 fields: the action, the source directory, the destination directory.
should be put on its own line, with the source and destination separated by
whitespace.

=back

=head1 OPTIONS

=over 4

=item B<-X>I<item>, B<--exclude=>I<item>

Do not create symlinks for files that contain I<item> anywhere in their
filename.

=item I<action source destination> ...

If the action is "embed" create a symlink tree named I<destination> with
all files within it pointing to the corresponding file in I<source>.

The "replace" action will not create new files but it will
replace existing files in the destination directory with symlinks to the
corresponding source file.

The "deduplicate" action is like "replace" except it replaces files only
if they have exactly the same content.

The work is done in the package build directory of the first package acted on.

=back

=head1 EXAMPLES

 dh_linktree embed usr/share/javascript/jquery usr/share/wordpress/plugin-jquery

Make F<plugin-jquery> be a symlink tree to F<jquery>.

=cut

init();

foreach my $package (@{$dh{DOPACKAGES}}) {
	my $tmp=tmpdir($package);
	my $file=pkgfile($package,"linktrees");

        my @srclinks;
	if ($file) {
		@srclinks=filearray($file);
	}

	# Make sure it has a multiple of 3 args
	if ($#srclinks % 3 == 0) {
		error("$file lists a link without a destination.");
	}

	if (($package eq $dh{FIRSTPACKAGE} || $dh{PARAMS_ALL}) && @ARGV) {
		push @srclinks, @ARGV;
	}

	# Same test as above, including arguments this time.
	if ($#srclinks % 3 == 0) {
		error("parameters list a link without a destination.");
	}

	next unless scalar(@srclinks);

	my @links;
	while (@srclinks) {
	        my $action=shift @srclinks;
		my $src=shift @srclinks;
		my $dest=shift @srclinks;
		error("invalid action '$action'")
			if $action !~ /^(embed|replace|deduplicate)$/;
		if (! -l "/$src" and -d _) {
			find(sub {
				return if -d and ! -l;
				return if excludefile($_);
				my $rel=File::Spec->abs2rel($File::Find::name,"/$src");
				push @links, $action, "$src/$rel", "$dest/$rel";
			}, "/$src");
		} else {
			push @links, $action, $src, $dest;
		}
	}

	my %used;
	while (@links) {
	        my $action=shift @links;
		my $src=shift @links;
		my $dest=shift @links;

		$src=~s:^/::;
		$dest=~s:^/::;

		my $src_abs="/$src";

		if ($src eq $dest) {
			warning("skipping link from $src to self");
			next;
		}

		if ($action ne "embed" and not -e "$tmp/$dest") {
			verbose_print("not creating $tmp/$dest");
			next;
		}

		if ($action eq "deduplicate" and -e "$tmp/$dest" and
		    compare("$tmp/$dest", "/$src") != 0) {
			verbose_print("not replacing $tmp/$dest due to " .
				      "mismatch with /$src");
			next;
		}

		# Make sure the directory the link will be in exists.
		my $basedir=dirname("$tmp/$dest");
		if (! -e $basedir) {
			doit("install","-d",$basedir);
		}

		# Policy says that if the link is all within one toplevel
		# directory, it should be relative. If it's between
		# top level directories, leave it absolute.
		my @src_dirs=split(m:/+:,$src);
		my @dest_dirs=split(m:/+:,$dest);
		if (@src_dirs > 0 && $src_dirs[0] eq $dest_dirs[0]) {
			# Figure out how much of a path $src and $dest
			# share in common.
			my $x;
			for ($x=0; $x < @src_dirs && $src_dirs[$x] eq $dest_dirs[$x]; $x++) {}
			# Build up the new src.
			$src="";
			for (1..$#dest_dirs - $x) {
				$src.="../";
			}
			for ($x .. $#src_dirs) {
				$src.=$src_dirs[$_]."/";
			}
			if ($x > $#src_dirs && ! length $src) {
				$src.="."; # special case
			}
			$src=~s:/$::;
		}
		else {
			# Make sure it's properly absolute.
			$src="/$src";
		}

		if (-d "$tmp/$dest" && ! -l "$tmp/$dest") {
			error("link destination $tmp/$dest is a directory");
		}
		doit("rm", "-f", "$tmp/$dest");
		doit("ln","-sf", $src, "$tmp/$dest");
		$used{$src_abs} = $action;
	}
	my $output;
	my @files = sort keys %used;
	my $pid = spawn(exec => [ "dpkg", "--search", "--", @files ],
			to_pipe => \$output,
			env => { LC_ALL => 'C' });
	my %pkgused;
	while(defined($_ = <$output>)) {
	    chomp($_);
	    if (m/^local diversion |^diversion by/) {
		warning(_g("diversions involved - output may be incorrect"));
		print(STDERR " $_\n")
		    || syserr(_g("write diversion info to stderr"));
	    } elsif (m/^([-a-z0-9+.:, ]+): (\/.*)$/) {
		foreach my $pkg (split(/, /, $1)) {
		    if (exists $pkgused{$pkg}) {
			$pkgused{$pkg} = $used{$2} if $pkgused{$pkg} eq "replace";
		    } else {
			$pkgused{$pkg} = $used{$2};
		    }
		}
	    } else {
		warning("unknown output from dpkg --search: '$_'");
	    }
	}
	close($output) or error("failed to close pipe with dpkg --search");
	wait_child($pid, cmdline => "dpkg --search -- @files");
	$output = undef;
	$pid = spawn(exec => [ "dpkg-query", "-W", "--", sort keys %pkgused ],
		     to_pipe => \$output,
		     env => { LC_ALL => 'C' });
	my %deps;
	while(defined($_ = <$output>)) {
	    chomp($_);
	    my ($pkg, $ver) = split(/\s+/, $_);
	    $ver =~ s/-[^-]*$//; # Drop debian revision
	    if (not exists $pkgused{$pkg}) {
		error("Unexpected package $pkg returned by dpkg-query -W.");
	    }
	    $deps{"$pkg (>= $ver)"} = 1;
	    $deps{"$pkg (<< $ver.0~)"} = 1 if $pkgused{$pkg} ne "replace";
	}
	close($output) or error("failed to close pipe with dpkg-query -W");
	wait_child($pid, cmdline => "dpkg-query -W @{[sort keys %pkgused]}");

	my $gendeps = join(", ", sort keys %deps);
	verbose_print("Generated dependency: $gendeps");
	addsubstvar($package, "misc:Depends", $gendeps);
}

=head1 SEE ALSO

L<debhelper(7)>

This program is a part of debhelper.

=head1 AUTHOR

Raphael Hertzog <hertzog@debian.org>
Joey Hess <joeyh@debian.org>

=cut