[SCM] Debian package checker branch, vendor-profile, updated. 2.5.1-32-gdbc1960
The following commit has been merged in the vendor-profile branch:
commit 5dee3a257b65090ac842886783f7f5ac0db9db73
Author: Niels Thykier <niels@thykier.net>
Date: Thu Jun 23 15:32:55 2011 +0200
Refactored default profile loading into an internal module
diff --git a/frontend/lintian b/frontend/lintian
index b8638d5..d66e315 100755
--- a/frontend/lintian
+++ b/frontend/lintian
@@ -679,6 +679,8 @@ import Lintian::Output qw(:messages);
require Lintian::Command::Simple;
require Lintian::Command;
import Lintian::Command qw(spawn reap);
+require Lintian::Internal::FrontendUtil;
+import Lintian::Internal::FrontendUtil;
require Lintian::ProcessablePool;
require Lintian::Profile;
require Lintian::Tag::Info;
@@ -742,7 +744,7 @@ if (defined $check_tags) {
} else {
unless ($LINTIAN_PROFILE){
# Time to ask dpkg-vendor for a vendor name
- $LINTIAN_PROFILE = find_default_profile();
+ $LINTIAN_PROFILE = find_default_profile(@prof_inc, "$LINTIAN_ROOT/profiles");
}
}
@@ -1217,68 +1219,6 @@ sub set_value {
delete $source->{$field};
}
-# Check if we are testing a specific feature
-# - e.g. vendor-libdpkg-perl
-sub _check_test_feature{
- my $env = $ENV{LINTIAN_TEST_FEATURE};
- return 0 unless $env;
- foreach my $feat (@_){
- return 1 if($env =~ m/$feat/);
- }
- return 0;
-}
-
-sub find_default_profile {
- my ($vendor, $orig);
- # CODE-ref to query for the parent vendor
- # $qparent->("Ubuntu")
- my $qparent;
- # Use dpkg-vendor if present (unless we are testing our libdpkg-perl code)
- if(Util::check_path('dpkg-vendor') && !_check_test_feature('vendor-libdpkg-perl')){
- v_msg('Using dpkg-vendor to determine the default profile.');
- chomp($vendor = `dpkg-vendor --query Vendor`);
- fail('dpkg-vendor failed (status: ' . ($? >> 8). ").\n") if $?;
- $qparent = sub {
- my ($cur) = @_;
- my $par;
- chomp($par = `dpkg-vendor --vendor "$cur" --query Parent`);
- # dpkg-vendor returns 1 if there is no parent (because the query failed),
- # which we translate into ''; but other values suggests an internal
- # dpkg-vendor error.
- if ( $? ){
- my $err = ($? >> 8) & 256;
- fail('dpkg-vendor failed (status: ' . ($? >> 8). ").\n") if $err != 1;
- return '';
- }
- return $par;
- }; # End of $qparent sub
-
- } else {
- v_msg('Using Dpkg::Vendor to determine the default profile.');
- require Dpkg::Vendor;
- $vendor = Dpkg::Vendor::get_current_vendor();
- fail("Could not determine the current vendor.\n") unless $vendor;
- $qparent = sub {
- my ($cur) = @_;
- my $info = Dpkg::Vendor::get_vendor_info($cur);
- # Cannot happen atm, but in case Dpkg::Vendor changes its internals
- # or our code changes
- fail("Could not look up the parent vendor of $cur.\n") unless $vendor;
- return $info->{'Parent'};
- }; # End of $qparent sub
- }
- $orig = $vendor;
- while ($vendor) {
- my $p;
- v_msg("Checking for default profile for $vendor.");
- $p = Lintian::Profile->find_profile(lc($vendor), @prof_inc, "$LINTIAN_ROOT/profiles");
- last if $p;
- $vendor = $qparent->($vendor);
- }
- fail("Could not find a profile for vendor $orig") unless $vendor;
- v_msg("Found default profile for vendor $orig");
- return lc($vendor);
-}
# Given a ref to %collection_info and the path to the collection
# directory, this will load all the collection information into
diff --git a/lib/Lintian/Internal/FrontendUtil.pm b/lib/Lintian/Internal/FrontendUtil.pm
new file mode 100644
index 0000000..a72b571
--- /dev/null
+++ b/lib/Lintian/Internal/FrontendUtil.pm
@@ -0,0 +1,106 @@
+# -*- perl -*-
+# Lintian::Internal::FrontendUtil -- internal helpers for lintian frontends
+
+# Copyright (C) 2011 Niels Thykier
+#
+# This program is free software; you can redistribute it and/or modify it
+# under the terms of the GNU General Public License as published by the Free
+# Software Foundation; either version 2 of the License, or (at your option)
+# any later version.
+#
+# This program is distributed in the hope that it will be useful, but WITHOUT
+# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+# FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
+# more details.
+#
+# You should have received a copy of the GNU General Public License along with
+# this program. If not, see <http://www.gnu.org/licenses/>.
+
+package Lintian::Internal::FrontendUtil;
+use strict;
+use warnings;
+
+use base qw(Exporter);
+use Util;
+
+our @EXPORT = qw(&check_test_feature &find_default_profile);
+
+# Check if we are testing a specific feature
+# - e.g. vendor-libdpkg-perl
+sub check_test_feature{
+ my $env = $ENV{LINTIAN_TEST_FEATURE};
+ return 0 unless $env;
+ foreach my $feat (@_){
+ return 1 if($env =~ m/$feat/);
+ }
+ return 0;
+}
+
+# _find_parent_vendor_dpkg_vendor($vendor)
+#
+# returns the parent vendor using dpkg-vendor
+sub _find_parent_vendor_dpkg_vendor {
+ my ($cur) = @_;
+ my $par;
+ chomp($par = `dpkg-vendor --vendor "$cur" --query Parent`);
+ # dpkg-vendor returns 1 if there is no parent (because the query failed),
+ # which we translate into ''; but other values suggests an internal
+ # dpkg-vendor error.
+ if ( $? ){
+ my $err = ($? >> 8) & 256;
+ fail('dpkg-vendor failed (status: ' . ($? >> 8). ").\n") if $err != 1;
+ return '';
+ }
+ return $par;
+}
+
+# _find_parent_vendor_dpkg_vendor($vendor)
+#
+# returns the parent vendor using libdpkg-perl
+# - assumes Dpkg::Vendor has been required before
+# being invoked.
+sub _find_parent_vendor_libdpkg_perl {
+ my ($cur) = @_;
+ my $info = Dpkg::Vendor::get_vendor_info($cur);
+ # Cannot happen atm, but in case Dpkg::Vendor changes its internals
+ # or our code changes
+ fail("Could not look up the parent vendor of $cur.\n") unless $info;
+ return $info->{'Parent'};
+}
+
+# find_default_profile(@prof_path)
+#
+# locates the default profile - used if no profile was explicitly given.
+sub find_default_profile {
+ my (@prof_path) = @_;
+ my ($vendor, $orig);
+ # CODE-ref to query for the parent vendor
+ # $qparent->("Ubuntu") returns Debian
+ # $qparent->("Debian") returns '' or undef
+ my $qparent;
+ # Use dpkg-vendor if present (unless we are testing our libdpkg-perl code)
+ if(check_path('dpkg-vendor') && !check_test_feature('vendor-libdpkg-perl')){
+ v_msg('Using dpkg-vendor to determine the default profile.');
+ chomp($vendor = `dpkg-vendor --query Vendor`);
+ fail('dpkg-vendor failed (status: ' . ($? >> 8). ").\n") if $?;
+ $qparent = \&_find_parent_vendor_dpkg_vendor;
+ } else {
+ v_msg('Using Dpkg::Vendor to determine the default profile.');
+ require Dpkg::Vendor;
+ $vendor = Dpkg::Vendor::get_current_vendor();
+ fail("Could not determine the current vendor.\n") unless $vendor;
+ $qparent = \&_find_parent_vendor_libdpkg_perl;
+ }
+ $orig = $vendor;
+ while ($vendor) {
+ my $p;
+ v_msg("Checking for default profile for $vendor.");
+ $p = Lintian::Profile->find_profile(lc($vendor), @prof_path);
+ last if $p;
+ $vendor = $qparent->($vendor);
+ }
+ fail("Could not find a profile for vendor $orig") unless $vendor;
+ v_msg("Found default profile for vendor $orig");
+ return lc($vendor);
+}
+
--
Debian package checker
Reply to: