diff options
Diffstat (limited to 'tools/install-xml-file-list')
| -rwxr-xr-x | tools/install-xml-file-list | 382 |
1 files changed, 382 insertions, 0 deletions
diff --git a/tools/install-xml-file-list b/tools/install-xml-file-list new file mode 100755 index 000000000..f53f6993b --- /dev/null +++ b/tools/install-xml-file-list @@ -0,0 +1,382 @@ +#!/usr/bin/perl + +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}"; +} + +#$verbose = 1; + +my $initial_dir = cwd(); +my $ARCH = arch() =~ /i.86/ ? 'i386' : arch(); +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, $dest, @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 = $env->{from}{matching}) { + @l = grep { eval $re } @l; + } + + collect_needed_libraries(grep { -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(/sbin /bin /usr/bin /usr/sbin /usr/X11R6/bin); + 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') { + $disallow_from_dir->(); + $from_dir = '/usr/lib/perl5/vendor_perl/*'; + @files = @text_l; + } elsif ($expand eq 'main-perl') { + $disallow_from_dir->(); + $from_dir = $Config{privlib}; + @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, $to, @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}) { + 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) ] }; + } +} |