[Date Prev][Date Next] [Thread Prev][Thread Next] [Date Index] [Thread Index]

[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: