Linux ip-172-26-7-228 5.4.0-1103-aws #111~18.04.1-Ubuntu SMP Tue May 23 20:04:10 UTC 2023 x86_64
Your IP : 18.221.240.14
# files -- lintian check script -*- perl -*-
# Copyright (C) 1998 Christian Schwarz and Richard Braakman
#
# 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, you can find it on the World Wide
# Web at http://www.gnu.org/copyleft/gpl.html, or write to the Free
# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
# MA 02110-1301, USA.
package Lintian::files;
use strict;
use warnings;
use autodie;
use Lintian::Data;
use Lintian::Tags qw(tag);
use Lintian::Util qw(drain_pipe internal_error is_string_utf8_encoded open_gz
signal_number2name strip normalize_pkg_path);
use Lintian::SlidingWindow;
use constant BLOCKSIZE => 16_384;
my $FNAMES = Lintian::Data->new('files/fnames', qr/\s*\~\~\s*/);
my $FONT_PACKAGES = Lintian::Data->new('files/fonts', qr/\s++/);
my $TRIPLETS = Lintian::Data->new('files/triplets', qr/\s++/);
my $LOCALE_CODES = Lintian::Data->new('files/locale-codes', qr/\s++/);
my $INCORRECT_LOCALE_CODES
= Lintian::Data->new('files/incorrect-locale-codes', qr/\s++/);
my $MULTIARCH_DIRS = Lintian::Data->new('common/multiarch-dirs', qr/\s++/);
my $GENERIC_PYTHON_MODULES= Lintian::Data->new('files/python-generic-modules');
my $PRIVACY_BREAKER_WEBSITES= Lintian::Data->new(
'files/privacy-breaker-websites',
qr/\s*\~\~/o,
sub {
my ($regex, $tag, $suggest) = split(/\s*\~\~\s*/, $_[1], 3);
$tag = defined($tag) ? strip($tag) : '';
if (length($tag) == 0) {
$tag = $_[0];
}
my %ret = (
'tag' => $tag,
'regexp' => qr/$regex/xsm,
);
if (defined($suggest)) {
$ret{'suggest'} = $suggest;
}
return \%ret;
});
my $PRIVACY_BREAKER_FRAGMENTS= Lintian::Data->new(
'files/privacy-breaker-fragments',
qr/\s*\~\~/o,
sub {
my ($regex, $tag) = split(/\s*\~\~\s*/, $_[1], 2);
return {
'keyword' => $_[0],
'regex' => qr/$regex/xsm,
'tag' => $tag,
};
});
my $PRIVACY_BREAKER_TAG_ATTR= Lintian::Data->new(
'files/privacy-breaker-tag-attr',
qr/\s*\~\~\s*/o,
sub {
my ($keywords,$regex) = split(/\s*\~\~\s*/, $_[1], 2);
$regex =~ s/&URL/(?:(?:ht|f)tps?:)?\/\/[^"\r\n]*/g;
my @keywordlist;
my @keywordsorraw = split(/\s*\|\|\s*/,$keywords);
foreach my $keywordor (@keywordsorraw) {
my @keywordsandraw = split(/\s*&&\s*/,$keywordor);
push(@keywordlist, \@keywordsandraw);
}
return {
'keywords' => \@keywordlist,
'regex' => qr/$regex/xsm,
};
});
my $PKG_CONFIG_BAD_REGEX
= Lintian::Data->new('files/pkg-config-bad-regex',qr/~~~~~/,
sub { return qr/$_[0]/xsm;});
my $COMPRESS_FILE_EXTENSIONS
= Lintian::Data->new('files/compressed-file-extensions',
qr/\s++/,sub { return qr/\Q$_[0]\E/ });
# an OR (|) regex of all compressed extension
my $COMPRESS_FILE_EXTENSIONS_OR_ALL = sub { qr/(:?$_[0])/ }
->(
join('|',
map {$COMPRESS_FILE_EXTENSIONS->value($_) }
$COMPRESS_FILE_EXTENSIONS->all));
# see tag duplicated-compressed-file
my $DUPLICATED_COMPRESSED_FILE_REGEX
= qr/^(.+)\.(?:$COMPRESS_FILE_EXTENSIONS_OR_ALL)$/;
# see tag compressed-symlink-with-wrong-ext
my $COMPRESSED_SYMLINK_POINTING_TO_COMPRESSED_REGEX
= qr/\.($COMPRESS_FILE_EXTENSIONS_OR_ALL)\s*$/;
# vcs control files
my $VCS_FILES = Lintian::Data->new(
'files/vcs-control-files',
qr/\s++/,
sub {
my $regexp = $_[0];
$regexp =~ s/\$[{]COMPRESS_EXT[}]/$COMPRESS_FILE_EXTENSIONS_OR_ALL/g;
return qr/(?:$regexp)/x;
});
# an OR (|) regex of all vcs files
my $VCS_FILES_OR_ALL = sub { qr/(?:$_[0])/ }
->(join('|', map { $VCS_FILES->value($_) } $VCS_FILES->all));
# A list of known packaged Javascript libraries
# and the packages providing them
sub _load_file_package_list_mapping {
my ($datafile,$ext,$tagname,$reinside) = @_;
unless(defined($reinside)) {
$reinside = undef;
}
my $mapping = Lintian::Data->new(
$datafile,
qr/\s*\~\~\s*/,
sub {
my $pkg = strip($_[0]);
my $pkg_regexp = qr/^$pkg$/x;
my @sliptline = split(/\s*\~\~/, $_[1], 2);
my $file_regexp = strip($sliptline[0]);
$file_regexp =~ s/\$EXT/$ext/g;
my $recontents = $reinside;
if (scalar(@sliptline) == 2) {
my $contents = strip($sliptline[1]);
$recontents = qr/$contents/;
}
return {
'pkg_re' => $pkg_regexp,
'pkg' => $pkg,
'match' => qr/$file_regexp/,
'contents_re' => $recontents,
};
});
return {
'ext_regexp' => qr/$ext/x,
'mapping' => $mapping,
'ext' => $ext,
'tag' => $tagname,
};
}
my $JS_EXT
= '(?:(?i)[-._]?(?:compiled|lite|min|pack(?:ed)?|yc)?\.js(?:\.gz)?)$';
my $PHP_EXT = '(?i)\.(?:php|inc|dtd)$';
my @FILE_PACKAGE_MAPPING = (
_load_file_package_list_mapping(
'files/js-libraries',$JS_EXT,'embedded-javascript-library'
),
_load_file_package_list_mapping(
'files/php-libraries',$PHP_EXT,'embedded-php-library'
),
_load_file_package_list_mapping(
'files/pear-modules','(?i)\.php$',
'embedded-pear-module',qr,pear[/.],
),
);
my $BUILD_PATH_REGEX
= Lintian::Data->new('files/build-path-regex',qr/~~~~~/,
sub { return qr/$_[0]/xsm;});
sub _tag_build_tree_path {
my ($path, $msg) = @_;
foreach my $buildpath ($BUILD_PATH_REGEX->all) {
my $regex = $BUILD_PATH_REGEX->value($buildpath);
if ($path =~ m{$regex}xms) {
tag 'dir-or-file-in-build-tree', $msg;
}
}
return;
}
sub _is_tmp_path {
my ($path) = @_;
if( $path =~ m,^tmp/.,
or $path =~ m,^(?:var|usr)/tmp/.,
or $path =~ m,^/dev/shm/,) {
return 1;
}
return 0;
}
sub _detect_embedded_libraries {
my ($fname, $file, $pkg) = @_;
# detect only in regular file
unless($file->is_regular_file) {
return;
}
foreach my $type (@FILE_PACKAGE_MAPPING) {
my $typere = $type->{'ext_regexp'};
if($fname =~ m/$typere/) {
my $mapping = $type->{'mapping'};
my $typetag = $type->{'tag'};
LIBRARY:
foreach my $library ($mapping->all) {
my $library_data = $mapping->value($library);
my $mainre = $library_data->{'pkg_re'};
my $mainpkg = $library_data->{'pkg'};
my $filere = $library_data->{'match'};
my $reinside = $library_data->{'contents_re'};
unless ($fname =~ m,$filere,) {
next LIBRARY;
}
unless ($pkg !~ m,$mainre,) {
next LIBRARY;
}
if(defined($reinside)) {
my $foundre = 0;
my $fd = $file->open(':raw');
my $sfd = Lintian::SlidingWindow->new($fd);
READWINDOW:
while (my $block = $sfd->readwindow) {
if ($block =~ m{$reinside}) {
$foundre = 1;
last READWINDOW;
}
}
close($fd);
unless($foundre) {
next LIBRARY;
}
}
tag $typetag, $file, 'please use', $mainpkg;
}
}
}
return;
}
# A list of known non-free flash executables
my @flash_nonfree = (
qr<(?i)dewplayer(?:-\w+)?\.swf$>,
qr<(?i)(?:mp3|flv)player\.swf$>,
# Situation needs to be clarified:
# qr,(?i)multipleUpload\.swf$,
# qr,(?i)xspf_jukebox\.swf$,
);
my %PATH_DIRECTORIES = map { $_ => 1 } qw(
bin/ sbin/ usr/bin/ usr/sbin/ usr/games/ );
# Common files stored in /usr/share/doc/$pkg that aren't sufficient to
# consider the package non-empty.
my $STANDARD_FILES = Lintian::Data->new('files/standard-files');
# Obsolete path
my $OBSOLETE_PATHS = Lintian::Data->new(
'files/obsolete-paths',
qr/\s*\->\s*/,
sub {
my @sliptline = split(/\s*\~\~\s*/, $_[1], 2);
if (scalar(@sliptline) != 2) {
internal_error('Syntax error in files/obsolete-paths', $.);
}
my ($newdir, $moreinfo) = @sliptline;
return {
'newdir' => $newdir,
'moreinfo' => $moreinfo,
'match' => qr/$_[0]/x,
'olddir' => $_[0],
};
});
sub run {
my ($pkg, $type, $info, $proc) = @_;
my ($is_python, $is_perl, $has_binary_perl_file, $has_public_executable,
$has_public_shared_library);
my @nonbinary_perl_files_in_lib;
my %linked_against_libvga;
my @devhelp;
my @devhelp_links;
# X11 bitmapped font directories under /usr/share/fonts/X11 in which we've
# seen files.
my %x11_font_dirs;
my $arch_dep_files = 0;
# Note: $proc->pkg_src never includes the source version.
my $source_pkg = $proc->pkg_src;
my $pkg_section = $info->field('section', '');
my $arch = $info->field('architecture', '');
my $multiarch = $info->field('multi-arch', 'no');
my $multiarch_dir = $MULTIARCH_DIRS->value($arch);
my $ppkg = quotemeta($pkg);
# get the last changelog timestamp
# if for some weird reasons the timestamp does
# not exist, it will remain 0
my $changes = $info->changelog;
my $changelog_timestamp = 0;
if (defined $changes) {
my ($entry) = $changes->data;
if ($entry && $entry->Timestamp) {
$changelog_timestamp = $entry->Timestamp;
}
}
# find out which files are scripts
my %script = map {$_ => 1} (keys %{$info->scripts});
# We only want to warn about these once.
my $warned_debug_name = 0;
# Check if package is empty
my $is_dummy = $info->is_pkg_class('any-meta');
# read data from objdump-info file
foreach my $file (sort keys %{$info->objdump_info}) {
my $objdump = $info->objdump_info->{$file};
if (defined $objdump->{NEEDED}) {
for my $lib (@{$objdump->{NEEDED}}) {
$linked_against_libvga{$file} = 1
if $lib =~ /^libvga\.so\./;
}
}
}
if (!$is_dummy) {
my $is_empty = 1;
for my $file ($info->sorted_index) {
my $fname = $file->name;
# Ignore directories
unless ($fname =~ m,/$,) {
# Skip if $file is outside /usr/share/doc/$pkg directory
if ($fname !~ m,^usr/share/doc/\Q$pkg\E,) {
# - except if it is a lintian override.
next
if $fname =~ m{\A
# Except for:
usr/share/ (?:
# lintian overrides
lintian/overrides/$ppkg(?:\.gz)?
# reportbug scripts/utilities
| bug/$ppkg(?:/(?:control|presubj|script))?
)\Z}xsm;
$is_empty = 0;
last;
}
# Skip if /usr/share/doc/$pkg has files in a subdirectory
if ($fname =~ m,^usr/share/doc/\Q$pkg\E/[^/]++/,) {
$is_empty = 0;
last;
}
# Skip /usr/share/doc/$pkg symlinks.
next if $fname eq "usr/share/doc/$pkg";
my $basename = $file->basename;
# For files directly in /usr/share/doc/$pkg, if the
# file isn't one of the uninteresting ones, the
# package isn't empty.
next if $STANDARD_FILES->known($basename);
# Ignore all READMEs
next if $basename =~ m/^README(?:\..*)?$/i;
my $pkg_arch = $proc->pkg_arch;
if ($pkg_arch ne 'all') {
# binNMU changelog (debhelper)
next if $basename eq "changelog.Debian.${pkg_arch}.gz";
}
# buildinfo file (dh-buildinfo)
next if $basename eq "buildinfo_${pkg_arch}.gz";
$is_empty = 0;
last;
}
}
if ($is_empty) {
tag 'empty-binary-package' if ($type ne 'udeb');
tag 'empty-udeb-package' if ($type eq 'udeb');
}
}
# Read package contents...
foreach my $file ($info->sorted_index) {
my $fname = $file->name;
my $owner = $file->owner . '/' . $file->group;
my $operm = $file->operm;
my $link = $file->link;
$arch_dep_files = 1 if $fname !~ m,^usr/share/,o && $fname ne 'usr/';
if (exists($PATH_DIRECTORIES{$file->dirname})) {
$has_public_executable = 1;
tag 'file-name-in-PATH-is-not-ASCII', $file
if $file->basename !~ m{\A [[:ascii:]]++ \Z}xsm;
} elsif (!is_string_utf8_encoded($fname)) {
tag 'file-name-is-not-valid-UTF-8', $file;
}
# check for generic bad filenames
foreach my $tag ($FNAMES->all()) {
my $regex = $FNAMES->value($tag);
tag $tag, $file if $fname =~ m/$regex/;
}
if ($file->is_hardlink) {
my $link_target_dir = $link;
$link_target_dir =~ s,[^/]*$,,;
# It may look weird to sort the file and link target here,
# but since it's a hard link, both files are equal and
# either could be legitimately reported first. tar will
# generate different tar files depending on the hashing of
# the directory, and this sort produces stable lintian
# output despite that.
#
# TODO: actually, policy says 'conffile', not '/etc' ->
# extend!
tag 'package-contains-hardlink',join(' -> ', sort($fname, $link))
if $fname =~ m,^etc/,
or $link =~ m,^etc/,
or $fname !~ m,^\Q$link_target_dir\E[^/]*$,;
}
my ($year) = ($file->date =~ /^(\d{4})/);
if ($year <= 1975) { # value from dak CVS: Dinstall::PastCutOffYear
tag 'package-contains-ancient-file', $file, $file->date;
}
if (
!(
$file->uid < 100
|| $file->uid == 65_534
|| ($file->uid >= 60_000 && $file->uid < 65_000))
|| !(
$file->gid < 100
|| $file->gid == 65_534
|| ($file->gid >= 60_000 && $file->gid < 65_000))
) {
tag 'wrong-file-owner-uid-or-gid', $file,
$file->uid . '/' . $file->gid;
}
# *.devhelp and *.devhelp2 files must be accessible from a directory in
# the devhelp search path: /usr/share/devhelp/books and
# /usr/share/gtk-doc/html. We therefore look for any links in one of
# those directories to another directory. The presence of such a link
# blesses any file below that other directory.
if (defined $link
and $fname =~ m,^usr/share/(?:devhelp/books|gtk-doc/html)/,) {
my $blessed = $file->link_normalized // '<broken-link>';
push(@devhelp_links, $blessed);
}
# check for generic obsolete path
foreach my $obsolete_path ($OBSOLETE_PATHS->all) {
my $obs_data = $OBSOLETE_PATHS->value($obsolete_path);
my $oldpathmatch = $obs_data->{'match'};
if ($fname =~ m{$oldpathmatch}) {
my $oldpath = $obs_data->{'olddir'};
my $newpath = $obs_data->{'newdir'};
my $moreinfo = $obs_data->{'moreinfo'};
tag 'package-installs-into-obsolete-dir',
"$file : $oldpath -> $newpath $moreinfo";
}
}
# see #785662
if($file->is_regular_file) {
if(index($fname,'oui') > -1 || index($fname,'iab') > -1) {
if($fname
=~ m,/(?:[^/]-)?(?:oui|iab)(?:\.(txt|idx|db))?(?:\.$COMPRESS_FILE_EXTENSIONS_OR_ALL)?\Z,x
) {
unless ($source_pkg eq 'ieee-data') {
tag 'package-installs-ieee-data', $file;
}
}
}
}
# build directory
unless ($source_pkg eq 'sbuild' || $source_pkg eq 'pbuilder') {
_tag_build_tree_path($fname, $file);
}
# ---------------- /etc
if ($fname =~ m,^etc/,) {
# /etc/apt
if ($fname =~ m,^etc/apt/,) {
# -----------------/etc/apt/preferences
if ($fname =~ m,^etc/apt/preferences(?:$|\.d/[^/]+),) {
unless ($source_pkg eq 'apt') {
tag 'package-installs-apt-preferences', $file;
}
}
# -----------------/etc/apt/sources
if ($fname =~ m,^etc/apt/sources\.list(?:$|\.d/[^/]+),) {
unless ($source_pkg eq 'apt') {
tag 'package-installs-apt-sources', $file;
}
}
}
# ---------------- /etc/cron.daily, etc.
elsif ($fname
=~ m,^etc/cron\.(?:daily|hourly|monthly|weekly|d)/[^\.].*[\+\.],
) {
# NB: cron ships ".placeholder" files, which shouldn't be run.
tag 'run-parts-cron-filename-contains-illegal-chars', $file;
}
# ---------------- /etc/cron.d
elsif ($fname =~ m,^etc/cron\.d/[^\.], and $operm != 0644) {
# NB: cron ships ".placeholder" files in etc/cron.d,
# which we shouldn't tag.
tag 'bad-permissions-for-etc-cron.d-script',
sprintf('%s %04o != 0644',$file,$operm);
}
# ---------------- /etc/emacs.*
elsif ( $fname =~ m,^etc/emacs.*/\S,
and $file->is_file
and $operm != 0644) {
tag 'bad-permissions-for-etc-emacs-script',
sprintf('%s %04o != 0644',$file,$operm);
}
# ---------------- /etc/gconf/schemas
elsif ($fname =~ m,^etc/gconf/schemas/\S,) {
tag 'package-installs-into-etc-gconf-schemas', $file;
}
# ---------------- /etc/init
elsif ($fname =~ m,^etc/init/\S,) {
tag 'package-installs-deprecated-upstart-configuration', $file;
}
# ---------------- /etc/init.d
elsif ( $fname =~ m,^etc/init\.d/\S,
and $fname !~ m,^etc/init\.d/(?:README|skeleton)$,
and $operm != 0755
and $file->is_file) {
tag 'non-standard-file-permissions-for-etc-init.d-script',
sprintf('%s %04o != 0755',$file,$operm);
}
#----------------- /etc/ld.so.conf.d
elsif ($fname =~ m,^etc/ld\.so\.conf\.d/.+$, and $pkg !~ /^libc/){
tag 'package-modifies-ld.so-search-path', $file;
}
#----------------- /etc/modprobe.d
elsif ( $fname =~ m,^etc/modprobe\.d/(.+)$,
and $1 !~ m,\.conf$,
and not $file->is_dir) {
tag 'non-conf-file-in-modprobe.d', $file;
}
#---------------- /etc/opt
elsif ($fname =~ m,^etc/opt/.,) {
tag 'dir-or-file-in-etc-opt', $file;
}
#----------------- /etc/pam.conf
elsif ($fname =~ m,^etc/pam.conf, and $pkg ne 'libpam-runtime') {
tag 'config-file-reserved', "$fname by libpam-runtime";
}
#----------------- /etc/php/7.0/mods-available/*.ini
elsif ($fname =~ m,^etc/php/.*/mods-available/.+\.ini$,) {
if ($file->is_file) {
my $fd = $file->open;
while (<$fd>) {
next unless (m/^\s*#/);
tag 'obsolete-comments-style-in-php-ini', $file;
# only warn once per file:
last;
}
close($fd);
}
}
# ---------------- /etc/rc.d && /etc/rc?.d
elsif ( $type ne 'udeb'
and $fname =~ m,^etc/rc(?:\d|S)?\.d/\S,
and $pkg !~ /^(?:sysvinit|file-rc)$/) {
tag 'package-installs-into-etc-rc.d', $file;
}
# ---------------- /etc/rc.boot
elsif ($fname =~ m,^etc/rc\.boot/\S,) {
tag 'package-installs-into-etc-rc.boot', $file;
}
# ---------------- /etc/udev/rules.d
elsif ($fname =~ m,^etc/udev/rules\.d/\S,) {
tag 'udev-rule-in-etc', $file;
}
}
# ---------------- /usr
elsif ($fname =~ m,^usr/,) {
# ---------------- /usr/share/doc
if ($fname =~ m,^usr/share/doc/\S,) {
if ($type eq 'udeb') {
tag 'udeb-contains-documentation-file', $file;
} else {
# file not owned by root?
if ($owner ne 'root/root') {
tag 'bad-owner-for-doc-file',
"$fname $owner != root/root";
}
# file directly in /usr/share/doc ?
if ( $file->is_file
and $fname =~ m,^usr/share/doc/[^/]+$,){
tag 'file-directly-in-usr-share-doc', $file;
}
# executable in /usr/share/doc ?
if ( $file->is_file
and $fname !~ m,^usr/share/doc/(?:[^/]+/)?examples/,
and ($operm & 0111)) {
if ($script{$file}) {
tag 'script-in-usr-share-doc', $file;
} else {
tag 'executable-in-usr-share-doc', $file,
(sprintf '%04o', $operm);
}
}
# zero byte file in /usr/share/doc/
if ($file->is_regular_file and $file->size == 0) {
# Exceptions: examples may contain empty files for various
# reasons, Doxygen generates empty *.map files, and Python
# uses __init__.py to mark module directories.
unless (
$fname =~ m,^usr/share/doc/(?:[^/]+/)?examples/,
or $fname
=~ m,^usr/share/doc/(?:.+/)?(?:doxygen|html)/.*\.map$,
or $fname
=~ m,^usr/share/doc/(?:.+/)?__init__\.py$,){
tag 'zero-byte-file-in-doc-directory', $file;
}
}
# gzipped zero byte files:
# 276 is 255 bytes (maximal length for a filename)
# + gzip overhead
if ( $fname =~ m,.gz$,
and $file->is_regular_file
and $file->size <= 276
and $file->file_info =~ m/gzip compressed/) {
my $fd = $file->open_gz;
my $f = <$fd>;
close($fd);
unless (defined $f and length $f) {
tag 'zero-byte-file-in-doc-directory', $file;
}
}
# contains an INSTALL file?
if ($fname =~ m,^usr/share/doc/$ppkg/INSTALL(?:\..+)*$,){
tag
'package-contains-upstream-install-documentation',
$file;
}
# contains a README for another distribution/platform?
if (
$fname =~ m,^usr/share/doc/$ppkg/readme\.
(?:apple|aix|atari|be|beos|bsd|bsdi
|cygwin|darwin|irix|gentoo|freebsd|mac|macos
|macosx|netbsd|openbsd|osf|redhat|sco|sgi
|solaris|suse|sun|vms|win32|win9x|windows
)(?:\.txt)?(?:\.gz)?$,xi
) {
#<<< No tidy (tag name too long)
tag 'package-contains-readme-for-other-platform-or-distro',
$file;
#>>>
}
# contains a compressed version of objects.inv in
# sphinx-generated documentation?
if ($fname
=~ m,^usr/share/doc/$ppkg/(?:[^/]+/)+objects\.inv\.gz$,
and $file->file_info =~ m/gzip compressed/) {
tag 'file-should-not-be-compressed', $file;
}
}
}
# ---------------- arch-indep pkgconfig
elsif ($file->is_regular_file
&& $fname=~ m,^usr/(lib(/[^/]+)?|share)/pkgconfig/[^/]+\.pc$,){
my $prefix = $1;
my $pkg_config_arch = $2 // '';
$pkg_config_arch =~ s,\A/,,ms;
tag 'pkg-config-unavailable-for-cross-compilation', $file
if $prefix eq 'lib';
my $fd = $file->open(':raw');
my $sfd = Lintian::SlidingWindow->new($fd);
BLOCK:
while (my $block = $sfd->readwindow) {
# remove comment line
$block =~ s,\#\V*,,gsm;
# remove continuation line
$block =~ s,\\\n, ,gxsm;
# check if pkgconfig file include path point to
# arch specific dir
MULTI_ARCH_DIR:
foreach my $arch ($MULTIARCH_DIRS->all) {
my $madir = $MULTIARCH_DIRS->value($arch);
if ($pkg_config_arch eq $madir) {
next MULTI_ARCH_DIR;
}
if ($block =~ m{\W\Q$madir\E(\W|$)}xms) {
tag 'pkg-config-multi-arch-wrong-dir',$file,
'full text contains architecture specific dir',
$madir;
last MULTI_ARCH_DIR;
}
}
PKG_CONFIG_TABOO:
foreach my $taboo ($PKG_CONFIG_BAD_REGEX->all) {
my $regex = $PKG_CONFIG_BAD_REGEX->value($taboo);
while($block =~ m{$regex}xmsg) {
my $extra = $1 // '';
$extra =~ s/\s+/ /g;
tag 'pkg-config-bad-directive', $file, $extra;
}
}
}
close($fd);
}
#----------------- /usr/X11R6/
# links to FHS locations are allowed
elsif ($fname =~ m,^usr/X11R6/, and not $file->is_symlink) {
tag 'package-installs-file-to-usr-x11r6', $file;
}
# ---------------- /usr/lib/debug
elsif ($fname =~ m,^usr/lib/debug/\S,) {
unless ($warned_debug_name) {
tag 'debug-package-should-be-named-dbg', $file
unless $info->is_pkg_class('debug');
$warned_debug_name = 1;
}
if ( $file->is_file
&& $fname
=~ m,^usr/lib/debug/usr/lib/pyshared/(python\d?(?:\.\d+))/(.++)$,o
) {
my $correct = "usr/lib/debug/usr/lib/pymodules/$1/$2";
tag 'python-debug-in-wrong-location', $file, $correct;
}
}
# ---------------- /usr/lib/sgml
elsif ($fname =~ m,^usr/lib/sgml/\S,) {
tag 'file-in-usr-lib-sgml', $file;
}
# ---------------- /usr/lib/node
elsif ($fname =~ m,^usr/lib/nodejs/,) {
if ($fname eq 'usr/lib/nodejs/package.json') {
tag 'node-package-install-in-nodejs-rootdir', $fname;
}elsif ($fname =~m,usr/lib/nodejs/[^/]*\.js$,) {
tag 'node-package-install-in-nodejs-rootdir', $fname;
}
}
# ---------------- perllocal.pod
elsif ($fname =~ m,^usr/lib/perl.*/perllocal.pod$,) {
tag 'package-installs-perllocal-pod', $file;
}
# ---------------- .packlist files
elsif ($fname =~ m,^usr/lib/perl.*/.packlist$,) {
tag 'package-installs-packlist', $file;
}elsif ($fname =~ m,^usr/lib/(?:[^/]+/)?perl5/.*\.p[lm]$,) {
push @nonbinary_perl_files_in_lib, $file;
}elsif ($fname =~ m,^usr/lib/(?:[^/]+/)?perl5/.*\.(?:bs|so)$,) {
$has_binary_perl_file = 1;
}
# ---------------- /usr/lib -- needs to go after the other usr/lib/*
elsif ($fname =~ m,^usr/lib/,) {
if ( $type ne 'udeb'
and $file =~ m,\.(?:bmp|gif|jpe?g|png|tiff|x[pb]m)$,
and not defined $link) {
tag 'image-file-in-usr-lib', $file;
}
}
# ---------------- /usr/local
elsif ($fname =~ m,^usr/local/\S+,) {
if ($file->is_dir) {
tag 'dir-in-usr-local', $file;
} else {
tag 'file-in-usr-local', $file;
}
}
# ---------------- /usr/share/applications
elsif (
$fname=~ m,^usr/share/applications/mimeinfo.cache(?:\.gz)?$,){
tag 'package-contains-mimeinfo.cache-file', $file;
}
# ---------------- /usr/share/cmake-*
elsif ($fname=~ m,^usr/share/cmake-\d+\.\d+/.+,){
unless ($source_pkg eq 'cmake') {
tag 'package-contains-cmake-private-file', $file;
}
}
# ---------------- /usr/share/mime/
elsif ($fname=~ m,^usr/share/mime/.+,) {
# ---------------- /usr/share/mime
if ($fname =~ m,^usr/share/mime/[^/]+$,) {
tag 'package-contains-mime-cache-file', $file;
}elsif ($fname!~ m,^usr/share/mime/packages/,) {
tag 'package-contains-mime-file-outside-package-dir',$file;
}
}
# ---------------- /usr/share/man
elsif ($fname =~ m,^usr/share/man/\S+,) {
if ($type eq 'udeb') {
tag 'udeb-contains-documentation-file', $file;
}
if ($file->is_dir) {
tag 'stray-directory-in-manpage-directory', $file
if ($fname
!~ m,^usr/(?:X11R6|share)/man/(?:[^/]+/)?(?:man\d/)?$,
);
} elsif ($file->is_file and ($operm & 0111)) {
tag 'executable-manpage', $file;
}
}
# ---------------- /usr/share/fonts/X11
elsif ($fname =~ m,^usr/share/fonts/X11/([^/]+)/\S+,) {
my $dir = $1;
if ($dir =~ /^(?:PEX|CID|Speedo|cyrillic)$/) {
tag 'file-in-discouraged-x11-font-directory', $file;
} elsif (
$dir !~ /^(?:100dpi|75dpi|misc|Type1|encodings|util)$/) {
tag 'file-in-unknown-x11-font-directory', $file;
} elsif ($file->basename eq 'encodings.dir'
or $file->basename =~ m{fonts\.(dir|scale|alias)}) {
tag 'package-contains-compiled-font-file', $file;
}
if ($dir =~ /^(?:100dpi|75dpi|misc)$/) {
$x11_font_dirs{$dir}++;
}
}
# ---------------- /usr/share/info
elsif ($fname =~ m,^usr/share/info\S+,) {
if ($type eq 'udeb') {
tag 'udeb-contains-documentation-file', $file;
}
if ($fname =~ m,^usr/share/info/dir(?:\.old)?(?:\.gz)?$,) {
tag 'package-contains-info-dir-file', $file;
}
}
# ---------------- /usr/share/linda/overrides
elsif ($fname =~ m,^usr/share/linda/overrides/\S+,) {
tag 'package-contains-linda-override', $file;
}
# ---------------- /usr/share/p11-kit/modules
elsif (
$fname =~ m{^usr/share/p11-kit/modules/.}
&& $fname !~ m{\A usr/share/p11-kit/modules/
[[:alnum:]][[:alnum:]_.-]*\.module\Z
}xsm
) {
tag 'incorrect-naming-of-pkcs11-module', $file;
}
# ---------------- /usr/share/vim
elsif ($fname =~ m,^usr/share/vim/vim(?:current|\d{2})/([^/]++),){
my $is_vimhelp = $1 eq 'doc' && $pkg =~ m,^vimhelp-\w++$,;
my $is_vim = $source_pkg =~ m,vim,;
tag 'vim-addon-within-vim-runtime-path', $file
unless $is_vim
or $is_vimhelp;
}
# ---------------- /usr/share
elsif ($fname =~ m,^usr/share/[^/]+$,) {
if ($file->is_file) {
tag 'file-directly-in-usr-share', $file;
}
}
# ---------------- /usr/bin
elsif ($fname =~ m,^usr/bin/,) {
if ( $file->is_dir
and $fname =~ m,^usr/bin/.,
and $fname !~ m,^usr/bin/(?:X11|mh)/,) {
tag 'subdir-in-usr-bin', $file;
}
# check old style config script
elsif ( $file->is_regular_file
and $fname =~ m,-config$,
and $script{$file}) {
# try to find some indication of
# config file (read only one block)
my $fd = $file->open(':raw');
my $sfd = Lintian::SlidingWindow->new($fd);
my $block = $sfd->readwindow;
# some common stuff found in config file
if (
$block
and ( index($block,'flag')>-1
or index($block,'/include/') > -1
or index($block,'pkg-config') > -1)
) {
tag 'old-style-config-script',$file;
# could be ok but only if multi-arch: no
if($multiarch ne 'no' or $arch eq 'all') {
# check multi-arch path
foreach my $archs ($MULTIARCH_DIRS->all) {
my $madir= $MULTIARCH_DIRS->value($archs);
if ($block =~ m{\W\Q$madir\E(\W|$)}xms){
# allow files to begin with triplet if it matches arch
if($file->basename =~ m{^\Q$madir\E}xms) {
next;
}
if($arch eq 'all') {
#<<< No perltidy - tag name too long
tag
'old-style-config-script-multiarch-path-arch-all',
$file,
'full text contains architecture specific dir',
$madir;
#>>>
} else {
#<<< No perltidy - tag name too long
tag
'old-style-config-script-multiarch-path',
$file,
'full text contains architecture specific dir',
$madir;
#>>>
}
last;
}
}
}
}
close($fd);
}
}
# ---------------- /usr subdirs
elsif ($type ne 'udeb' and $fname =~ m,^usr/[^/]+/$,)
{ # FSSTND dirs
if ($fname=~ m,^usr/(?:dict|doc|etc|info|man|adm|preserve)/,){
tag 'FSSTND-dir-in-usr', $file;
}
# FHS dirs
elsif (
$fname !~ m,^usr/(?:X11R6|X386|
bin|games|include|
lib|
local|sbin|share|
src|spool|tmp)/,x
) {
if ($fname =~ m,^usr/lib(?'libsuffix'64|x?32)/,) {
my $libsuffix = $+{libsuffix};
# eglibc exception is due to FHS. Other are
# transitional, waiting for full
# implementation of multi-arch. Note that we
# allow (e.g.) "lib64" packages to still use
# these dirs, since their use appears to be by
# intention.
unless ($source_pkg =~ m/^e?glibc$/
or $pkg =~ m/^lib$libsuffix/) {
tag 'non-multi-arch-lib-dir', $file;
}
} else {
tag 'non-standard-dir-in-usr', $file;
}
}
# unless $file =~ m,^usr/[^/]+-linuxlibc1/,; was tied
# into print above...
# Make an exception for the altdev dirs, which will go
# away at some point and are not worth moving.
}
# ---------------- .desktop files
# People have placed them everywhere, but nowadays the
# consensus seems to be to stick to the fd.org standard
# drafts, which says that .desktop files intended for
# menus should be placed in $XDG_DATA_DIRS/applications.
# The default for $XDG_DATA_DIRS is
# /usr/local/share/:/usr/share/, according to the
# basedir-spec on fd.org. As distributor, we should only
# allow /usr/share.
#
# KDE hasn't moved its files from /usr/share/applnk, so
# don't warn about this yet until KDE adopts the new
# location.
elsif ($fname =~ m,^usr/share/gnome/apps/.*\.desktop$,) {
tag 'desktop-file-in-wrong-dir', $file;
}
# ---------------- non-games-specific data in games subdirectory
elsif ($fname
=~ m,^usr/share/games/(?:applications|mime|icons|pixmaps)/,
and not $file->is_dir) {
tag 'global-data-in-games-directory', $file;
}
}
# ---------------- /var subdirs
elsif ($type ne 'udeb' and $fname =~ m,^var/[^/]+/$,) { # FSSTND dirs
if ($fname =~ m,^var/(?:adm|catman|named|nis|preserve)/,) {
tag 'FSSTND-dir-in-var', $file;
}
# base-files is special
elsif ($pkg eq 'base-files'
&& $fname =~ m,^var/(?:backups|local)/,){
# ignore
}
# FHS dirs with exception in Debian policy
elsif (
$fname !~ m{\A var/
(?: account|lib|cache|crash|games
|lock|log|opt|run|spool|state
|tmp|www|yp)/
}xsm
) {
tag 'non-standard-dir-in-var', $file;
}
} elsif ($type ne 'udeb' and $fname =~ m,^var/lib/games/.,) {
tag 'non-standard-dir-in-var', $file;
# ---------------- /var/lock, /var/run
} elsif ($type ne 'udeb' and $fname =~ m,^var/lock/.,) {
tag 'dir-or-file-in-var-lock', $file;
} elsif ($type ne 'udeb' and $fname =~ m,^var/run/.,) {
tag 'dir-or-file-in-var-run', $file;
} elsif ($type ne 'udeb' and $fname =~ m,^run/.,o) {
tag 'dir-or-file-in-run', $file;
}
# ---------------- /var/www
# Packages are allowed to create /var/www since it's
# historically been the default document root, but they
# shouldn't be installing stuff under that directory.
elsif ($fname =~ m,^var/www/\S+,) {
tag 'dir-or-file-in-var-www', $file;
}
# ---------------- /opt
elsif ($fname =~ m,^opt/.,) {
tag 'dir-or-file-in-opt', $file;
} elsif ($fname =~ m,^hurd/,) {
next;
} elsif ($fname =~ m,^servers/,) {
next;
}
# -------------- /home
elsif ($fname =~ m,^home/.,) {
tag 'dir-or-file-in-home', $file;
} elsif ($fname =~ m,^root/.,) {
tag 'dir-or-file-in-home', $file;
}
# ---------------- /tmp, /var/tmp, /usr/tmp
elsif (_is_tmp_path($fname)) {
tag 'dir-or-file-in-tmp', $file;
}
# ---------------- /mnt
elsif ($fname =~ m,^mnt/.,) {
tag 'dir-or-file-in-mnt', $file;
}
# ---------------- /bin
elsif ($fname =~ m,^bin/,) {
if ($file->is_dir and $fname =~ m,^bin/.,) {
tag 'subdir-in-bin', $file;
}
}
# ---------------- /srv
elsif ($fname =~ m,^srv/.,) {
tag 'dir-or-file-in-srv', $file;
}
# ---------------- FHS directory?
elsif (
$fname =~ m,^[^/]+/$,o
and $fname !~ m{\A (?:
bin|boot|dev|etc|home|lib
|mnt|opt|root|run|sbin|srv|sys
|tmp|usr|var) /
}oxsm
) {
# Make an exception for the base-files package here and
# other similar packages because they install a slew of
# top-level directories for setting up the base system.
# (Specifically, /cdrom, /floppy, /initrd, and /proc are
# not mentioned in the FHS).
if ($fname =~ m,^lib(?'libsuffix'64|x?32)/,) {
my $libsuffix = $+{libsuffix};
# see comments for ^usr/lib(?'libsuffix'64|x?32)
unless ($source_pkg =~ m/^e?glibc$/
or $pkg =~ m/^lib$libsuffix/) {
tag 'non-multi-arch-lib-dir', $file;
}
} else {
unless ($pkg eq 'base-files'
or $pkg eq 'hurd'
or $pkg eq 'hurd-udeb'
or $pkg =~ /^rootskel(?:-bootfloppy)?/) {
tag 'non-standard-toplevel-dir', $file;
}
}
}
# ---------------- compatibility symlinks should not be used
if ( $fname =~ m,^usr/(?:spool|tmp)/,
or $fname =~ m,^usr/(?:doc|bin)/X11/,
or $fname =~ m,^var/adm/,) {
tag 'use-of-compat-symlink', $file;
}
# ---------------- any files
if (not $file->is_dir) {
unless (
$type eq 'udeb'
or $fname =~ m,^usr/(?:bin|dict|doc|games|
include|info|lib(?:x?32|64)?|
man|sbin|share|src|X11R6)/,x
or $fname =~ m,^lib(?:x?32|64)?/(?:modules/|libc5-compat/)?,
or $fname =~ m,^var/(?:games|lib|www|named)/,
or $fname =~ m,^(?:bin|boot|dev|etc|sbin)/,
# non-FHS, but still usual
or $fname =~ m,^usr/[^/]+-linux[^/]*/,
or $fname =~ m,^usr/iraf/,
# not allowed, but tested individually
or $fname =~ m{\A (?:
build|home|mnt|opt|root|run|srv
|(?:(?:usr|var)/)?tmp)|var/www/}xsm
) {
tag 'file-in-unusual-dir', $file;
}
if ( defined($multiarch_dir)
and $multiarch eq 'foreign'
and $fname =~ m,^usr/lib/\Q$multiarch_dir\E/(.*)$,) {
my $tail = $1;
tag 'multiarch-foreign-cmake-file', $file
if ($tail =~ m,^cmake/.+\.cmake$,);
tag 'multiarch-foreign-pkgconfig', $file
if ($tail =~ m,^pkgconfig/[^/]+\.pc$,);
tag 'multiarch-foreign-static-library', $file
if ($tail =~ m,^lib[^/]+\.a$,);
}
}
if ($fname =~ m,^(?:usr/)?lib/([^/]+)/$,o) {
my $subdir = $1;
if ($TRIPLETS->known($subdir)) {
tag 'triplet-dir-and-architecture-mismatch', "$file is for",
$TRIPLETS->value($subdir)
unless ($arch eq $TRIPLETS->value($subdir));
}
}
if ($fname =~ m,^(?:usr/)?lib/(?:([^/]+)/)?lib[^/]*\.so$,) {
$has_public_shared_library = 1
if (!defined($1) || $TRIPLETS->known($1));
}
# ---------------- .pyc/.pyo (compiled Python files)
# skip any file installed inside a __pycache__ directory
# - we have a separate check for that directory.
if ($fname =~ m,\.py[co]$,o && $fname !~ m,/__pycache__/,o) {
tag 'package-installs-python-bytecode', $file;
}
# ---------------- __pycache__ (directory for pyc/pyo files)
if ($file->is_dir && $fname =~ m,/__pycache__/,o){
tag 'package-installs-python-pycache-dir', $file;
}
# ---------------- .egg (Python egg files)
if (
$fname =~ m,\.egg$,o
&& ( $fname =~ m,^usr/lib/python\d+(?:\.\d+/),o
|| $fname =~ m,^usr/lib/pyshared,o
|| $fname =~ m,^usr/share/,o)
) {
tag 'package-installs-python-egg', $file;
}
# ---------------- .class (compiled Java files)
if ( $fname =~ m,\.class$,o
&& $fname !~ m,(?:WEB-INF|demo|doc|example|sample|test),o) {
my $fd = $file->open;
read($fd, my $magic, 4);
close($fd);
tag 'package-installs-java-bytecode', $file
if $magic eq "\xCA\xFE\xBA\xBE";
}
# ---------------- /usr/lib/site-python
if ($fname =~ m,^usr/lib/site-python/\S,) {
tag 'file-in-usr-lib-site-python', $file;
}
# ---------------- pythonX.Y extensions
if ($fname =~ m,^usr/lib/python\d\.\d/\S,
and not $fname=~ m,^usr/lib/python\d\.\d/(?:site|dist)-packages/,){
# check if it's one of the Python proper packages
unless (defined $is_python) {
$is_python = 0;
$is_python = 1
if $source_pkg =~ m/^python(?:\d\.\d)?$/
or $source_pkg =~ m{\A python\d?-
(?:stdlib-extensions|profiler|old-doctools) \Z}xsm;
}
tag 'third-party-package-in-python-dir', $file
unless $is_python;
}
# ---------------- perl modules
if ($fname =~ m,^usr/(?:share|lib)/perl/\S,) {
# check if it's the "perl" package itself
unless (defined $is_perl) {
$is_perl = 0;
$is_perl = 1 if $source_pkg eq 'perl';
}
tag 'perl-module-in-core-directory', $file
unless $is_perl;
}
# ---------------- perl modules using old libraries
# we do the same check on perl scripts in checks/scripts
{
my $dep = $info->relation('strong');
if ( $file->is_file
&& $fname =~ m,\.pm$,
&& !$dep->implies(
'libperl4-corelibs-perl | perl (<< 5.12.3-7)')) {
my $fd = $file->open;
while (<$fd>) {
if (
m{ (?:do|require)\s+['"] # do/require
# Huge list of perl4 modules...
(abbrev|assert|bigfloat|bigint|bigrat
|cacheout|complete|ctime|dotsh|exceptions
|fastcwd|find|finddepth|flush|getcwd|getopt
|getopts|hostname|importenv|look|newgetopt
|open2|open3|pwd|shellwords|stat|syslog
|tainted|termcap|timelocal|validate)
# ... so they end with ".pl" rather than ".pm"
\.pl['"]
}xsm
) {
tag 'perl-module-uses-perl4-libs-without-dep',
"$file:$. ${1}.pl";
}
}
close($fd);
}
}
# ---------------- license files
if (
$file->basename =~ m{ \A
# Look for commonly used names for license files
(?: copying | licen[cs]e | l?gpl | bsd | artistic )
# ... possibly followed by a version
[v0-9._-]*
(?:\. .* )? \Z
}xsmi
# Ignore some common extensions for source or compiled
# extension files. There was at least one file named
# "license.el". These are probably license-displaying
# code, not license files. Also ignore executable files
# in general. This means we get false-negatives for
# licenses files marked executable, but these will trigger
# a warning about being executable. (See #608866)
#
# Another exception is made for .html and .php because
# preserving working links is more important than saving
# some bytes, and because a package had an HTML form for
# licenses called like that. Another exception is made
# for various picture formats since those are likely to
# just be simply pictures.
#
# DTD files are excluded at the request of the Mozilla
# suite maintainers. Zope products include license files
# for runtime display. underXXXlicense.docbook files are
# from KDE.
#
# Ignore extra license files in examples, since various
# package building software includes example packages with
# licenses.
and ($operm & 0111) == 0
and not $fname =~ m{ \. (?:
# Common "non-license" file extensions...
el|[ch]|cc|p[ylmc]|[hu]i|p_hi|html|php|rb|xpm
|png|jpe?g|gif|svg|dtd|mk|lisp|yml|rs|ogg
) \Z}xsm
and not $fname=~ m,^usr/share/zope/Products/.*\.(?:dtml|pt|cpt)$,
and not $fname =~ m,/under\S+License\.docbook$,
and not $fname =~ m,^usr/share/doc/[^/]+/examples/,
# liblicense has a manpage called license
and not $fname =~ m,^usr/share/man/(?:[^/]+/)?man\d/,o
# liblicense (again)
and not $fname =~ m,^usr/share/pyshared-data/,o
# Rust crate unmodified upstream sources
and not $fname =~ m,^usr/share/cargo/registry/,o
# Some GNOME/GTK software uses these to show the "license
# header".
and not $fname =~ m,
^usr/share/(?:gnome/)?help/[^/]+/[^/]+/license\.page$
,x
# base-files (which is required to ship them)
and not $fname =~ m,^usr/share/common-licenses/[^/]+$,o
and not defined $link
# Sphinx includes various license files
and not $fname =~ m,/_sources/license(\.rst)?\.txt$,oi
) {
# okay, we cannot rule it out based on file name; but if
# it is an elf or a static library, we also skip it. (In
# case you hadn't guessed; liblicense)
my $fileinfo = $file->file_info;
tag 'extra-license-file', $file
unless $fileinfo and ($fileinfo =~ m/^[^,]*\bELF\b/)
or ($fileinfo =~ m/\bcurrent ar archive\b/);
}
# ---------------- .devhelp2? files
if (
$fname =~ m,\.devhelp2?(?:\.gz)?$,
# If the file is located in a directory not searched by devhelp, we
# check later to see if it's in a symlinked directory.
and not $fname =~ m,^usr/share/(?:devhelp/books|gtk-doc/html)/,
and not $fname =~ m,^usr/share/doc/[^/]+/examples/,
) {
push(@devhelp, $fname);
}
# ---------------- weird file names
if ($fname =~ m,\s+\z,) {
tag 'file-name-ends-in-whitespace', $file;
}
if ($fname =~ m,/\*\z,) {
tag 'star-file', $file;
}
if ($fname =~ m,/-\z,) {
tag 'hyphen-file', $file;
}
# ---------------- misplaced lintian overrides
if ( $fname =~ m,^usr/share/doc/$ppkg/override\.[lL]intian(?:\.gz)?$,
or $fname =~ m,^usr/share/lintian/overrides/$ppkg/.+,) {
tag 'override-file-in-wrong-location', $file;
} elsif ($fname =~ m,^usr/share/lintian/overrides/(.+)/.+$,) {
tag 'override-file-in-wrong-package', $file if $1 ne $pkg;
}
# doxygen md5sum
if ($fname =~ m,^usr/share/doc/$ppkg/[^/]+/.+\.md5$,) {
if ($file->parent_dir->child('doxygen.png')) {
tag 'useless-autogenerated-doxygen-file', $file;
}
}
# doxygen compressed map
if (
$fname =~ m,^usr/share/doc/(?:.+/)?(?:doxygen|html)/
.*\.map\.$COMPRESS_FILE_EXTENSIONS_OR_ALL,x
) {
tag 'file-should-not-be-compressed', $file;
}
# ---------------- Python file locations
# - The Python people kindly provided the following table.
# good:
# /usr/lib/python2.5/site-packages/
# /usr/lib/python2.6/dist-packages/
# /usr/lib/python2.7/dist-packages/
# /usr/lib/python3/dist-packages/
#
# bad:
# /usr/lib/python2.5/dist-packages/
# /usr/lib/python2.6/site-packages/
# /usr/lib/python2.7/site-packages/
# /usr/lib/python3.*/*-packages/
if (
$fname =~ m{\A
(usr/lib/debug/)?
usr/lib/python (\d+(?:\.\d+)?)/
(site|dist)-packages/(.++)
\Z}oxsm
){
my ($debug, $pyver, $loc, $rest) = ($1, $2, $3, $4);
my ($pmaj, $pmin) = split(m/\./o, $pyver, 2);
my @correction;
$pmin = 0 unless (defined $pmin);
$debug = '' unless (defined $debug);
next if ($pmaj < 2 or $pmaj > 3); # Not Python 2 or 3
if ($pmaj == 2 and $pmin < 6){
# 2.4 and 2.5
if ($loc ne 'site') {
@correction = (
"${debug}usr/lib/python${pyver}/$loc-packages/$rest",
"${debug}usr/lib/python${pyver}/site-packages/$rest"
);
}
} elsif ($pmaj == 3){
# Python 3. Everything must be in python3/dist-... and
# not python3.X/<something>
if ($pyver ne '3' or $loc ne 'dist'){
# bad mojo
@correction = (
"${debug}usr/lib/python${pyver}/$loc-packages/$rest",
"${debug}usr/lib/python3/dist-packages/$rest"
);
}
} else {
# Python 2.6+
if ($loc ne 'dist') {
@correction = (
"${debug}usr/lib/python${pyver}/$loc-packages/$rest",
"${debug}usr/lib/python${pyver}/dist-packages/$rest"
);
}
}
tag 'python-module-in-wrong-location', @correction
if (@correction);
for my $regex ($GENERIC_PYTHON_MODULES->all) {
tag 'python-module-has-overly-generic-name', $fname, "($1)"
if $rest =~ m,^($regex)(?:\.py|/__init__\.py)$,i;
}
}
if ($fname =~ m,/icons/[^/]+/(\d+)x(\d+)/(?!animations/).*\.png$,){
my ($dwidth, $dheight) = ($1, $2);
my $path = $file->resolve_path;
if ($path && $path->file_info =~ m/,\s*(\d+)\s*x\s*(\d+)\s*,/) {
my ($fwidth, $fheight) = ($1, $2);
my $width_delta = abs($dwidth - $fwidth);
my $height_delta = abs($dheight - $fheight);
tag 'icon-size-and-directory-name-mismatch', $file,
$fwidth.'x'.$fheight
unless ($width_delta <= 2 && $height_delta <= 2);
}
}
# ---------------- plain files
if ($file->is_file) {
if ($fname =~ m,/icons/[^/]+/scalable/.*\.(?:png|xpm)$,) {
tag 'raster-image-in-scalable-directory', $file;
}
# ---------------- backup files and autosave files
if ( $fname =~ /~$/
or $fname =~ m,\#[^/]+\#$,
or $fname =~ m,/\.[^/]+\.swp$,) {
tag 'backup-file-in-package', $file;
}
if ($fname =~ m,/\.nfs[^/]+$,) {
tag 'nfs-temporary-file-in-package', $file;
}
# ---------------- vcs control files
if ( $fname =~ m,$VCS_FILES_OR_ALL,
and $fname !~ m,^usr/share/cargo/registry/,) {
tag 'package-contains-vcs-control-file', $file;
}
# ---------------- subversion and svk commit message backups
if ($fname =~ m/svn-commit.*\.tmp$/) {
tag 'svn-commit-file-in-package', $file;
}
if ($fname =~ m/svk-commit.+\.tmp$/) {
tag 'svk-commit-file-in-package', $file;
}
# ---------------- executables with language extensions
if (
$fname =~ m{\A
(?:usr/)?(?:s?bin|games)/[^/]+\.
(?:p[ly]|php|rb|[bc]?sh|tcl)
\Z}xsm
) {
tag 'script-with-language-extension', $file;
}
# ---------------- Devel files for Windows
if ( $fname =~ m,/.+\.(?:vcproj|sln|ds[pw])(?:\.gz)?$,
and $fname !~ m,^usr/share/doc/,) {
tag 'windows-devel-file-in-package', $file;
}
# ---------------- Autogenerated databases from other OSes
if ($fname =~ m,/Thumbs\.db(?:\.gz)?$,i) {
tag 'windows-thumbnail-database-in-package', $file;
}
if ($fname =~ m,/\.DS_Store(?:\.gz)?$,) {
tag 'macos-ds-store-file-in-package', $file;
}
if ($fname =~ m,/\._[^_/][^/]*$, and $file !~ m/\.swp$/) {
tag 'macos-resource-fork-file-in-package', $file;
}
# ---------------- embedded libraries
_detect_embedded_libraries($fname, $file, $pkg)
# Ignore embedded jQuery libraries for Doxygen (#736360)
unless $file->basename eq 'jquery.js'
and defined(
$info->index_resolved_path($file->dirname . 'doxygen.css'));
# ---------------- embedded Feedparser library
if ( $fname =~ m,/feedparser\.py$,
and $source_pkg ne 'feedparser'){
my $fd = $file->open;
while (<$fd>) {
if (m,Universal feed parser,) {
tag 'embedded-feedparser-library', $file;
last;
}
}
close($fd);
}
# ---------------- html/javascript
if ($fname =~ m,\.(?:x?html?|js|xht|xml|css)$,i) {
if( $source_pkg eq 'josm'
and $file->basename eq 'defaultpresets.xml') {
# false positive
} else {
detect_privacy_breach($file);
}
}
# ---------------- fonts
elsif ($fname =~ m,/([\w-]+\.(?:[to]tf|pfb))$,i) {
my $font = lc $1;
if (my $font_owner = $FONT_PACKAGES->value($font)) {
tag 'duplicate-font-file', "$fname also in", $font_owner
if ($pkg ne $font_owner and $type ne 'udeb');
} elsif ($pkg !~ m/^(?:[ot]tf|t1|x?fonts)-/) {
tag 'font-in-non-font-package', $file;
}
my $finfo = $file->file_info;
if ($finfo =~ m/PostScript Type 1 font program data/) {
my $path = $file->fs_path;
my $foundadobeline = 0;
open(my $t1pipe, '-|', 't1disasm', $path);
while (my $line = <$t1pipe>) {
if ($foundadobeline) {
if (
$line =~ m{\A [%\s]*
All\s*Rights\s*Reserved\.?\s*
\Z}xsmi
) {
#<<< No perltidy - tag name too long
tag 'license-problem-font-adobe-copyrighted-fragment',
$file;
#>>>
last;
} else {
$foundadobeline = 0;
}
}
if (
$line =~ m{\A
[%\s]*Copyright\s*\(c\) \s*
19\d{2}[\-\s]19\d{2}\s*
Adobe\s*Systems\s*Incorporated\.?\s*\Z}xsmi
) {
$foundadobeline = 1;
}
# If copy pasted from black book they are
# copyright adobe a few line before the only
# place where the startlock is documented is
# in the black book copyrighted fragment
if ($line =~ m/startlock\s*get\s*exec/) {
#<<< no perltidy - tag name too long
tag 'license-problem-font-adobe-copyrighted-fragment-no-credit',
$file;
#>>>
last;
}
}
drain_pipe($t1pipe);
close($t1pipe);
}
}
# ---------------- non-free .swf files
unless ($info->is_non_free) {
foreach my $flash (@flash_nonfree) {
if ($fname =~ m,/$flash,) {
tag 'non-free-flash', $file;
}
}
}
# ---------------- .gz files
if ($fname =~ m/\.gz$/) {
my $finfo = $file->file_info;
if ($finfo !~ m/gzip compressed/) {
tag 'gz-file-not-gzip', $file;
} else {
my ($buff, $mtime);
my $fd = $file->open;
# We need to read at least 8 bytes
if (sysread($fd, $buff, 1024) >= 8) {
# Extract the flags and the mtime.
# NN NN NN NN, NN NN NN NN - bytes read
# __ __ __ __, $mtime - variables
(undef, $mtime) = unpack('NN', $buff);
} else {
internal_error("reading $file failed: $!");
}
close($fd);
if ($mtime != 0) {
if ($multiarch eq 'same' && $file !~ m/\Q$arch\E/) {
tag 'gzip-file-is-not-multi-arch-same-safe',$file;
} else {
# see https://bugs.debian.org/762105
my $diff= $file->timestamp - $changelog_timestamp;
if ($diff > 0) {
tag 'package-contains-timestamped-gzip',$file;
}
}
}
}
}
# --------------- compressed + uncompressed files
if ($fname =~ $DUPLICATED_COMPRESSED_FILE_REGEX) {
tag 'duplicated-compressed-file', $file
if $info->index($1);
}
# ---------------- general: setuid/setgid files!
if ($operm & 06000) {
my ($setuid, $setgid) = ('','');
# get more info:
$setuid = $file->owner if $operm & 04000;
$setgid = $file->group if $operm & 02000;
# 1st special case: program is using svgalib:
if (exists $linked_against_libvga{$fname}) {
# setuid root is ok, so remove it
if ($setuid eq 'root') {
undef $setuid;
}
}
# 2nd special case: program is a setgid game
if ( $fname =~ m,^usr/lib/games/\S+,
or $fname =~ m,^usr/games/\S+,) {
# setgid games is ok, so remove it
if ($setgid eq 'games') {
undef $setgid;
}
}
# 3rd special case: allow anything with suid in the name
if ($pkg =~ m,-suid,) {
undef $setuid;
}
# Check for setuid and setgid that isn't expected.
if ($setuid and $setgid) {
tag 'setuid-gid-binary', $file,
sprintf('%04o %s',$operm,$owner);
} elsif ($setuid) {
tag 'setuid-binary', $file,
sprintf('%04o %s',$operm,$owner);
} elsif ($setgid) {
tag 'setgid-binary', $file,
sprintf('%04o %s',$operm,$owner);
}
# Check for permission problems other than the setuid status.
if (($operm & 0444) != 0444) {
tag 'executable-is-not-world-readable', $file,
sprintf('%04o',$operm);
} elsif ($operm != 04755
&& $operm != 02755
&& $operm != 06755
&& $operm != 04754) {
tag 'non-standard-setuid-executable-perm', $file,
sprintf('%04o',$operm);
}
}
# ---------------- general: executable files
elsif ($operm & 0111) {
# executable
if ($owner eq 'root/games') {
if ($operm != 2755) {
tag 'non-standard-game-executable-perm', $file,
sprintf('%04o != 2755',$operm);
}
} else {
if (($operm & 0444) != 0444) {
tag 'executable-is-not-world-readable', $file,
sprintf('%04o',$operm);
} elsif ($operm != 0755) {
tag 'non-standard-executable-perm', $file,
sprintf('%04o != 0755',$operm);
}
}
}
# ---------------- general: normal (non-executable) files
else {
# not executable
# special case first: game data
if ( $operm == 0664
and $owner eq 'root/games'
and $fname =~ m,^var/(lib/)?games/\S+,) {
# everything is ok
} elsif ($fname =~ m,^usr/lib/.*\.ali$,) {
# GNAT compiler wants read-only Ada library information.
tag 'bad-permissions-for-ali-file', $file
if ($operm != 0444);
} elsif ($operm == 0600 and $fname =~ m,^etc/backup.d/,) {
# backupninja expects configurations files to be 0600
} elsif ($fname =~ m,^etc/sudoers.d/,) {
# sudo requires sudoers files to be mode 0440
tag 'bad-perm-for-file-in-etc-sudoers.d', $file,
sprintf('%04o != 0440', $operm)
unless $operm == 0440;
} elsif ($operm != 0644) {
tag 'non-standard-file-perm', $file,
sprintf('%04o != 0644',$operm);
}
}
}
# ---------------- directories
elsif ($file->is_dir) {
if ($file->faux) {
tag 'missing-intermediate-directory', $file;
}
# special cases first:
# game directory with setgid bit
if ( $fname =~ m,^var/(?:lib/)?games/\S+,
and $operm == 02775
and $owner eq 'root/games') {
# do nothing, this is allowed, but not mandatory
} elsif ((
$fname eq 'tmp/'
or $fname eq 'var/tmp/'
or $fname eq 'var/lock/'
)
and $operm == 01777
and $owner eq 'root/root'
) {
# actually shipping files here is warned about elsewhere
} elsif ($fname eq 'usr/src/'
and $operm == 02775
and $owner eq 'root/src') {
# /usr/src as created by base-files is a special exception
} elsif ($fname eq 'var/local/'
and $operm == 02775
and $owner eq 'root/staff') {
# actually shipping files here is warned about elsewhere
}
# otherwise, complain if it's not 0755.
elsif ($operm != 0755) {
tag 'non-standard-dir-perm', $file,
sprintf('%04o != 0755', $operm);
}
if ($fname =~ m,/CVS/?$,) {
tag 'package-contains-vcs-control-dir', $file;
}
if ($fname =~ m,/\.(?:svn|bzr|git|hg)/?$,) {
tag 'package-contains-vcs-control-dir', $file;
}
if ( ($fname =~ m,/\.arch-ids/?$,)
|| ($fname =~ m,/\{arch\}/?$,)) {
tag 'package-contains-vcs-control-dir', $file;
}
if ($fname =~ m,/\.(?:be|ditrack)/?$,) {
tag 'package-contains-bts-control-dir', $file;
}
if ($fname =~ m,/\.xvpics/?$,) {
tag 'package-contains-xvpics-dir', $file;
}
if ($fname =~ m,/\.thumbnails/?$,) {
tag 'package-contains-thumbnails-dir', $file;
}
if ($fname =~ m,usr/share/doc/[^/]+/examples/examples/?$,) {
tag 'nested-examples-directory', $file;
}
if ($fname =~ m,^usr/share/locale/([^/]+)/$,) {
# Without encoding:
my ($lwccode) = split(m/[.@]/, $1);
# Without country code:
my ($lcode) = split(m/_/, $lwccode);
# special exception:
if ($lwccode ne 'l10n') {
if ($INCORRECT_LOCALE_CODES->known($lwccode)) {
tag 'incorrect-locale-code',
"$lwccode ->",
$INCORRECT_LOCALE_CODES->value($lwccode);
} elsif ($INCORRECT_LOCALE_CODES->known($lcode)) {
tag 'incorrect-locale-code',
"$lcode ->",
$INCORRECT_LOCALE_CODES->value($lcode);
} elsif (!$LOCALE_CODES->known($lcode)) {
tag 'unknown-locale-code', $lcode;
} elsif ($LOCALE_CODES->known($lcode)
&& defined($LOCALE_CODES->value($lcode))) {
# If there's a key-value pair in the codes
# list it means the ISO 639-2 code is being
# used instead of ISO 639-1's
tag 'incorrect-locale-code', "$lcode ->",
$LOCALE_CODES->value($lcode);
}
}
}
}
# ---------------- symbolic links
elsif ($file->is_symlink) {
# link
my $mylink = $link;
if ($mylink =~ s,//+,/,g) {
tag 'symlink-has-double-slash', "$fname $link";
}
if ($mylink =~ s,(.)/$,$1,) {
tag 'symlink-ends-with-slash', "$fname $link";
}
# determine top-level directory of file
$fname =~ m,^/?([^/]*),;
my $filetop = $1;
if ($mylink =~ m,^/([^/]*),) {
my $flinkname = substr($mylink,1);
# absolute link, including link to /
# determine top-level directory of link
my $linktop = $1;
if ($type ne 'udeb' and $filetop eq $linktop) {
# absolute links within one toplevel directory are _not_ ok!
tag 'symlink-should-be-relative', "$fname $link";
}
_tag_build_tree_path($flinkname,
"symlink $file point to $mylink");
if(_is_tmp_path($flinkname)) {
tag 'dir-or-file-in-tmp', "symlink $file point to $mylink";
}
# Any other case is already definitely non-recursive
tag 'symlink-is-self-recursive', "$fname $link"
if $mylink eq '/';
} else {
# relative link, we can assume from here that the link
# starts nor ends with /
my @filecomponents = split('/', $fname);
# chop off the name of the symlink
pop @filecomponents;
my @linkcomponents = split('/', $mylink);
# handle `../' at beginning of $link
my ($lastpop, $linkcomponent);
while ($linkcomponent = shift @linkcomponents) {
if ($linkcomponent eq '.') {
tag 'symlink-contains-spurious-segments',
"$fname $link"
unless $mylink eq '.';
next;
}
last if $linkcomponent ne '..';
if (@filecomponents) {
$lastpop = pop @filecomponents;
} else {
tag 'symlink-has-too-many-up-segments',"$fname $link";
goto NEXT_LINK;
}
}
if (!defined $linkcomponent) {
# After stripping all starting .. components, nothing left
tag 'symlink-is-self-recursive', "$fname $link";
}
# does the link go up and then down into the same
# directory? (lastpop indicates there was a backref
# at all, no linkcomponent means the symlink doesn't
# get up anymore)
if ( defined $lastpop
&& defined $linkcomponent
&& $linkcomponent eq $lastpop) {
tag 'lengthy-symlink', "$fname $link";
}
if ($#filecomponents == -1) {
# we've reached the root directory
if ( ($type ne 'udeb') && (!defined $linkcomponent)
|| ($filetop ne $linkcomponent)) {
# relative link into other toplevel directory.
# this hits a relative symbolic link in the root too.
tag 'symlink-should-be-absolute', "$fname $link";
}
}
# check additional segments for mistakes like `foo/../bar/'
foreach (@linkcomponents) {
if ($_ eq '..' || $_ eq '.') {
tag 'symlink-contains-spurious-segments',
"$fname $link";
last;
}
}
}
NEXT_LINK:
if ($link =~ $COMPRESSED_SYMLINK_POINTING_TO_COMPRESSED_REGEX) {
# symlink is pointing to a compressed file
# symlink has correct extension?
unless ($fname =~ m,\.$1\s*$,) {
tag 'compressed-symlink-with-wrong-ext', "$fname $link";
}
}
}
# ---------------- special files
else {
# special file
tag 'special-file', $fname, sprintf('%04o',$operm);
}
}
if (!$is_dummy && !$arch_dep_files && $arch ne 'all') {
tag 'package-contains-no-arch-dependent-files'
unless $type eq 'udeb';
}
# Check for section games but nothing in /usr/games. Check for
# any binary to save ourselves from game-data false positives:
my $games = dir_counts($info, 'usr/games/');
my $other = dir_counts($info, 'bin/') + dir_counts($info, 'usr/bin/');
if ($other) {
if ($pkg_section =~ m,games$,) {
if ($games) {
tag 'package-section-games-but-has-usr-bin';
} else {
tag 'package-section-games-but-contains-no-game';
}
}
} elsif ($games > 0 and $pkg_section !~ m,games$,) {
tag 'games-package-should-be-section-games';
}
# Warn about empty directories, but ignore empty directories in
# /var (packages create directories to hold dynamically created
# data) or /etc (configuration files generated by maintainer
# scripts). Also skip base-files, which is a very special case.
#
# Empty Perl directories are an ExtUtils::MakeMaker artifact that
# will be fixed in Perl 5.10, and people can cause more problems
# by trying to fix it, so just ignore them.
if ($pkg ne 'base-files') {
foreach my $dir ($info->sorted_index) {
next if not $dir->is_dir;
my $dirname = $dir->name;
next if ($dirname =~ m{^var/} or $dirname =~ m{^etc/});
if (scalar($dir->children) == 0) {
if ( $dirname !~ m;^usr/lib/(?:[^/]+/)?perl5/$;
and $dirname ne 'usr/share/perl5/') {
tag 'package-contains-empty-directory', $dirname;
}
}
}
}
if (!$has_binary_perl_file && @nonbinary_perl_files_in_lib) {
foreach my $file (@nonbinary_perl_files_in_lib) {
tag 'package-installs-nonbinary-perl-in-usr-lib-perl5', $file;
}
}
# Check for .devhelp2? files that aren't symlinked into paths searched by
# devhelp.
for my $file (@devhelp) {
my $found = 0;
for my $link (@devhelp_links) {
if ($file =~ m,^\Q$link,) {
$found = 1;
last;
}
}
tag 'package-contains-devhelp-file-without-symlink', $file
unless $found;
}
# Check for including multiple different DPIs of fonts in the same X11 bitmap
# font package.
if ($x11_font_dirs{'100dpi'} and $x11_font_dirs{'75dpi'}) {
tag 'package-contains-multiple-dpi-fonts';
}
if ($x11_font_dirs{misc} and keys(%x11_font_dirs) > 1) {
tag 'package-mixes-misc-and-dpi-fonts';
}
tag 'multiarch-foreign-shared-library'
if $arch ne 'all'
and $multiarch eq 'foreign'
and $has_public_shared_library
and not $has_public_executable;
return;
}
sub dir_counts {
my ($info, $filename) = @_;
if (my $file = $info->index($filename)) {
return scalar($file->children);
}
return 0;
}
sub is_localhost {
my ($urlshort) = @_;
if( $urlshort =~ m!^(?:[^/]+@)?localhost(?:[:][^/]+)?/!i
|| $urlshort =~ m!^(?:[^/]+@)?::1(?:[:][^/]+)?/!i
|| $urlshort =~ m!^(?:[^/]+@)?127(?:\.\d{1,3}){3}(?:[:][^/]+)?/!i) {
return 1;
}else {
return 0;
}
}
sub _check_tag_url_privacy_breach {
my ($fulltag, $tagattr, $url,$privacybreachhash, $file) = @_;
my $website = $url;
# detect also "^//" trick
$website =~ s,^"?(?:(?:ht|f)tps?:)?//,,;
$website =~ s/"?$//;
if (is_localhost($website)){
# do nothing ok
return;
}
# reparse fulltag for rel
if ($tagattr eq 'link') {
my $rel = $fulltag;
$rel =~ m,<link
(?:\s[^>]+)? \s+
rel="([^"\r\n]*)"
[^>]*
>,xismog;
my $relcontent = $1;
if (defined($relcontent)) {
# See, for example, https://www.w3schools.com/tags/att_link_rel.asp
my %allowed = (
'alternate' => 1, # #891301
'author' => 1, # #891301
'bookmark' => 1, # #746656
'canonical' => 1, # #762753
'generator' => 1, # #891301
'generator-home' => 1, # texinfo
'help' => 1, # #891301
'license' => 1, # #891301
'next' => 1, # #891301
'prev' => 1, # #891301
'schema.dct' => 1, # #736992
'search' => 1, # #891301
);
return if ($allowed{$relcontent});
if ($relcontent eq 'alternate') {
my $type = $fulltag;
$type =~ m,<link
(?:\s[^>]+)? \s+
type="([^"\r\n]*)"
[^>]*
>,xismog;
my $typecontent = $1;
if($typecontent eq 'application/rdf+xml') {
# see #79991
return;
}
}
}
}
# False positive
# legal.xml file of gnome
# could be replaced by a link to local file but not really a privacy breach
if( $file->basename eq 'legal.xml'
&& $tagattr eq 'link'
&& $website =~ m{^creativecommons.org/licenses/}) {
return;
}
# In Mallard XML, <link> is a clickable anchor that will not be
# followed automatically.
if( $file->basename =~ '.xml$'
&& $tagattr eq 'link'
&& $file->file_contents
=~ qr{ xmlns="http://projectmallard\.org/1\.0/"}) {
return;
}
# track well known site
foreach my $breaker ($PRIVACY_BREAKER_WEBSITES->all) {
my $value = $PRIVACY_BREAKER_WEBSITES->value($breaker);
my $regex = $value->{'regexp'};
if ($website =~ m{$regex}mxs) {
unless (exists $privacybreachhash->{'tag-'.$breaker}) {
my $tag = $value->{'tag'};
my $suggest = $value->{'suggest'} // '';
$privacybreachhash->{'tag-'.$breaker}= 1;
tag $tag, $file, $suggest, "($url)";
}
# do not go to generic case
return;
}
}
# generic case
unless (exists $privacybreachhash->{'tag-generic-'.$website}){
tag 'privacy-breach-generic', $file, "[$fulltag] ($url)";
$privacybreachhash->{'tag-generic-'.$website} = 1;
}
return;
}
# According to html norm src attribute is used by tags:
#
# audio(v5+), embed (v5+), iframe (v4), frame, img, input, script, source, track(v5), video (v5)
# Add other tags with src due to some javascript code:
# div due to div.js
# div data-href due to jquery
# css with @import
sub detect_generic_privacy_breach {
my ($block, $privacybreachhash, $file) = @_;
my %matchedkeyword;
# now check generic tag
TYPE:
foreach my $type ($PRIVACY_BREAKER_TAG_ATTR->all) {
my $keyvalue = $PRIVACY_BREAKER_TAG_ATTR->value($type);
my $keywords = $keyvalue->{'keywords'};
my $orblockok = 0;
ORBLOCK:
foreach my $keywordor (@$keywords) {
ANDBLOCK:
foreach my $keyword (@$keywordor) {
my $thiskeyword = $matchedkeyword{$keyword};
if(!defined($thiskeyword)) {
if(index($block,$keyword) > -1) {
$matchedkeyword{$keyword} = 1;
$orblockok = 1;
}else {
$matchedkeyword{$keyword} = 0;
$orblockok = 0;
next ORBLOCK;
}
}
if($matchedkeyword{$keyword} == 0) {
$orblockok = 0;
next ORBLOCK;
}else {
$orblockok = 1;
}
}
if($orblockok == 1) {
last ORBLOCK;
}
}
if($orblockok == 0) {
next TYPE;
}
my $regex = $keyvalue->{'regex'};
while($block=~m{$regex}g){
_check_tag_url_privacy_breach($1, $2, $3,$privacybreachhash,$file);
}
}
return;
}
sub detect_privacy_breach {
my ($file) = @_;
my %privacybreachhash;
# detect only in regular file
unless($file->is_regular_file) {
return;
}
my $fd = $file->open(':raw');
my $sfd = Lintian::SlidingWindow->new($fd,sub { $_=lc($_); },BLOCKSIZE);
while (my $block = $sfd->readwindow) {
# Strip comments
for my $x (qw(<!--.*?--\s*> /\*.*?\*/)) {
$block =~ s@$x@@gs;
}
# try generic fragment tagging
foreach my $keyword ($PRIVACY_BREAKER_FRAGMENTS->all) {
if(index($block,$keyword) > -1) {
my $keyvalue = $PRIVACY_BREAKER_FRAGMENTS->value($keyword);
my $regex = $keyvalue->{'regex'};
if ($block =~ m{($regex)}) {
my $capture = $1;
my $breaker_tag = $keyvalue->{'tag'};
unless (exists $privacybreachhash{'tag-'.$breaker_tag}){
$privacybreachhash{'tag-'.$breaker_tag} = 1;
tag $breaker_tag, $file, "(choke on: $capture)";
}
}
}
}
for my $x (
qw(src="http src="ftp src="// data-href="http data-href="ftp
data-href="// codebase="http codebase="ftp codebase="// data="http
data="ftp data="// poster="http poster="ftp poster="// <link @import)
) {
next if index($block, $x) == -1;
detect_generic_privacy_breach($block,\%privacybreachhash,$file);
last;
}
}
close($fd);
return;
}
1;
# Local Variables:
# indent-tabs-mode: nil
# cperl-indent-level: 4
# End:
# vim: syntax=perl sw=4 sts=4 sr et
|