/usr/share/lintian/lib/Lintian/Internal/FrontendUtil.pm is in lintian 2.5.10.4.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 | # -*- 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 Lintian::Util qw(check_path fail);
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')){
chomp($vendor = `dpkg-vendor --query Vendor`);
fail('dpkg-vendor failed (status: ' . ($? >> 8). ").\n") if $?;
$qparent = \&_find_parent_vendor_dpkg_vendor;
} else {
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;
$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;
return lc($vendor);
}
1;
# Local Variables:
# indent-tabs-mode: nil
# cperl-indent-level: 4
# End:
# vim: syntax=perl sw=4 sts=4 sr et
|