[SCM] Debian package checker branch, master, updated. 2.5.11-139-g76f1c80
The following commit has been merged in the master branch:
commit 2deff68ed05b4099eb56209f7a1c3eb88f3edbcf
Author: Niels Thykier <niels@thykier.net>
Date: Wed Jan 30 13:14:09 2013 +0100
Add new collection interface to reduce overhead
The major overhead in running collections are loading the required
Perl Modules (again). As an example, loading Lintian::Util has a cost
of 0.040 seconds (the first time). With a couple of extra modules,
coll/hardening-info has a average "no-op" runtime of at least 0.150s.
Eliminating the module load overhead, it drops to 0.065s.
This patch set creates a new (backwards compatible) interface for
invoking collections. Instead of doing a complete fork+exec, the new
interface loads the collection script like a perl module and load a
"collect" sub (similar to how scripts work). This interface can still
be combined with fork for parallelization.
Because it avoids the exec, the child process retrains the cache of
(most of) the Perl Modules. This vastly reduces the "start up" time
for the collections.
Signed-off-by: Niels Thykier <niels@thykier.net>
diff --git a/collection/ar-info b/collection/ar-info
index 4e2c103..e891e13 100755
--- a/collection/ar-info
+++ b/collection/ar-info
@@ -19,6 +19,8 @@
# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
# MA 02110-1301, USA.
+package Lintian::coll::ar_info;
+
use strict;
use warnings;
@@ -28,8 +30,8 @@ use Lintian::Collect;
use Lintian::Command qw(spawn);
use Lintian::Util qw(fail);
-($#ARGV == 2) or fail 'syntax: ar-info <pkg> <type> <dir>';
-my ($pkg, $type, $dir) = @ARGV;
+sub collect {
+ my ($pkg, $type, $dir) = @_;
my $info = Lintian::Collect->new ($pkg, $type, $dir);
if ( -e "$dir/ar-info" ) {
@@ -59,6 +61,10 @@ foreach my $file ($info->sorted_index) {
}
close(OUT) or fail("cannot write ar-info: $!");
+}
+
+collect (@ARGV) if $0 =~ m,(?:^|/)ar-info$,;
+1;
# Local Variables:
# indent-tabs-mode: nil
diff --git a/collection/ar-info.desc b/collection/ar-info.desc
index 5772f6a..cd9e2e6 100644
--- a/collection/ar-info.desc
+++ b/collection/ar-info.desc
@@ -4,3 +4,4 @@ Info: This script runs the "ar t" command over all .a files of package.
Type: binary
Needs-Info: unpacked, index
Version: 1
+Interface: perl-coll
diff --git a/collection/bin-pkg-control b/collection/bin-pkg-control
index 6325973..97e9c50 100755
--- a/collection/bin-pkg-control
+++ b/collection/bin-pkg-control
@@ -19,6 +19,8 @@
# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
# MA 02110-1301, USA.
+package Lintian::coll::bin_pkg_control;
+
use strict;
use warnings;
@@ -26,8 +28,8 @@ use lib "$ENV{'LINTIAN_ROOT'}/lib";
use Lintian::Command qw(spawn reap);
use Lintian::Util qw(delete_dir fail);
-($#ARGV == 2) or fail 'syntax: bin-pkg-control <pkg> <type> <dir>';
-my ($pkg, $type, $dir) = @ARGV;
+sub collect {
+my ($pkg, $type, $dir) = @_;
my (@jobs, $job);
if ( -e "$dir/control"){
@@ -74,7 +76,11 @@ unlink "$dir/control.tar" or fail "unlink control.tar: $!";
spawn({ fail => 'error' },
['chmod', '-R', 'u+rX,o-w', "$dir/control"]);
-exit 0;
+}
+
+collect (@ARGV) if $0 =~ m,(?:^|/)bin-pkg-control$,;
+
+1;
# Local Variables:
# indent-tabs-mode: nil
diff --git a/collection/bin-pkg-control.desc b/collection/bin-pkg-control.desc
index b5e08f6..7406c40 100644
--- a/collection/bin-pkg-control.desc
+++ b/collection/bin-pkg-control.desc
@@ -3,3 +3,4 @@ Info: This script extracts the contents of control.tar into the control/
and creates control-index as well.
Type: binary, udeb
Version: 2
+Interface: perl-coll
diff --git a/collection/changelog-file b/collection/changelog-file
index ade55c1..416d6c1 100755
--- a/collection/changelog-file
+++ b/collection/changelog-file
@@ -19,14 +19,16 @@
# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
# MA 02110-1301, USA.
+package Lintian::coll::changelog_file;
+
use strict;
use warnings;
use lib "$ENV{'LINTIAN_ROOT'}/lib";
use Lintian::Util qw(fail gunzip_file);
-($#ARGV == 2) or fail('syntax: changelog-file <pkg> <type> <dir>');
-my ($pkg, $type, $dir) = @ARGV;
+sub collect {
+my ($pkg, $type, $dir) = @_;
unlink "$dir/changelog" or fail "cannot remove changelog file: $!"
if -e "$dir/changelog" or -l "$dir/changelog";
@@ -129,6 +131,12 @@ if (-f $news) {
}
}
+}
+
+collect (@ARGV) if $0 =~ m,(?:^|/)changelog-file$,;
+
+1;
+
# Local Variables:
# indent-tabs-mode: nil
# cperl-indent-level: 4
diff --git a/collection/changelog-file.desc b/collection/changelog-file.desc
index caa6950..4a5021d 100644
--- a/collection/changelog-file.desc
+++ b/collection/changelog-file.desc
@@ -6,3 +6,4 @@ Info: This script copies the <tt>changelog</tt> file and
Type: binary
Version: 1
Needs-Info: unpacked
+Interface: perl-coll
diff --git a/collection/copyright-file b/collection/copyright-file
index b77afaf..20ff5db 100755
--- a/collection/copyright-file
+++ b/collection/copyright-file
@@ -19,6 +19,8 @@
# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
# MA 02110-1301, USA.
+package Lintian::coll::copyright_file;
+
use strict;
use warnings;
@@ -27,8 +29,8 @@ use Lintian::Util qw(fail gunzip_file touch_file);
use File::Copy qw(copy);
-($#ARGV == 2) or fail 'syntax: copyright-file <pkg> <type> <dir>';
-my ($pkg, $type, $dir) = @ARGV;
+sub collect {
+my ($pkg, $type, $dir) = @_;
if ( -e "$dir/copyright" ) {
unlink "$dir/copyright" or fail "unlink copyright: $!";
@@ -56,7 +58,11 @@ if (-l $file) {
touch_file ("$dir/copyright");
}
-exit 0;
+}
+
+collect (@ARGV) if $0 =~ m,(?:^|/)copyright-file$,;
+
+1;
# Local Variables:
# indent-tabs-mode: nil
diff --git a/collection/copyright-file.desc b/collection/copyright-file.desc
index beda287..d8e7610 100644
--- a/collection/copyright-file.desc
+++ b/collection/copyright-file.desc
@@ -5,3 +5,4 @@ Info: This script copies the <tt>copyright</tt> file of a package into the
Type: binary
Version: 1
Needs-Info: unpacked
+Interface: perl-coll
diff --git a/collection/debfiles b/collection/debfiles
index 48d25f8..059f474 100755
--- a/collection/debfiles
+++ b/collection/debfiles
@@ -19,6 +19,8 @@
# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
# MA 02110-1301, USA.
+package Lintian::coll::debfiles;
+
use strict;
use warnings;
@@ -26,8 +28,8 @@ use warnings;
use lib "$ENV{'LINTIAN_ROOT'}/lib";
use Lintian::Util qw(copy_dir delete_dir fail);
-($#ARGV == 2) or fail 'syntax: debfiles <pkg> <type> <dir>';
-my ($pkg, $type, $dir) = @ARGV;
+sub collect {
+my ($pkg, $type, $dir) = @_;
-e "$dir/unpacked" or fail 'debfiles invoked with wrong dir argument';
@@ -52,6 +54,12 @@ if ( -l "$dir/unpacked/debian" ) {
copy_dir ("$dir/unpacked/debian/", "$dir/debfiles")
or fail("cannot copy unpacked/debian to debfiles: $!");
+}
+
+collect (@ARGV) if $0 =~ m,(?:^|/)debfiles$,;
+
+1;
+
# Local Variables:
# indent-tabs-mode: nil
# cperl-indent-level: 4
diff --git a/collection/debfiles.desc b/collection/debfiles.desc
index 18c7e92..35c9611 100644
--- a/collection/debfiles.desc
+++ b/collection/debfiles.desc
@@ -5,3 +5,4 @@ Info: This script collects files shipped in the source of the
Type: source
Version: 1
Needs-Info: unpacked
+Interface: perl-coll
diff --git a/collection/debian-readme b/collection/debian-readme
index 177dc38..48e5cc3 100755
--- a/collection/debian-readme
+++ b/collection/debian-readme
@@ -19,14 +19,16 @@
# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
# MA 02110-1301, USA.
+package Lintian::coll::debian_readme;
+
use strict;
use warnings;
use lib "$ENV{'LINTIAN_ROOT'}/lib";
use Lintian::Util qw(fail gunzip_file touch_file);
-($#ARGV == 2) or fail 'syntax: debian-readme <pkg> <type> <dir>';
-my ($pkg, $type, $dir) = @ARGV;
+sub collect {
+my ($pkg, $type, $dir) = @_;
if ( -f "$dir/README.Debian") {
unlink "$dir/README.Debian" or fail "Could not remove old README.Debian: $!";
@@ -60,6 +62,12 @@ if (not defined $file) {
or fail("cannot link $file to README.Debian: $!");
}
+}
+
+collect (@ARGV) if $0 =~ m,(?:^|/)debian-readme$,;
+
+1;
+
# Local Variables:
# indent-tabs-mode: nil
# cperl-indent-level: 4
diff --git a/collection/debian-readme.desc b/collection/debian-readme.desc
index 0fd103d..5e35524 100644
--- a/collection/debian-readme.desc
+++ b/collection/debian-readme.desc
@@ -5,3 +5,4 @@ Info: This script copies the <tt>README.Debian</tt> file of a package into
Type: binary
Version: 1
Needs-Info: unpacked
+Interface: perl-coll
diff --git a/collection/diffstat b/collection/diffstat
index 31a313b..6906fbc 100755
--- a/collection/diffstat
+++ b/collection/diffstat
@@ -25,14 +25,16 @@
# perl code will be perl modules, so only one perl interpreter
# need be started.
+package Lintian::coll::diffstat;
+
use strict;
use warnings;
use lib "$ENV{'LINTIAN_ROOT'}/lib";
use Lintian::Util qw(fail get_dsc_info gunzip_file);
-($#ARGV == 2) or fail 'syntax: diffstat <pkg> <type> <dir>';
-my ($pkg, undef, $dir) = @ARGV;
+sub collect {
+my ($pkg, undef, $dir) = @_;
my $data;
my $ver;
@@ -47,7 +49,7 @@ unlink "$dir/debian-patch" or fail "cannot unlink debian-patch: $!"
$ver =~ s/^\d://; #Remove epoch for this
my $diff_file = "$dir/${pkg}_${ver}.diff.gz";
-exit 0 unless (-f $diff_file);
+return unless (-f $diff_file);
gunzip_file($diff_file, "$dir/debian-patch");
@@ -66,6 +68,12 @@ while (<DIFF>) {
close DIFF or fail("cannot close pipe to diffstat on debian-patch: $!");
close STAT or fail("error writing diffstat file: $!");
+}
+
+collect (@ARGV) if $0 =~ m,(?:^|/)diffstat$,;
+
+1;
+
# Local Variables:
# indent-tabs-mode: nil
# cperl-indent-level: 4
diff --git a/collection/diffstat.desc b/collection/diffstat.desc
index a714306..69f79e8 100644
--- a/collection/diffstat.desc
+++ b/collection/diffstat.desc
@@ -4,3 +4,4 @@ Info: This script extracts the Debian diff of a source package, and runs
diffstat on it, leaving the result in the diffstat output file
Type: source
Version: 1
+Interface: perl-coll
diff --git a/collection/doc-base-files b/collection/doc-base-files
index d9aeec1..d2e38da 100755
--- a/collection/doc-base-files
+++ b/collection/doc-base-files
@@ -20,14 +20,16 @@
# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
# MA 02110-1301, USA.
+package Lintian::coll::doc_base_files;
+
use strict;
use warnings;
use lib "$ENV{'LINTIAN_ROOT'}/lib";
use Lintian::Util qw(copy_dir delete_dir fail);
-($#ARGV == 2) or fail 'syntax: doc-base-files <pkg> <type> <dir>';
-my ($pkg, $type, $dir) = @ARGV;
+sub collect {
+my ($pkg, $type, $dir) = @_;
if ( -e "$dir/doc-base") {
delete_dir ("$dir/doc-base")
@@ -41,6 +43,11 @@ if ( -d "$dir/unpacked/usr/share/doc-base") {
# no doc-base directory
mkdir ("$dir/doc-base", 0777) or fail "cannot mkdir doc-base: $!";
}
+}
+
+collect (@ARGV) if $0 =~ m,(?:^|/)doc-base-files$,;
+
+1;
# Local Variables:
# indent-tabs-mode: nil
diff --git a/collection/doc-base-files.desc b/collection/doc-base-files.desc
index ee4652d..c222f97 100644
--- a/collection/doc-base-files.desc
+++ b/collection/doc-base-files.desc
@@ -5,3 +5,4 @@ Info: This script copies the contents of /usr/share/doc-base into the
Type: binary
Version: 1
Needs-Info: unpacked
+Interface: perl-coll
diff --git a/collection/file-info b/collection/file-info
index 075c470..1135fd3 100755
--- a/collection/file-info
+++ b/collection/file-info
@@ -19,6 +19,8 @@
# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
# MA 02110-1301, USA.
+package Lintian::coll::file_info;
+
use strict;
use warnings;
@@ -29,12 +31,12 @@ use Lintian::Collect;
use Lintian::Command qw(spawn reap);
use Lintian::Util qw(fail);
-($#ARGV == 2) or fail 'syntax: file-info <pkg> <type> <dir>';
-my ($pkg, $type, $dir) = @ARGV;
+sub collect {
+my ($pkg, $type, $dir) = @_;
my $info = Lintian::Collect->new ($pkg, $type, $dir);
my $last = '';
-my $helper = realpath("$0-helper");
+my $helper = realpath (__FILE__ . '-helper');
my $outfile = "$dir/file-info.gz";
if ( -e "$dir/file-info" ) {
@@ -66,6 +68,12 @@ foreach my $file ($info->sorted_index) {
close $opts{pipe_in};
reap(\%opts);
+}
+
+collect (@ARGV) if $0 =~ m,(?:^|/)file-info$,;
+
+1;
+
# Local Variables:
# indent-tabs-mode: nil
# cperl-indent-level: 4
diff --git a/collection/file-info.desc b/collection/file-info.desc
index 10a19c7..712ac47 100644
--- a/collection/file-info.desc
+++ b/collection/file-info.desc
@@ -4,3 +4,4 @@ Info: This script runs the file(1) command over all files of any kind of package
Type: binary, udeb, source
Version: 2
Needs-Info: unpacked, index
+Interface: perl-coll
diff --git a/collection/hardening-info b/collection/hardening-info
index a3343bd..20817e2 100755
--- a/collection/hardening-info
+++ b/collection/hardening-info
@@ -26,6 +26,8 @@
# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
# MA 02110-1301, USA.
+package Lintian::coll::hardening_info;
+
use strict;
use warnings;
@@ -37,10 +39,11 @@ use Lintian::Collect;
use Lintian::Command qw(spawn reap);
use Lintian::Util qw(fail);
-my ($pkg, $type, $dir) = @ARGV;
+sub collect {
+my ($pkg, $type, $dir) = @_;
my $info = Lintian::Collect->new ($pkg, $type, $dir);
-my $helper = realpath("$0-helper");
+my $helper = realpath (__FILE__ . '-helper');
if ( -e "$dir/hardening-info" ) {
unlink "$dir/hardening-info" or fail "unlink hardening-info: $!";
@@ -73,8 +76,10 @@ foreach my $bin ($info->sorted_index) {
close $opts{pipe_in};
reap (\%opts);
+}
-exit 0;
+collect (@ARGV) if $0 =~ m,(?:^|/)hardening-info$,;
+1;
# Local Variables:
# indent-tabs-mode: nil
diff --git a/collection/hardening-info.desc b/collection/hardening-info.desc
index a4a7a7a..fbb4e23 100644
--- a/collection/hardening-info.desc
+++ b/collection/hardening-info.desc
@@ -5,3 +5,4 @@ Info: This script runs hardening-check(1) over all ELF binaries of a binary
Type: binary, udeb
Version: 4
Needs-Info: bin-pkg-control, file-info, index, unpacked
+Interface: perl-coll
diff --git a/collection/index b/collection/index
index 304e82e..7934afa 100755
--- a/collection/index
+++ b/collection/index
@@ -23,6 +23,8 @@
# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
# MA 02110-1301, USA.
+package Lintian::coll::index;
+
use strict;
use warnings;
@@ -33,8 +35,8 @@ use Lintian::Command qw(spawn reap);
use Lintian::Processable::Package;
use Lintian::Util qw(fail get_dsc_info);
-($#ARGV == 2) or fail 'syntax: index <pkg> <type> <dir>';
-my ($pkg, $type, $dir) = @ARGV;
+sub collect {
+my ($pkg, $type, $dir) = @_;
unlink "$dir/index" or fail "Could not unlink index: $!"
if -e "$dir/index";
@@ -44,7 +46,7 @@ unlink "$dir/index-errors" or fail "Could not unlink index-errors: $!"
if -e "$dir/index-errors";
if ($type ne 'source') {
- index_deb();
+ index_deb ($dir);
} else {
chdir "$dir/unpacked"
or fail "chdir $dir/unpacked: $!";
@@ -61,10 +63,11 @@ if ($type ne 'source') {
'|', ['sort', '-k', '6'], '|', ['gzip', '-9c']);
}
-exit 0;
+}
# Creates an index for binary packages
sub index_deb {
+ my ($dir) = @_;
my (@jobs, $job);
foreach my $file (qw(index index-errors index-owner-id)) {
@@ -101,6 +104,10 @@ sub index_deb {
return 1;
}
+collect (@ARGV) if $0 =~ m,(?:^|/)index$,;
+
+1;
+
# Local Variables:
# indent-tabs-mode: nil
# cperl-indent-level: 4
diff --git a/collection/index.desc b/collection/index.desc
index 904e0b4..a46e86f 100644
--- a/collection/index.desc
+++ b/collection/index.desc
@@ -3,4 +3,4 @@ Info: This script create an index file of the contents of a package.
Type: source, binary, udeb
Needs-Info: unpacked [source]
Version: 4
-
+Interface: perl-coll
diff --git a/collection/init.d b/collection/init.d
index ddc27d2..204d8d8 100755
--- a/collection/init.d
+++ b/collection/init.d
@@ -19,14 +19,16 @@
# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
# MA 02110-1301, USA.
+package Lintian::coll::init_d;
+
use strict;
use warnings;
use lib "$ENV{'LINTIAN_ROOT'}/lib";
use Lintian::Util qw(copy_dir delete_dir fail);
-($#ARGV == 2) or fail('syntax: init.d <pkg> <type> <dir>');
-my ($pkg, $type, $dir) = @ARGV;
+sub collect {
+my ($pkg, $type, $dir) = @_;
if (-e "$dir/init.d") {
delete_dir ("$dir/init.d")
@@ -40,6 +42,11 @@ if (-d "$dir/unpacked/etc/init.d") {
# no etc/init.d
mkdir ("$dir/init.d", 0777) or fail "cannot mkdir init.d: $!";
}
+}
+
+collect (@ARGV) if $0 =~ m,(?:^|/)init\.d$,;
+
+1;
# Local Variables:
# indent-tabs-mode: nil
diff --git a/collection/init.d.desc b/collection/init.d.desc
index d56c188..34a5826 100644
--- a/collection/init.d.desc
+++ b/collection/init.d.desc
@@ -5,3 +5,4 @@ Info: This script copies the etc/init.d directory into the lintian
Type: binary
Version: 1
Needs-Info: unpacked
+Interface: perl-coll
diff --git a/collection/java-info b/collection/java-info
index bb342ef..f25eac4 100755
--- a/collection/java-info
+++ b/collection/java-info
@@ -19,6 +19,8 @@
# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
# MA 02110-1301, USA.
+package Lintian::coll::java_info;
+
use strict;
use warnings;
@@ -30,7 +32,8 @@ use Lintian::Collect;
use Lintian::Command qw(spawn reap);
use Lintian::Util qw(fail);
-my ($pkg, $type, $dir) = @ARGV;
+sub collect {
+my ($pkg, $type, $dir) = @_;
my $info = Lintian::Collect->new ($pkg, $type, $dir);
# Sanity check
@@ -48,6 +51,14 @@ if ( -f "$dir/java-info.gz" ) {
# We lazily start the gzip process to avoid creating the java-info.gz
# file when there are no jar files in the package.
my %opts;
+my $open_java_info = sub {
+ %opts = ( pipe_in => FileHandle->new,
+ out => "$dir/java-info.gz",
+ fail => 'error' );
+ spawn(\%opts, ['gzip', '-9c'] );
+ $opts{pipe_in}->blocking(1);
+};
+
chdir ("$dir/unpacked")
or fail "unable to chdir to unpacked: $!";
@@ -61,7 +72,7 @@ foreach my $file ($info->sorted_index) {
my $manifest;
my $azip = Archive::Zip->new;
- open_java_info() unless %opts;
+ $open_java_info->() unless %opts;
# This script needs unzip, there's no way around.
print {$opts{pipe_in}} "-- $file\n";
@@ -117,15 +128,10 @@ if (%opts) {
reap (\%opts);
}
-exit 0;
+};
-sub open_java_info {
- %opts = ( pipe_in => FileHandle->new,
- out => "$dir/java-info.gz",
- fail => 'error' );
- spawn(\%opts, ['gzip', '-9c'] );
- $opts{pipe_in}->blocking(1);
-}
+collect (@ARGV) if $0 =~ m,(?:^|/)java-info$,;
+1;
# Local Variables:
# indent-tabs-mode: nil
diff --git a/collection/java-info.desc b/collection/java-info.desc
index 470b827..c319604 100644
--- a/collection/java-info.desc
+++ b/collection/java-info.desc
@@ -4,3 +4,4 @@ Info: This script extracts information from manifests of JAR files
Type: binary
Version: 3
Needs-Info: index, file-info, unpacked
+Interface: perl-coll
diff --git a/collection/md5sums b/collection/md5sums
index 97b1472..8b65a65 100755
--- a/collection/md5sums
+++ b/collection/md5sums
@@ -19,6 +19,8 @@
# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
# MA 02110-1301, USA.
+package Lintian::coll::md5sums;
+
use strict;
use warnings;
@@ -28,9 +30,8 @@ use Lintian::Collect;
use Lintian::Command qw(spawn reap);
use Lintian::Util qw(fail);
-($#ARGV == 2) or fail 'syntax: md5sums <pkg> <type> <dir>';
-
-my ($pkg, $type, $dir) = @ARGV;
+sub collect {
+my ($pkg, $type, $dir) = @_;
my $info = Lintian::Collect->new ($pkg, $type, $dir);
if ( -e "$dir/md5sums" ) {
@@ -54,6 +55,10 @@ foreach my $file ($info->sorted_index) {
close $opts{pipe_in};
reap(\%opts);
+}
+
+collect (@ARGV) if $0 =~ m,(?:^|/)md5sums$,;
+1;
# Local Variables:
# indent-tabs-mode: nil
diff --git a/collection/md5sums.desc b/collection/md5sums.desc
index 07349cb..b505526 100644
--- a/collection/md5sums.desc
+++ b/collection/md5sums.desc
@@ -4,3 +4,4 @@ Info: This script runs the md5sums(1) over all files in a binary package.
Type: binary, udeb
Version: 1
Needs-Info: unpacked, index
+Interface: perl-coll
diff --git a/collection/menu-files b/collection/menu-files
index 15fc69a..13290e6 100755
--- a/collection/menu-files
+++ b/collection/menu-files
@@ -19,14 +19,16 @@
# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
# MA 02110-1301, USA.
+package Lintian::coll::menu_files;
+
use strict;
use warnings;
use lib "$ENV{'LINTIAN_ROOT'}/lib";
use Lintian::Util qw(copy_dir delete_dir fail);
-($#ARGV == 2) or fail('syntax: menu-files <pkg> <type> <dir>');
-my ($pkg, $type, $dir) = @ARGV;
+sub collect {
+my ($pkg, $type, $dir) = @_;
if ( -e "$dir/menu") {
delete_dir ("$dir/menu")
@@ -50,6 +52,12 @@ while (my ($shortn, $path) = each %dirs) {
}
}
+}
+
+collect (@ARGV) if $0 =~ m,(?:^|/)menu-files$,;
+
+1;
+
# Local Variables:
# indent-tabs-mode: nil
# cperl-indent-level: 4
diff --git a/collection/menu-files.desc b/collection/menu-files.desc
index cce2451..5ff531d 100644
--- a/collection/menu-files.desc
+++ b/collection/menu-files.desc
@@ -4,3 +4,4 @@ Info: This script copies the contents of /usr/lib/menu into the lintian menu/ di
Type: binary
Version: 2
Needs-Info: unpacked
+Interface: perl-coll
diff --git a/collection/objdump-info b/collection/objdump-info
index 1b091f6..17cd44e 100755
--- a/collection/objdump-info
+++ b/collection/objdump-info
@@ -23,6 +23,8 @@
# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
# MA 02110-1301, USA.
+package Lintian::coll::objdump_info;
+
use strict;
use warnings;
@@ -34,9 +36,10 @@ use Lintian::Collect;
use Lintian::Command qw(spawn reap);
use Lintian::Util qw(fail);
-my ($pkg, $type, $dir) = @ARGV;
+sub collect {
+my ($pkg, $type, $dir) = @_;
my $info = Lintian::Collect->new ($pkg, $type, $dir);
-my $helper = realpath("$0-helper");
+my $helper = realpath (__FILE__ . '-helper');
if ( -e "$dir/objdump-info" ) {
unlink "$dir/objdump-info" or fail "unlink objdump-info: $!"
@@ -66,7 +69,10 @@ foreach my $bin ($info->sorted_index) {
close $opts{pipe_in} or fail "cannot write objdump-info.gz: $!";
reap(\%opts);
-exit 0;
+};
+
+collect (@ARGV) if $0 =~ m,(?:^|/)objdump-info$,;
+1;
# Local Variables:
# indent-tabs-mode: nil
diff --git a/collection/objdump-info.desc b/collection/objdump-info.desc
index 5bc5af0..d072481 100644
--- a/collection/objdump-info.desc
+++ b/collection/objdump-info.desc
@@ -5,3 +5,4 @@ Info: This script runs objdump(1) over all binaries and object files of a
Type: binary, udeb
Version: 4
Needs-Info: file-info, unpacked, index
+Interface: perl-coll
diff --git a/collection/override-file b/collection/override-file
index 2256267..e647b46 100755
--- a/collection/override-file
+++ b/collection/override-file
@@ -20,14 +20,16 @@
# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
# MA 02110-1301, USA.
+package Lintian::coll::override_file;
+
use strict;
use warnings;
use lib "$ENV{'LINTIAN_ROOT'}/lib";
use Lintian::Util qw(fail gunzip_file);
-($#ARGV == 2) or fail('syntax: override-file <pkg> <type> <dir>');
-my ($pkg, $type, $dir) = @ARGV;
+sub collect {
+my ($pkg, $type, $dir) = @_;
-d "$dir/unpacked" or fail 'override-file invoked with wrong dir argument';
@@ -61,6 +63,12 @@ if (not defined $file) {
or fail("cannot link $file to override: $!");
}
+}
+
+collect (@ARGV) if $0 =~ m,(?:^|/)override-file$,;
+
+1;
+
# Local Variables:
# indent-tabs-mode: nil
# cperl-indent-level: 4
diff --git a/collection/override-file.desc b/collection/override-file.desc
index 8f481e8..2485aaa 100644
--- a/collection/override-file.desc
+++ b/collection/override-file.desc
@@ -5,3 +5,4 @@ Info: This script copies the <tt>override</tt> file of a package into the
Type: binary, udeb, source
Version: 1
Needs-Info: unpacked
+Interface: perl-coll
diff --git a/collection/scripts b/collection/scripts
index d78c657..2136991 100755
--- a/collection/scripts
+++ b/collection/scripts
@@ -19,6 +19,8 @@
# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
# MA 02110-1301, USA.
+package Lintian::coll::scripts;
+
use strict;
use warnings;
@@ -26,7 +28,8 @@ use lib "$ENV{'LINTIAN_ROOT'}/lib/";
use Lintian::Collect;
use Lintian::Util qw(fail);
-my ($pkg, $type, $dir) = @ARGV;
+sub collect {
+my ($pkg, $type, $dir) = @_;
my $info = Lintian::Collect->new ($pkg, $type, $dir);
open SCRIPTS, '>', "$dir/scripts" or fail "cannot open scripts output file: $!";
@@ -85,7 +88,11 @@ for $file (readdir CONTROL) {
closedir(CONTROL);
close(SCRIPTS) or fail("cannot write control-scripts file: $!");
-exit 0;
+}
+
+collect (@ARGV) if $0 =~ m,(?:^|/)scripts$,;
+
+1;
# Local Variables:
# indent-tabs-mode: nil
diff --git a/collection/scripts.desc b/collection/scripts.desc
index 31be29a..63e46c0 100644
--- a/collection/scripts.desc
+++ b/collection/scripts.desc
@@ -8,3 +8,4 @@ Info: This script scans a binary package for scripts that start with #! and
Type: binary, udeb
Version: 1
Needs-Info: unpacked, bin-pkg-control, index
+Interface: perl-coll
diff --git a/collection/src-orig-index b/collection/src-orig-index
index 08b585a..197affe 100755
--- a/collection/src-orig-index
+++ b/collection/src-orig-index
@@ -19,6 +19,8 @@
# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
# MA 02110-1301, USA.
+package Lintian::coll::src_orig_index;
+
use strict;
use warnings;
@@ -30,8 +32,8 @@ use Lintian::Command qw(spawn);
use Lintian::Processable::Package;
use Lintian::Util qw(fail);
-($#ARGV == 2) or fail 'syntax: src-orig-index <pkg> <type> <dir>';
-my ($pkg, $type, $dir) = @ARGV;
+sub collect {
+my ($pkg, $type, $dir) = @_;
my $info = Lintian::Collect->new ($pkg, $type, $dir);
if ( -f "$dir/orig-index.gz" ) {
@@ -44,13 +46,12 @@ if ( -f "$dir/orig-index.gz" ) {
if ($info->native) {
link "$dir/index.gz", "$dir/orig-index.gz"
or fail "link index.gz orig-index.gz: $!";
- exit 0
+ return;
}
index_orig ($info);
-exit 0;
-
+}
# returns all (orig) tarballs.
sub gather_tarballs {
@@ -191,3 +192,13 @@ sub index_orig {
'|', ['gzip', '--best', '-c']);
return 1;
}
+
+collect (@ARGV) if $0 =~ m,(?:^|/)src-orig-index$,;
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/collection/src-orig-index.desc b/collection/src-orig-index.desc
index 9b1d114..9d2ebd4 100644
--- a/collection/src-orig-index.desc
+++ b/collection/src-orig-index.desc
@@ -3,5 +3,4 @@ Info: This script create an index file of the contents of the orig tarballs.
Type: source
Needs-Info: index
Version: 1
-
-
+Interface: perl-coll
diff --git a/collection/strings b/collection/strings
index 1d5da2e..8682bbe 100755
--- a/collection/strings
+++ b/collection/strings
@@ -19,6 +19,8 @@
# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
# MA 02110-1301, USA.
+package Lintian::coll::strings;
+
use strict;
use warnings;
@@ -30,12 +32,13 @@ use Lintian::Collect;
use Lintian::Command qw(spawn reap);
use Lintian::Util qw(delete_dir fail);
-($#ARGV == 2) or fail('syntax: strings <pkg> <type> <dir>');
-my ($pkg, $type, $dir) = @ARGV;
+sub collect {
+
+my ($pkg, $type, $dir) = @_;
my $info = Lintian::Collect->new ($pkg, $type, $dir);
-my $helper = realpath("$0-helper");
+my $helper = realpath(__FILE__ . '-helper');
my @manual = ();
if ( -e "$dir/elf-index" ) {
@@ -95,7 +98,11 @@ if (@manual) {
}
close(ELF_INDEX) or fail("cannot write elf-index file: $!");
-exit 0;
+}
+
+collect (@ARGV) if $0 =~ m,(?:^|/)strings$,;
+
+1;
# Local Variables:
# indent-tabs-mode: nil
diff --git a/collection/strings.desc b/collection/strings.desc
index 609dd17..4836db1 100644
--- a/collection/strings.desc
+++ b/collection/strings.desc
@@ -4,4 +4,5 @@ Info: This script runs the strings(1) command over all files of a binary
package.
Type: binary, udeb
Version: 2
+Interface: perl-coll
Needs-Info: index, unpacked, file-info
diff --git a/collection/unpacked b/collection/unpacked
index 87e0203..4a5d503 100755
--- a/collection/unpacked
+++ b/collection/unpacked
@@ -20,6 +20,8 @@
# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
# MA 02110-1301, USA.
+package Lintian::coll::unpacked;
+
use strict;
use warnings;
@@ -27,8 +29,8 @@ use lib "$ENV{'LINTIAN_ROOT'}/lib";
use Lintian::Command qw(spawn);
use Lintian::Util qw(check_path delete_dir fail);
-($#ARGV == 2) or fail('syntax: unpacked <package> <type> <dir>');
-my ($pkg, $type, $dir) = @ARGV;
+sub collect {
+my ($pkg, $type, $dir) = @_;
if (-d "$dir/unpacked/") {
delete_dir ("$dir/unpacked/") or
@@ -40,7 +42,7 @@ if (-f "$dir/unpacked-errors") {
}
# If we are asked to only remove the files stop right here
if ($type =~ m/^remove-/) {
- exit 0;
+ return;
}
if ($type eq 'source') {
@@ -91,6 +93,8 @@ if ($type eq 'source') {
['chmod', '-R', 'u+rwX,go-w', "$dir/unpacked"]);
}
+}
+
sub libdpkg_unpack_dsc {
my ($dsc, $target) = @_;
my $opt = {
@@ -120,6 +124,10 @@ sub can_use_dpkg_source{
return check_path('dpkg-source');
}
+collect (@ARGV) if $0 =~ m,(?:^|/)unpacked$,;
+
+1;
+
# Local Variables:
# indent-tabs-mode: nil
# cperl-indent-level: 4
diff --git a/collection/unpacked.desc b/collection/unpacked.desc
index 871abb7..a52cd5b 100644
--- a/collection/unpacked.desc
+++ b/collection/unpacked.desc
@@ -4,3 +4,4 @@ Info: This script unpacks the package under the unpacked/ directory
Type: binary, udeb, source
Version: 1
Auto-Remove: yes
+Interface: perl-coll
diff --git a/doc/lintian.xml b/doc/lintian.xml
index 25ae68f..a3e23d4 100644
--- a/doc/lintian.xml
+++ b/doc/lintian.xml
@@ -1229,9 +1229,9 @@ foo [!any-i386] binary: some-tag-not-for-i386 optional-extra
</para>
<para>
Check names without a forward slash (e.g. "fields") and names
- starting with "lintian/" are reserved for built-in checks.
- Vendors are recommended to use their vendor name before the
- first slash (e.g. "ubuntu/fields").
+ starting with either "lintian/" or "coll/" are reserved for
+ the Lintian core. Vendors are recommended to use their vendor
+ name before the first slash (e.g. "ubuntu/fields").
</para>
<sect2 label="3.3.1" id="section-3.3.1">
<title>Check description file</title>
diff --git a/lib/Lintian/CollScript.pm b/lib/Lintian/CollScript.pm
index 8f90f39..bd45e3a 100644
--- a/lib/Lintian/CollScript.pm
+++ b/lib/Lintian/CollScript.pm
@@ -26,7 +26,7 @@ use base 'Class::Accessor';
use Carp qw(croak);
use File::Basename qw(dirname);
-use Lintian::Util qw(get_dsc_info);
+use Lintian::Util qw(fail get_dsc_info);
=head1 NAME
@@ -77,6 +77,8 @@ sub new {
'version' => $header->{'version'},
'type-table' => {},
'auto_remove' => 0,
+ 'interface' => $header->{'interface'}//'exec',
+ '_collect_sub' => undef,
};
$self->{'script_path'} = dirname ($file) . '/' . $self->{'name'};
$self->{'auto_remove'} = 1
@@ -152,10 +154,33 @@ Returns a truth value if the collection has the "auto-remove" flag.
Returns the absolute path to the collection script.
+=item interface
+
+The call interface for this collection script.
+
+=over 4
+
+=item exec
+
+The collection is run by invoking the script denoted by script_path
+with the proper arguments.
+
+This is the default value.
+
+=item perl-coll
+
+The collection is implemented in Perl in such a way that it can be
+loaded into perl and run via the L</collect (PKG, TASK, DIR)> method.
+
+Collections that have the "perl-coll" can also be run as if they had
+the "exec" interface (see above).
+
+=back
+
=cut
Lintian::CollScript->mk_ro_accessors (qw(name type version auto_remove
- script_path
+ script_path interface
));
=item needs_info ([COND])
@@ -204,6 +229,34 @@ sub is_type {
return $self->{'type-table'}->{$type};
}
+=item collect (PKG, TASK, DIR)
+
+=cut
+
+sub collect {
+ my ($self, $pkg_name, $task, $dir) = @_;
+ my $collector = $self->{'_collect_sub'};
+ unless (defined $collector) {
+ my $cs_path = $self->script_path;
+ my $ppkg = $self->name;
+
+ $ppkg =~ s,[-.],_,go;
+ $ppkg =~ s,/,::,go;
+
+ require $cs_path;
+
+ {
+ no strict 'refs';
+ $collector = \&{'Lintian::coll::' . $ppkg . '::collect'}
+ if defined &{'Lintian::coll::' . $ppkg . '::collect'};
+ }
+ fail $self->name . ' does not have a collect function'
+ unless defined $collector;
+ $self->{'_collect_sub'} = $collector;
+ }
+ $collector->($pkg_name, $task, $dir);
+}
+
=back
=head1 AUTHOR
diff --git a/lib/Lintian/Unpacker.pm b/lib/Lintian/Unpacker.pm
index 39507ad..da22397 100644
--- a/lib/Lintian/Unpacker.pm
+++ b/lib/Lintian/Unpacker.pm
@@ -23,7 +23,9 @@ use warnings;
use base 'Class::Accessor';
-use Lintian::Command::Simple qw(background wait_any kill_all);
+use POSIX;
+
+use Lintian::Command::Simple qw(wait_any kill_all);
use Lintian::Util qw(fail);
=head1 NAME
@@ -432,7 +434,24 @@ sub process_tasks {
# collect info
$cmap->select ($coll);
$wlist->{'changed'} = 1;
- my $pid = background ($cs->script_path, $pkg_name, $pkg_type, $base);
+ my $pid = fork//-1;
+ if (not $pid) {
+ # child
+ my $ret = 0;
+ if ($cs->interface eq 'perl-coll') {
+ eval {
+ $cs->collect ($pkg_name, $pkg_type, $base);
+ };
+ if ($@) {
+ print STDERR $@;
+ $ret = 2;
+ }
+ } else {
+ exec $cs->script_path, $pkg_name, $pkg_type, $base
+ or die "exec $cs->script_path: $!";
+ }
+ POSIX::_exit ($ret);
+ }
$coll_hook->($lpkg, 'start', $cs, $pid) if $coll_hook;
if ($pid < 0) {
# failed - Lets not start any more jobs for this processable
--
Debian package checker
Reply to: