path: root/tools/install-xml-file-list

#!/usr/bin/perl

use FileHandle;
use MDK::Common;
use XML::Parser;
use Data::Dumper;
use File::Glob;
use Config;
use Cwd 'cwd';

my $want_sudo = $ARGV[0] eq '--sudo' && shift @ARGV;

@ARGV == 2 or die "usage: install-xml-file-list [--sudo] <xml file> <destination>\n";
my ($xml_file_list, $DEST) = @ARGV;

my $sudo = '';
if ($>) {
    $sudo = "sudo" if $want_sudo;
    $ENV{PATH} = "/sbin:/usr/sbin:$ENV{PATH}";
}

my $verbose;
#$verbose = 1;

my $initial_dir = cwd();
my $ARCH = arch() =~ /i.86/ ? 'i386' : arch();
$ARCH =~ s/^(arm).*/$1/;
my $LIB = arch() =~ /x86_64/ ? "lib64" : "lib";

my $base_cpio_options = '-pumd --quiet';

my $problem;
my $tree = XML::Parser->new(Style => 'Tree')->parsefile($xml_file_list);

my $main_node = decompose($tree);

$main_node->{tag} eq 'list' or die "bad file $xml_file_list (main tag should be <list>)\n";

handle_nodes({}, $main_node);

$problem and exit 1;

install_needed_libraries();

final_cleanup();

sub error {
    my ($err) = @_;
    warn "FATAL: $err\n";
    $problem = 1;
}

sub final_cleanup() {
    #- cpio creates directory 700, that's not nice
    system("find $DEST -type d -print0 | xargs -0 $sudo chmod 755");
}

sub handle_nodes {
    my ($env, $e) = @_;
    handle_node($env, decompose($_)) foreach @{$e->{l}};
}
sub handle_node {
    my ($env, $node) = @_;

    if (!$node->{tag} && $node->{text} !~ /\S/) {
    } elsif (!$node->{tag}) {
	install($env, $node->{text});
    } elsif ($node->{tag} eq 'if') {
	my $cond = valid_cond($node->{attr});
	handle_nodes($env, $node) if $cond;
    } elsif ($node->{tag} eq 'if-not') {
	my $cond = valid_cond($node->{attr});
	handle_nodes($env, $node) if !$cond;
    } elsif (member($node->{tag}, 'from', 'to', 'mode', 'filter')) {
	handle_nodes(add_to_env($env, $node->{tag} => $node->{attr}), $node);
    } else {
	warn "expecting tag <from>, not <$node->{tag}>\n";
    }
}

sub valid_cond {
    my ($attr) = @_;
    every {
	if ($_ eq 'ARCH') {
	    $ARCH =~ /$attr->{$_}/;
	} elsif ($_ eq 'set') {
	    $ENV{$attr->{$_}};
	} else {
	    die "<if>: unknown condition $_\n";
	}
    } keys %$attr;
}

sub add_to_env {
    my ($env, $tag, $attr) = @_;
    my %env = map_each { $::a => +{ %$::b } } %$env;
    foreach (keys %$attr) {
	!$env{$tag}{$_} or die qq(overriding attribute <$tag $_="$env{$tag}{$_}"> with $_="$attr->{$_}"\n); 
	$env{$tag}{$_} = $attr->{$_};
    }
    \%env;
}

sub group_by_n {
    my ($n, $l) = @_;
    my (@r, $subl);
    my $i = 0;
    foreach (@$l) {
	if ($i % $n == 0) {
	    push @r, $subl = [];
	}
	push @$subl, $_;
	$i++;
    }
    @r;
}

sub identify_file {
    my ($dev, $ino) = @_;
    "$dev:$ino";
}

sub all_files_rec_ {
    my ($d) = @_;

    $d, -d $d && ! -l $d ? map {  all_files_rec_("$d/$_") } all($d) : ();
}

sub expand_macros {
    my ($f) = @_;
    $f =~ s!\bLIB\b!$LIB!g;
    $f =~ s!\bARCH\b!$ARCH!ge;
    $f =~ s!\$\((\w+)\)!$ENV{$1} || die "$1 undefined\n"!ge;
    $f;
}

my %needed_libraries;
sub collect_needed_libraries {
    my (@to_check) = @_;
    while (@to_check) {
	my $to_check = join(' ', @to_check);
	my @l = `ldd $to_check 2>/dev/null` =~ m! => (/\S+)!g;
	foreach (@l) {
	    if ($main_node->{attr}{'no-arch-libraries'}) {
		#- replace /lib/tls or /lib/i686 with /lib
		s!^(/lib(64)?/).*?/!$1! if arch() !~ /x86_64/;
	    }
	}
	@to_check = grep { !$needed_libraries{$_}++ } @l;	
	@to_check = ();
    }
}
sub install_needed_libraries() {
    copy_files('', $DEST, [ keys %needed_libraries ], '', '--dereference');
}

sub collect_needed_perl_files {
    my ($local_rep, @scripts) = @_;

    my (%local, %global);
    foreach my $script (@scripts) {
	foreach (`strace -efile perl -cw -I$local_rep $script 2>&1`) {
	    my ($f) = /^open\("(.*?)",.*\)\s*=\s*\d+$/ or next;
	    if ($f =~ m!^\Q$local_rep\E/(.*)!) {
		$local{$1} = 1;
	    } elsif (begins_with($f, '/dev/')) {
		# skip
	    } elsif (begins_with($f, '/')) {
		if ($main_node->{attr}{'no-arch-libraries'}) {
		    #- replace /lib/tls or /lib/i686 with /lib
		    $f =~ s!^(/lib(64)?/).*?/!$1! if arch() !~ /x86_64/;
		}
		$global{$f} = 1;
	    }
	}
    }
    [ keys %local ], [ keys %global ];
}

sub copy_files {
    my ($working_dir, $to_dir, $files, $b_flatten, @options) = @_;

    if ($b_flatten) {
	mkdir_p($to_dir);
	my $options = join(' ', '-r', @options);
	foreach (group_by_n(20, $files)) {
	    warn "cp $options to_dir $to_dir from $working_dir: @$_\n" if $verbose;
	    system("cd $working_dir ; $sudo cp $options @$_ $to_dir");
	}
    } else {
	my $options = join(' ', $base_cpio_options, @options);
	warn "cpio $options to_dir=$to_dir from=$working_dir: @$files\n" if $verbose;
	open(my $F, "| cd $working_dir ; $sudo cpio $options $to_dir");
	print $F "$_\n" foreach @$files;
	close($F) or die "cpio $to_dir failed\n";
    }
}

sub install {
    my ($env, $text) = @_;

    my $from_dir = expand_macros($env->{from}{dir});
    my $to_dir = $DEST . expand_macros($env->{to}{dir} || $env->{to}{flatten} && $from_dir || '');
    my $copy_mode = $env->{mode}{copy} || '';
    my $working_dir = '.';

    my $expand = $env->{from}{expand} || '';

    my $disallow_from_dir = sub {
	!$from_dir or die "from dir not allowed with $expand binary\n";
    };

    my $from_file = sub {
	my ($rel, $b_full_glob, $b_recursive_dirs) = @_;
	my $f = expand_macros($from_dir ? "$from_dir/$rel" : $rel);
	my @l = $f;
	chdir $working_dir;
	if ($f =~ /\*/ || $b_full_glob) {
	    @l = File::Glob::bsd_glob($f); #- using bsd_glob because CORE::glob() splits on whitespace and we don't want this
	    if (@l == 0) { 
		error("no match for $f");
	    } elsif (@l == 1 || $b_full_glob) {
	    } else { 
		error("multiple match for $f");
		@l = ();
	    }
	} elsif (! -e $f) {
	    error("missing file $f ($rel) in $working_dir");
	    @l = ();
	}
	if (@l == 1 && -d $l[0] && $b_recursive_dirs) {
	    @l = all_files_rec_($l[0]);
	}
	@l = grep { !m!/(\.svn|CVS)($|/)! } @l;
	if (my $re = expand_macros($env->{from}{matching})) {
	    @l = grep { eval $re } @l;
	}

	collect_needed_libraries(grep { -f $_ && -x $_ } @l);

	chdir $initial_dir;
	@l;
    };

    my @text_l = $env->{from}{spaces_in_filename} ? $text =~ /^\s*(.*?)\s*$/ : split(' ', $text);
    my @files;
    if ($expand eq 'tar') {
	foreach (@text_l) {
	    my ($tarball) = $from_file->($_) or next;
	    system('tar', 'xfj', $tarball, '-C', $to_dir);
	}
	# not filling @files, things are already done

    } elsif ($expand eq 'command') {
	@files = chomp_(`$text`);

    } elsif ($expand eq 'glob') {
	#- glob done in $from_file
	@files = @text_l;

    } elsif ($expand eq 'binary') {
	$disallow_from_dir->();
	my @PATH = qw(/usr/sbin /usr/bin /usr/X11R6/bin);
	unshift(@PATH, "/bin") unless -l "/bin";
	unshift(@PATH, "/sbin") unless -l "/sbin";
	foreach my $name (map { expand_macros($_) } @text_l) {
	    my @l = grep { -x $_ } map { "$_/$name" } @PATH;
	    @l or error("can't find binary $name"), next;
	    if (@l > 1) {
		my @m = grep { ! -l $_ } @l;
		if (@m == 1) {
		    my $id = identify_file($m[0]);
		    push @files, grep { -l $_ && identify_file($_) eq $id } @l;
		}
		@l = @m if @m;
	    }
	    if (@l > 1) {
		warn "many matches for binary $name: " . join(' ', @l) . ", choosing $l[0]\n";
	    }
	    my $f = $l[0];
	    while (1) {
		push @files, $f;
		$copy_mode ne 'dereference' or last;
		my $l = readlink($f) or last;
		if ($l =~ m!/! && $l !~ m!^\.\..*/s?bin/[^/]+$!) {
		    warn "keeping symlink $f -> $l as is\n";
		    last;
		}
		$f = dirname($f) . '/' . $l;
	    }
	}	
	$copy_mode ||= 'keep-links';
	$env->{filter}{command} ||= 'strip';

    } elsif ($expand eq 'rpm') {
	$disallow_from_dir->();
	foreach my $rpm (@text_l) {
	    my @l = chomp_(`rpm -ql $rpm`) or error("rpm $rpm must be installed");
	    push @files, @l;
	}

    } elsif ($expand eq 'perl-bin') {
	$disallow_from_dir->();
	$from_dir = '/usr/LIB/perl5/vendor_perl/';
	@files = @text_l;
    } elsif ($expand eq 'perl') {
	$disallow_from_dir->();
	$from_dir = '/usr/share/perl5/vendor_perl/';
	@files = @text_l;
    } elsif ($expand eq 'main-perl') {
	$disallow_from_dir->();
	$from_dir = $Config{privlib};
	@files = @text_l;
    } elsif ($expand eq 'main-perl-bin') {
	$disallow_from_dir->();
	$from_dir = $Config{archlib};
	@files = @text_l;
    } elsif ($expand =~ /collect-perl-files/) {
	my (undef, $local, $to) = split(' ', $expand);

	@files = @text_l;
	warn "collect-perl-files $local $to @files ($env->{filter}{command})\n";
	my ($local_perl_files, $global_perl_files) = collect_needed_perl_files($local, @files);
	warn "collect-perl-files gave: ", join(' ', @$local_perl_files), "\n";
#	warn "                    and: ", join(' ', @$global_perl_files), "\n";
	copy_and_filter($local =~ m!/! ? $local : "$working_dir/$local", "$DEST$to", $local_perl_files, $env->{filter}, '', '--dereference');
	copy_and_filter('', $DEST, $global_perl_files, $env->{filter}, '', '--dereference');

    } elsif ($expand) {
	die "unknown expand method $expand\n";
    } else {
	@files = @text_l;

	$env->{filter}{command} ||= 'strip' if $to_dir =~ m!/bin$!;
    }

    if ($env->{to}{dir} && $from_dir) {
	$working_dir = $from_dir;
	undef $from_dir;
    }

    my @all_files = map { $from_file->($_, $expand eq 'glob', $expand ne 'rpm') } @files;
   
    my @options = (
	if_($copy_mode ne 'keep-links', '--dereference'),
    );
    if (@all_files) {
	copy_and_filter($working_dir, $to_dir, \@all_files, $env->{filter}, $env->{to}{flatten}, @options);
    }
}

sub copy_and_filter {
    my ($working_dir, $to_dir, $all_files, $filter, $flatten, @copy_options) = @_;

    copy_files($working_dir, $to_dir, $all_files, $flatten, @copy_options);
    apply_filter($to_dir, $filter, $all_files, $flatten);
}

sub apply_filter {
    my ($to_dir, $filter, $all_files, $b_flatten) = @_;

    chdir $to_dir;
    foreach (group_by_n(20, $all_files)) {
	my @l = $b_flatten ? (map { basename($_) } @$_) : (map { "./$_" } @$_);
	@l = grep { ! -d $_ } @l or next;

	if (my $subst = $filter->{subst}) {
	    warn "running substition $subst \n" if $verbose;
	    system('perl', '-pi', '-e', $subst, @l);
	}
	if (my $command = $filter->{command}) {
	    $command = $initial_dir . "/$command" if $command =~ m!^..?/!;
	    if ($command =~ /simplify-drakx-modules/) {
		@l = grep { !/\.so($|\.)/ } @l or next;
	    }
	    my @options = (
		if_($command eq 'gzip', '-9f'),
		if_($command eq 'strip', '2>/dev/null'),
	    );
	    warn "running $command @options @l\n" if $verbose;
	    system(join(' ', $command, @options, @l));
	}
    }
    chdir $initial_dir;
}

sub decompose {
    my ($tree) = @_;
    my ($tag, $val) = @$tree;
    if ($tag eq '0') {
	{ text => $val };
    } else {
	my ($attr, @l) = @$val;
	{ tag => $tag, attr => $attr, l => [ group_by2(@l) ] };
    }
}