rev 9878 - scripts
Modestas Vainius
modax-guest at alioth.debian.org
Wed Mar 26 23:37:07 UTC 2008
Author: modax-guest
Date: 2008-03-26 23:37:05 +0000 (Wed, 26 Mar 2008)
New Revision: 9878
Modified:
scripts/dh_installgen
Log:
* Many enhancement esp. wrt handling of symlinks.
* New match pattern: link and its target.
* Dependencies - which package should be processed first.
Modified: scripts/dh_installgen
===================================================================
--- scripts/dh_installgen 2008-03-26 23:03:41 UTC (rev 9877)
+++ scripts/dh_installgen 2008-03-26 23:37:05 UTC (rev 9878)
@@ -108,13 +108,12 @@
my $builddir = shift;
if ($builddir_cache{'builddir'} ne $builddir) {
my %cache;
- File::Find::find(sub {
+ File::Find::find({ wanted => sub {
my $key;
- if ($_ eq "debian" && -d) {
+ if (m/debian$/ && -d) {
$File::Find::prune = 1;
return;
} elsif (-f) {
- # Size
$key = ((stat($_))[7] / (1024*256));
} elsif (-l) {
$key = 'links';
@@ -122,8 +121,8 @@
return;
}
$cache{$key} = [] unless exists $cache{$key};
- push @{$cache{$key}}, new DH::AI::File($File::Find::name);
- }, $builddir);
+ push @{$cache{$key}}, new DH::AI::File($_);
+ }, no_chdir => 1 }, $builddir);
$builddir_cache{'builddir'} = $builddir;
$builddir_cache{'cache'} = \%cache;
}
@@ -141,36 +140,64 @@
return bless($self, $cls);
}
+sub is_link {
+ return shift()->{is_link};
+}
+
sub get_path($) {
my $self = shift;
sub gp_internal($) {
my $path = shift;
- if ($path && (-f $path)) {
- return $path;
- } elsif ($path && (-l $path)) {
+ if ($path && (-l $path)) {
+ my $first_path = $path;
while (-l $path) {
- $path = readlink($path);
+ $_ = readlink($path);
+ if (m#^/#) {
+ $path = $_;
+ } else {
+ $path = main::dirname($path) . "/" . $_
+ }
}
- return (-f $path) ? $path : undef;
+ if (! -f $path && $path =~ m#^/# ) {
+ my $old_path = $path;
+ my @parts = split /\/+/, $first_path;
+ while (! -f $path && @parts) {
+ $path = shift(@parts) . "/" . $path;
+ }
+ $path = $old_path if (! -f $path);
+ }
+ return $path;
+ } elsif ($path && -f $path) {
+ return $path;
}
return undef;
}
- my $path;
- $path = gp_internal($self->{dst});
- return $path if $path;
- $path = gp_internal($self->{src});
- return $path if $path;
+ $self->{path} = gp_internal($self->{dst}) if (!exists($self->{path}));
+ return $self->{path};
}
+sub _stripped_path($$) {
+ my ($path, $prefix) = @_;
+ if ($path) {
+ $path =~ s/^\Q$prefix\E\/?//;
+ return $path;
+ } else {
+ return undef;
+ }
+}
+
sub stripped_path($$) {
my ($self, $prefix) = @_;
- my $path = $self->get_path();
- $path =~ s/^\Q$prefix\E\/?//;
- return $path;
+ return _stripped_path($self->get_path(), $prefix);
}
+sub stripped_dstpath($$) {
+ my ($self, $prefix) = @_;
+ return _stripped_path($self->{dst}, $prefix);
+}
+
sub calc_checksum {
my $self = shift;
my $path = shift;
@@ -193,7 +220,9 @@
sub get_cache_key($) {
my $self = shift;
- if (my $path = $self->get_path()) {
+ if ($self->{is_link}) {
+ return 'links';
+ } elsif (my $path = $self->get_path()) {
return ((stat($path))[7] / (1024*256));
}
}
@@ -220,10 +249,12 @@
if ($self->{is_link}) {
# Search among links first
- if (!($self->{src} = $self->locate_in_cache($cache, 'links'))) {
+ if (!($self->{src} = $self->locate_in_cache($cache))) {
my $path = $self->get_path();
- my $new_file = new DH::AI::File($path);
- $self->{src} = $new_file->locate_in_cache($cache);
+ if (-f $path) {
+ my $new_file = new DH::AI::File($path);
+ $self->{src} = $new_file->locate_in_cache($cache);
+ }
}
main::warning("Unable to locate a source file for the link: " . $self->{dst})
@@ -241,9 +272,10 @@
my ($self, $other) = @_;
if ($self->{is_link} && $other->{is_link}) {
+ print $self->{dst}, " => ", $other->{dst}, "\n";
# Match by basename of the link and readlink
- return (basename($self->{dst}) eq basename($other->{dst}) &&
- basename($self->get_path()) eq basename($other->get_path()));
+ return (main::basename($self->{dst}) eq main::basename($other->{dst}) &&
+ $self->get_path() eq $other->get_path());
} elsif (!($self->{is_link} && ($other->{is_link}))) {
# I.e. file
$self->{chksum} = $self->calc_checksum() unless ($self->{chksum});
@@ -326,12 +358,21 @@
return ($self->{negated}) ? !$result : $result;
}
+sub has_value {
+ return defined shift()->{value};
+}
+
package DH::AI::Pattern::Src;
our @ISA = qw( DH::AI::Pattern::Common );
sub new {
my $self = DH::AI::Pattern::Common::new(@_);
- $self->{regex} = qr{$self->{value}};
+ if ($self->{value} && !($self->{value} =~ m/^\s*$/)) {
+ $self->{regex} = qr{$self->{value}};
+ } else {
+ $self->{value} = undef;
+ $self->{regex} = qr/.*/;
+ }
return $self;
}
@@ -365,6 +406,19 @@
return $self->_match_filename($file->{dst});
}
+package DH::AI::Pattern::Link;
+our @ISA = qw( DH::AI::Pattern::Src );
+
+sub type {
+ "link";
+}
+
+sub _match {
+ my ($self, $file) = @_;
+ return $file->{is_link} && (!$self->has_value() ||
+ $self->_match_filename($file->get_path()));
+}
+
package DH::AI::Pattern::Magic;
our @ISA = qw( DH::AI::Pattern::Common );
@@ -392,14 +446,19 @@
sub _match {
my ($self, $file) = @_;
- if (my $path = $file->get_path()) {
- my $mime = get_mimetype($path);
- if (defined $mime) {
- return $mime =~ m/$self->{regex}/;
+ if (! exists $file->{__mime__}) {
+ if (my $path = $file->get_path()) {
+ $file->{__mime__} = get_mimetype($path);
} else {
- return 0;
+ $file->{__mime__} = undef;
}
}
+ my $mime = $file->{__mime__};
+ if (defined $mime) {
+ return $mime =~ m/$self->{regex}/;
+ } else {
+ return 0;
+ }
return 0;
}
@@ -414,10 +473,13 @@
if ($p =~ m/^(inst|miss)(?:all|ing)?$/) {
$action = $1;
shift @$pattern;
- } else {
+ } elsif ($p =~ m/^depends$/) {
+ # Ignore. Not interesting here
+ return bless({ action => "ignr", pats => [] }, $cls);
+ } else{
$action = "inst"; # default
}
- my $self = bless( { action => $action }, $cls);
+ my $self = bless( { action => $action, pats => [] }, $cls);
while (@$pattern > 0) {
my $negated = 0;
@@ -433,6 +495,8 @@
$self->add_pattern(new DH::AI::Pattern::Dst($negated,$1));
} elsif ($p =~ m/^src:(.*)$/){
$self->add_pattern(new DH::AI::Pattern::Src($negated, $1));
+ } elsif ($p =~ m/^link:(.*)$/) {
+ $self->add_pattern(new DH::AI::Pattern::Link($negated, $1));
} elsif ($p =~ m/^mime:(.*)$/) {
$self->add_pattern(new DH::AI::Pattern::Magic($negated, $1));
} else {
@@ -445,7 +509,8 @@
sub add_pattern {
my ($self, $p) = @_;
- if (my $type = $p->type()) {
+ my $type = $p->type();
+ if ($type) {
if (exists $self->{$type}) {
$self->{$type}++;
} else {
@@ -477,38 +542,54 @@
###########################################################################
package main;
+my %autoremove;
+my %autoadd;
+
+init();
+
+my $installed = new DH::AI::Installed;
+
+my $srcdir = '.';
+$srcdir = $dh{SOURCEDIR}."/" if defined $dh{SOURCEDIR};
+
+my $builddir = '.';
+$builddir = $dh{DESTDIR} . "/" if defined $dh{DESTDIR};
+
+
sub rewrite_install_file($\@\@) {
my ($file, $remove, $add) = @_;
if (@$remove || @$add) {
- # Read. Remove non-matching patterns
- open (DH_INSTALL, "<$file") || error("cannot read $file: $!");
my $p = shift @$remove;
my @lines;
my $again = 0;
- while ($again || ($_ = <DH_INSTALL>)) {
- if (defined $p && !m/^#/ && m/(?:^|\s+)\Q$p\E(?:\s+|$)/) {
- my @set = split;
- if (! defined $dh{AUTODEST} && @set > 1) {
- s/((?:^|\s+)\Q$p\E\s*)(?!$)/ /;
+ # Read. Remove non-matching patterns
+ if (-r $file) {
+ open (DH_INSTALL, "<$file") || error("cannot read $file: $!");
+ while ($again || ($_ = <DH_INSTALL>)) {
+ if (defined $p && !m/^#/ && m/(?:^|\s+)\Q$p\E(?:\s+|$)/) {
+ my @set = split;
+ if (! defined $dh{AUTODEST} && @set > 1) {
+ s/((?:^|\s+)\Q$p\E\s*)(?!$)/ /;
+ } else {
+ s/((?:^|\s+)\Q$p\E\s*)/ /;
+ }
+ if (@set == 1 || @set == 2) {
+ # Move on
+ $p = shift @$remove;
+ } else {
+ # Check for another match
+ $_ = chomp() . "\n";
+ $again = 1;
+ next;
+ }
} else {
- s/((?:^|\s+)\Q$p\E\s*)/ /;
+ push @lines, $_;
}
- if (@set == 1 || @set == 2) {
- # Move on
- $p = shift @$remove;
- } else {
- # Check for another match
- $_ = chomp() . "\n";
- $again = 1;
- next;
- }
- } else {
- push @lines, $_;
+ $again = 0;
}
- $again = 0;
+ close(DH_INSTALL);
}
- close(DH_INSTALL);
push @lines, map { "$_\n" } @$add if (@$add);
@@ -518,27 +599,68 @@
}
close(DH_INSTALL);
if ($dh{NO_ACT}) {
- system("diff", "-u", "$file", "$file.tmp");
+ system("diff", "-uN", "$file", "$file.tmp");
} else {
doit("mv", "$file.tmp", "$file");
}
}
}
+sub installgen_process {
+ my ($package, $pdepends, $pdone, $missing) = @_;
-init();
+ return if (!exists $pdone->{$package} || $pdone->{$package});
-my $installed = new DH::AI::Installed;
+ # Process dependencies first
+ $pdone->{$package} = 2; # Processing
+ foreach my $dep (@{$pdepends->{$package}}) {
+ next if ($dep eq $package); # might happen in case of 'last'
-my $srcdir = '.';
-$srcdir = $dh{SOURCEDIR}."/" if defined $dh{SOURCEDIR};
+ if ($pdone->{$dep} == 2) {
+ verbose_print("installgen dependency loop for the package $dep detected. Breaking it...");
+ } elsif ($pdone->{$dep} == 0) {
+ installgen_process($dep, $pdepends, $pdone, $missing);
+ }
+ }
-my $builddir = '.';
-$builddir = $dh{DESTDIR} . "/" if defined $dh{DESTDIR};
+ # Handle our *.installgen
+ my $gfile=pkgfile($package, "installgen");
-my %autoremove;
-my %autoadd;
+ my @installgen;
+ if ($gfile) {
+ @installgen=filedoublearray($gfile);
+ }
+ my @autoadd;
+
+ if (@$missing && @installgen) {
+ for my $set (@installgen) {
+ my $pattern = new DH::AI::Pattern($set);
+
+ # Search for the missing files in the source/build tree
+ foreach my $miss (@$missing) {
+ next if $miss->{found};
+
+ if ($pattern->has_type("src") && ! defined($miss->{src})) {
+ $miss->locate($builddir);
+ }
+ my $match = $pattern->match($miss);
+ if (defined $match) {
+ if ($match eq "inst") {
+ push @autoadd, $miss->stripped_dstpath($srcdir);
+ } # Otherwise the file was defined as missing on purpose
+ $miss->{found} = 1;
+ }
+ }
+ }
+ }
+
+ $autoadd{$package} = \@autoadd;
+
+ $pdone->{$package} = 1; # Complete
+}
+
+
foreach my $package (@{$dh{DOPACKAGES}}) {
my $tmp=tmpdir($package);
my $file=pkgfile($package,"install");
@@ -596,48 +718,55 @@
my @missing = ();
-find(sub {
+find( { wanted => sub {
-f || -l || return;
- $_="$File::Find::dir/$_";
- my $bn = basename($_);
if (! excludefile($_) && ! $installed->check($_) ) {
push @missing, new DH::AI::File($_);
}
-}, $srcdir);
+}, no_chdir => 1 }, $srcdir);
+# We need to determine package processing order
+my %pdepends;
+my %pdone;
+my @pkgs;
foreach my $package (@{$dh{DOPACKAGES}}) {
my $gfile=pkgfile($package, "installgen");
- my @installgen;
- if ($gfile) {
- @installgen=filedoublearray($gfile);
- }
+ if (-r $gfile) {
+ open(GFILE, $gfile);
+ while (<GFILE>) {
+ last if (!m/^(?:#|\s*$)/);
+ }
+ close GFILE;
- my @autoadd;
-
- if (@missing && @installgen) {
- for my $set (@installgen) {
- my $pattern = new DH::AI::Pattern($set);
-
- # Search for the missing files in the source/build tree
- foreach my $miss (@missing) {
- next if $miss->{found};
-
- if ($pattern->has_type("src") && ! defined($miss->{src})) {
- $miss->locate($builddir);
+ my @parts = split;
+ my $p = shift @parts;
+ if (defined $p && $p eq "depends") {
+ if (@parts > 0) {
+ if ($parts[0] eq "first") {
+ unshift @pkgs, $package;
+ $pdepends{$package} = [];
+ } elsif ($parts[0] eq "last") {
+ push @pkgs, $package;
+ $pdepends{$package} = \@pkgs;
+ } else {
+ push @pkgs, $package;
+ $pdepends{$package} = \@parts;
}
- my $match = $pattern->match($miss);
- if (defined $match) {
- if ($match eq "inst") {
- push @autoadd, $miss->stripped_path($srcdir);
- } # Otherwise the file was defined as missing on purpose
- $miss->{found} = 1;
- }
}
}
+
+ if (!exists $pdepends{$package}) {
+ push @pkgs, $package;
+ $pdepends{$package} = [];
+ }
+ $pdone{$package} = 0;
}
+}
- $autoadd{$package} = \@autoadd;
+# Process all packages for installgen (recursively)
+foreach my $package (@pkgs) {
+ installgen_process($package, \%pdepends, \%pdone, \@missing);
}
if ($dh{LIST_MISSING} || $dh{FAIL_MISSING}) {
@@ -645,7 +774,7 @@
foreach (@missing) {
unless ($_->{found}) {
$unmatched++;
- warning $_->stripped_path($srcdir) .
+ warning $_->stripped_dstpath($srcdir) .
" exists in $srcdir but is not installed to anywhere" if ($dh{LIST_MISSING});
}
}
@@ -656,6 +785,7 @@
foreach my $package (@{$dh{DOPACKAGES}}) {
my $file=pkgfile($package, "install");
+ $file = "debian/$package.install" if (! -r $file);
rewrite_install_file($file, @{$autoremove{$package}}, @{$autoadd{$package}});
}
More information about the pkg-kde-commits
mailing list