summaryrefslogtreecommitdiffstats
path: root/tools
diff options
context:
space:
mode:
authorPascal Rigaux <pixel@mandriva.com>2005-05-10 08:40:01 +0000
committerPascal Rigaux <pixel@mandriva.com>2005-05-10 08:40:01 +0000
commit53fc42dd19e14154042e1fbe82ea0d5fc5a5e2f1 (patch)
tree148de82cf3714d16ae0de33204718f36f3483574 /tools
parentdc9545e4c654c0112c18be0444c75e2c4dc9bc09 (diff)
downloaddrakx-backup-do-not-use-53fc42dd19e14154042e1fbe82ea0d5fc5a5e2f1.tar
drakx-backup-do-not-use-53fc42dd19e14154042e1fbe82ea0d5fc5a5e2f1.tar.gz
drakx-backup-do-not-use-53fc42dd19e14154042e1fbe82ea0d5fc5a5e2f1.tar.bz2
drakx-backup-do-not-use-53fc42dd19e14154042e1fbe82ea0d5fc5a5e2f1.tar.xz
drakx-backup-do-not-use-53fc42dd19e14154042e1fbe82ea0d5fc5a5e2f1.zip
create install-xml-file-list and use it to replace share/list and share/list.ARCH with share/list.xml
Diffstat (limited to 'tools')
-rwxr-xr-xtools/install-xml-file-list279
1 files changed, 279 insertions, 0 deletions
diff --git a/tools/install-xml-file-list b/tools/install-xml-file-list
new file mode 100755
index 000000000..0cd1fc1cc
--- /dev/null
+++ b/tools/install-xml-file-list
@@ -0,0 +1,279 @@
+#!/usr/bin/perl
+
+use MDK::Common;
+use XML::Parser;
+use Data::Dumper;
+use Config;
+use Cwd 'cwd';
+
+@ARGV == 2 or die "usage: install-xml-file-list <xml file> <destination>\n";
+my ($xml_file_list, $DEST) = @ARGV;
+
+my $initial_dir = cwd();
+my $ARCH = arch() =~ /i.86/ ? 'i386' : arch();
+my $LIB = arch() =~ /x86_64/ ? "lib64" : "lib";
+
+my $base_cpio_options = '-pumd --quiet';
+
+system("rm -rf $DEST");
+
+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 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->{$_}/;
+ } 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 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!\bREP4PMS\b!$ENV{REP4PMS} || die "REP4PMS 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) {
+ s!^(/lib(64)?/).*?/!$1! if $main_node->{attr}{'no-arch-libraries'}; #- replace /lib/tls or /lib/i686 with /lib
+ }
+ @to_check = grep { !$needed_libraries{$_}++ } @l;
+ @to_check = ();
+ }
+}
+sub install_needed_libraries {
+ copy_files('', $DEST, [ keys %needed_libraries ], '', '--dereference');
+}
+
+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 ; 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 ; 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 = $env->{from}{dir};
+ my $to_dir = $DEST . expand_macros($env->{to}{dir} || $env->{to}{flatten} && $from_dir || '');
+ 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\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 (split(' ', $text)) {
+ my @l = grep { -x $_ } map { "$_/$name" } @PATH;
+ @l or die "can't find binary $name\n";
+ if (my @m = grep { ! -l $_ } @l) {
+ @l = @m;
+ }
+ @l == 1 or die "many matches for binary $name: " . join(' ', @l) . "\n";
+ push @files, @l;
+ }
+ $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) {
+ 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 $copy_mode = $env->{mode}{copy} || '';
+ my @options = (
+ if_($copy_mode ne 'keep-links', '--dereference'),
+ );
+ copy_files($working_dir, $to_dir, \@all_files, $env->{to}{flatten}, @options);
+
+ {
+ chdir $to_dir;
+ foreach (group_by_n(20, \@all_files)) {
+ my @l = $env->{to}{flatten} ? (map { basename($_) } @$_) : (map { "./$_" } @$_);
+ @l = grep { ! -d $_ } @l;
+
+ if (my $subst = $env->{filter}{subst}) {
+ system('perl', '-pi', '-e', $subst, @l);
+ }
+ if (my $command = $env->{filter}{command}) {
+ my @options = (
+ if_($command eq 'gzip', '-9'),
+ if_($command eq 'strip', '2>/dev/null'),
+ );
+ 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) ] };
+ }
+}