diff options
Diffstat (limited to 'tools/install-xml-file-list')
| -rwxr-xr-x | tools/install-xml-file-list | 356 |
1 files changed, 0 insertions, 356 deletions
diff --git a/tools/install-xml-file-list b/tools/install-xml-file-list deleted file mode 100755 index 4630a89fa..000000000 --- a/tools/install-xml-file-list +++ /dev/null @@ -1,356 +0,0 @@ -#!/usr/bin/perl - -use MDK::Common; -use XML::Parser; -use Data::Dumper; -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 $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); - -install_needed_libraries(); - -final_cleanup(); - -sub final_cleanup() { - #- cpio creates directory 700, that's not nice - system("find $DEST -type d | xargs $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!; - } - } - @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, '/')) { - $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 = glob($f) or die "no match for $f\n"; - - @l == 1 || $b_full_glob or die "multiple match for $f\n"; - } else { - -e $f or die "missing file $f ($rel) in $working_dir\n"; - } - if (@l == 1 && -d $l[0] && $b_recursive_dirs) { - @l = all_files_rec_($l[0]); - } - @l = grep { !m!/CVS($|/)! } @l; - if (my $re = $env->{from}{matching}) { - @l = grep { eval $re } @l; - } - - collect_needed_libraries(grep { -x $_ } @l); - - chdir $initial_dir; - @l; - }; - - my @files; - if ($expand eq 'tar') { - foreach (split(' ', $text)) { - system('tar', 'xfj', $from_file->($_), '-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 = split(' ', $text); - - } 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($_) } split(' ', $text)) { - my @l = grep { -x $_ } map { "$_/$name" } @PATH; - @l or die "can't find binary $name\n"; - 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; - 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 (split(' ', $text)) { - my @l = chomp_(`rpm -ql $rpm`) or die "rpm $rpm must be installed\n"; - push @files, @l; - } - - } elsif ($expand eq 'perl') { - $disallow_from_dir->(); - $from_dir = '/usr/lib/perl5/vendor_perl/*'; - @files = split(' ', $text); - } elsif ($expand eq 'main-perl') { - $disallow_from_dir->(); - $from_dir = $Config{privlib}; - @files = split(' ', $text); - } elsif ($expand =~ /collect-perl-files/) { - my (undef, $local, $to) = split(' ', $expand); - - @files = split(' ', $text); - 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"; - copy_and_filter("$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 = split(' ', $text); - - $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'), - ); - 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; - - 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; - } - 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) ] }; - } -} |