vcs.maemo.org Git - maemian/blob - checks/files

   1 # files -- lintian check script -*- perl -*-
   2
   3 # Copyright (C) 1998 Christian Schwarz and Richard Braakman
   4 #
   5 # This program is free software; you can redistribute it and/or modify
   6 # it under the terms of the GNU General Public License as published by
   7 # the Free Software Foundation; either version 2 of the License, or
   8 # (at your option) any later version.
   9 #
  10 # This program is distributed in the hope that it will be useful,
  11 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13 # GNU General Public License for more details.
  14 #
  15 # You should have received a copy of the GNU General Public License
  16 # along with this program.  If not, you can find it on the World Wide
  17 # Web at http://www.gnu.org/copyleft/gpl.html, or write to the Free
  18 # Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
  19 # MA 02110-1301, USA.
  20
  21 package Maemian::files;
  22 use strict;
  23 use Tags;
  24 use Util;
  25 use Maemian::Data;
  26
  27 our $FONT_PACKAGES;
  28
  29 # A list of known packaged Javascript libraries
  30 # and the packages providing them
  31 our @jslibraries = (
  32     [ qr,(?i)mochikit\.js(\.gz)?$, => qr'libjs-mochikit' ],
  33     [ qr,(?i)jquery(\.(min|lite|pack))?\.js(\.gz)?$, => qr'libjs-jquery' ],
  34     [ qr,(?i)prototype(-[\d\.]+)?\.js(\.gz)?$, => qr'libjs-prototype' ],
  35     [ qr,(?i)scriptaculous\.js(\.gz)?$, => qr'libjs-scriptaculous' ],
  36     [ qr,(?i)fckeditor\.js(\.gz)?$, => qr'fckeditor' ],
  37     [ qr,(?i)cropper(\.uncompressed)?\.js(\.gz)?$, => qr'libjs-cropper' ],
  38     [ qr,(?i)swfobject\.js(\.gz)?$, => qr'libjs-yui' ],
  39     [ qr,(?i)(yahoo|yui)-(dom-event|min)\.js(\.gz)?$, => qr'libjs-yui' ],
  40 # Disabled due to false positives.  Needs a content check adding to verify
  41 # that the file being checked is /the/ yahoo.js
  42 #    [ qr,(?i)yahoo\.js(\.gz)?$, => qr'libjs-yui' ],
  43     [ qr,(?i)jsjac(\.packed)?\.js(\.gz)?$, => qr'libjs-jac' ],
  44     [ qr,(?i)jsMath(-fallback-\w+)?\.js(\.gz)?$, => qr'jsmath' ],
  45     [ qr,(?i)tiny_mce(_(popup|src))?\.js(\.gz)?$, => qr'tinymce2?' ],
  46 # not yet available in unstable:
  47 #    [ qr,(?i)(htmlarea|Xinha(Loader|Core))\.js$, => qr'xinha' ],
  48 );
  49
  50 # A list of known packaged PEAR modules
  51 # and the packages providing them
  52 our @pearmodules = (
  53     [ qr,(?<!Auth/)HTTP\.php$, => 'php-http' ],
  54     [ qr,Auth\.php$, => 'php-auth' ],
  55     [ qr,Auth/HTTP\.php$, => 'php-auth-http' ],
  56     [ qr,Benchmark/(Timer|Profiler|Iterate)\.php$, => 'php-benchmark' ],
  57     [ qr,Cache\.php$, => 'php-cache' ],
  58     [ qr,Cache/Lite\.php$, => 'php-cache-lite' ],
  59     [ qr,Compat\.php$, => 'php-compat' ],
  60     [ qr,Config\.php$, => 'php-config' ],
  61     [ qr,CBC\.php$, => 'php-crypt-cbc' ],
  62     [ qr,Date\.php$, => 'php-date' ],
  63     [ qr,(?<!Container)/DB\.php$, => 'php-db' ],
  64     [ qr,(?<!Container)/File\.php$, => 'php-file' ],
  65     [ qr,Log\.php$, => 'php-log' ],
  66     [ qr,Log/(file|error_log|null|syslog|sql\w*)\.php$, => 'php-log' ],
  67     [ qr,Mail\.php$, => 'php-mail' ],
  68     [ qr,(?i)mime(Part)?\.php$, => 'php-mail-mime' ],
  69     [ qr,mimeDecode\.php$, => 'php-mail-mimedecode' ],
  70     [ qr,FTP\.php$, => 'php-net-ftp' ],
  71     [ qr,(?<!Container/)IMAP\.php$, => 'php-net-imap' ],
  72     [ qr,SMTP\.php$, => 'php-net-smtp' ],
  73     [ qr,(?<!FTP/)Socket\.php$, => 'php-net-socket' ],
  74     [ qr,IPv4\.php$, => 'php-net-ipv4' ],
  75     [ qr,(?<!Container/)LDAP\.php$, => 'php-net-ldap' ],
  76 );
  77
  78 # A list of known packaged php (!PEAR) libraries
  79 # and the packages providing them
  80 our @phplibraries = (
  81     [ qr,(?i)adodb\.inc\.php$, => 'libphp-adodb' ],
  82     [ qr,(?i)Smarty(_Compiler)?\.class\.php$, => 'smarty' ],
  83     [ qr,(?i)class\.phpmailer(\.(php|inc))+$, => 'libphp-phpmailer' ],
  84     [ qr,(?i)phpsysinfo\.dtd$, => 'phpsysinfo' ],
  85     [ qr,(?i)class\.(Linux|(Open|Net|Free|)BSD)\.inc\.php$, => 'phpsysinfo' ],
  86     [ qr,Auth/(OpenID|Yadis/Yadis)\.php$, => 'php-openid' ],
  87     [ qr,(?i)Snoopy\.class\.(php|inc)$, => 'libphp-snoopy' ],
  88     [ qr,(?i)markdown\.php$, => 'libmarkdown-php' ],
  89     [ qr,(?i)geshi\.php$, => 'php-geshi' ],
  90     [ qr,(?i)(class[.-])?pclzip\.(inc|lib)?\.php$, => 'libphp-pclzip' ],
  91     [ qr,(?i).*layersmenu.*/(lib/)?PHPLIB\.php$, => 'libphp-phplayersmenu' ],
  92     [ qr,(?i)phpSniff\.(class|core)\.php$, => 'libphp-phpsniff' ],
  93     [ qr,(?i)(class\.)?jabber\.php$, => 'libphp-jabber' ],
  94     [ qr,(?i)simplepie(\.(php|inc))+$, => 'libphp-simplepie' ],
  95     [ qr,(?i)jpgraph\.php$, => 'libphp-jpgraph' ],
  96     [ qr,(?i)fpdf\.php$, => 'php-fpdf' ],
  97     [ qr,(?i)getid3\.(lib\.)?(\.(php|inc))+$, => 'php-getid3' ],
  98     [ qr,(?i)streams\.php$, => 'php-gettext' ],
  99     [ qr,(?i)rss_parse\.(php|inc)$, => 'libphp-magpierss' ],
 100     [ qr,(?i)unit_tester\.php$, => 'php-simpletest' ],
 101     [ qr,(?i)Sparkline\.php$, => 'libsparkline-php' ],
 102 # not yet available in unstable:,
 103 #    [ qr,(?i)IXR_Library(\.inc|\.php)+$, => 'libphp-ixr' ],
 104 #    [ qr,(?i)(class\.)?kses\.php$, => 'libphp-kses' ],
 105 );
 106
 107 # A list of known non-free flash executables
 108 our @flash_nonfree = (
 109     qr<(?i)dewplayer(?:-\w+)?\.swf$>,
 110     qr<(?i)(?:mp3|flv)player\.swf$>,
 111 # Situation needs to be clarified:
 112 #    qr,(?i)multipleUpload\.swf$,
 113 #    qr,(?i)xspf_jukebox\.swf$,
 114 );
 115
 116 sub run {
 117
 118 my $pkg = shift;
 119 my $type = shift;
 120 my $info = shift;
 121
 122 my $file;
 123 my $source_pkg = "";
 124 my $pkg_section = "";
 125 my $is_python;
 126 my $is_perl;
 127 my $has_binary_perl_file;
 128 my @nonbinary_perl_files_in_lib;
 129
 130 my %linked_against_libvga;
 131
 132 # read data from objdump-info file
 133 foreach my $file (sort keys %{$info->objdump_info}) {
 134     my $objdump = $info->objdump_info->{$file};
 135     $file = './' . $file;
 136
 137     if (defined $objdump->{NEEDED}) {
 138         my $lib = $objdump->{NEEDED};
 139         $linked_against_libvga{$file} = 1
 140             if $lib =~ m/libvga/;
 141     }
 142 }
 143
 144 # Get source package name, if possible.
 145 if (defined $info->field('source')) {
 146     $source_pkg = $info->field('source') || "";
 147 }
 148
 149 # Get section.
 150 if (defined $info->field('section')) {
 151    $pkg_section = $info->field('section');
 152 }
 153
 154 # find out which files are scripts
 155 my %script = map {$_ => 1} (sort keys %{$info->scripts});
 156
 157 # We only want to warn about these once.
 158 my $warned_x11_predepends = 0;
 159 my $warned_debug_name = 0;
 160
 161 my @devhelp;
 162 my @devhelp_links;
 163
 164 # Read package contents...
 165 foreach my $file (sort keys %{$info->index}) {
 166     next if $file eq "";
 167     my $index_info = $info->index->{$file};
 168     my $owner = $index_info->{owner} . '/' . $index_info->{group};
 169     my $operm = $index_info->{operm};
 170     my $link = $index_info->{link};
 171     if ($index_info->{type} eq 'h') {
 172         my $link_target_dir = $link;
 173         $link_target_dir =~ s,[^/]*$,,;
 174
 175         # It may look weird to sort the file and link target here, but since
 176         # it's a hard link, both files are equal and either could be
 177         # legitimately reported first.  tar will generate different tar files
 178         # depending on the hashing of the directory, and this sort produces
 179         # stable lintian output despite that.
 180         #
 181         # TODO: actually, policy says 'conffile', not '/etc' -> extend!
 182         tag "package-contains-hardlink", join (' -> ', sort ($file, $link))
 183             if $file =~ m,^etc/,
 184                 or $link =~ m,^etc/,
 185                 or $file !~ m,^\Q$link_target_dir\E[^/]*$,;
 186     }
 187
 188     my ($year) = ($index_info->{date} =~ /^(\d{4})/);
 189     if ( $year <= 1984 ) { # value from dak CVS: Dinstall::PastCutOffYear
 190         tag "package-contains-ancient-file", "$file " . $index_info->{date};
 191     }
 192
 193     if (!($index_info->{uid} < 100 || $index_info->{uid} == 65534
 194           || ($index_info->{uid} >= 60000 && $index_info->{uid} < 65000))
 195         || !($index_info->{gid} < 100 || $index_info->{gid} == 65534
 196              || ($index_info->{gid} >= 60000 && $index_info->{gid} < 65000))) {
 197         tag "wrong-file-owner-uid-or-gid", $file, $index_info->{uid} . '/' . $index_info->{gid};
 198     }
 199
 200     # *.devhelp and *.devhelp2 files must be accessible from a directory in
 201     # the devhelp search path: /usr/share/devhelp/books and
 202     # /usr/share/gtk-doc/html.  We therefore look for any links in one of
 203     # those directories to another directory.  The presence of such a link
 204     # blesses any file below that other directory.
 205     if (defined $link and $file =~ m,usr/share/(?:devhelp/books|gtk-doc/html)/,) {
 206         my $blessed = $link;
 207         if ($blessed !~ m,^/,) {
 208             my $base = $file;
 209             $base =~ s,/+[^/]+$,,;
 210             while ($blessed =~ s,^\.\./,,) {
 211                 $base =~ s,/+[^/]+$,,;
 212             }
 213             $blessed = "$base/$blessed";
 214         }
 215         push (@devhelp_links, $blessed);
 216     }
 217
 218     # ---------------- /etc
 219     if ($file =~ m,^etc/,) {
 220         if ($file =~ m,^etc/nntpserver, ) {
 221             tag "package-uses-obsolete-file", "$file";
 222         }
 223         # ---------------- /etc/cron.daily, etc.
 224         elsif ($file =~ m,^etc/cron\.(?:daily|hourly|monthly|weekly)/[^\.].*\., ) {
 225             tag "run-parts-cron-filename-contains-full-stop", "$file";
 226         }
 227         # ---------------- /etc/cron.d
 228         elsif ($file =~ m,^etc/cron\.d/\S, and $operm != 0644) {
 229             tag "bad-permissions-for-etc-cron.d-script", sprintf("$file %04o != 0644",$operm);
 230         }
 231         # ---------------- /etc/emacs.*
 232         elsif ($file =~ m,^etc/emacs.*/\S, and $index_info->{type} =~ m,^[-h],
 233                and $operm != 0644) {
 234             tag "bad-permissions-for-etc-emacs-script", sprintf("$file %04o != 0644",$operm);
 235         }
 236         # ---------------- /etc/gconf/schemas
 237         elsif ($file =~ m,^etc/gconf/schemas/\S,) {
 238             tag "package-installs-into-etc-gconf-schemas", "$file";
 239         }
 240         # ---------------- /etc/init.d
 241         elsif ($file =~ m,^etc/init\.d/\S,
 242                and $file !~ m,^etc/init\.d/(?:README|skeleton)$,
 243                and $operm != 0755
 244                and $index_info->{type} =~ m,^[-h],) {
 245             tag "non-standard-file-permissions-for-etc-init.d-script",
 246                 sprintf("$file %04o != 0755",$operm);
 247         }
 248         #----------------- /etc/pam.conf
 249         elsif ($file =~ m,^etc/pam.conf, and $pkg ne "libpam-runtime" ) {
 250             tag "config-file-reserved", "$file by libpam-runtime";
 251         }
 252         # ---------------- /etc/rc.d
 253         elsif ($type ne 'udeb' and $file =~ m,^etc/rc\.d/\S, and $pkg !~ /^(?:sysvinit|file-rc)$/) {
 254             tag "package-installs-into-etc-rc.d", "$file";
 255         }
 256         # ---------------- /etc/rc?.d
 257         elsif ($type ne 'udeb' and $file =~ m,^etc/rc(?:\d|S)\.d/\S, and $pkg !~ /^(?:sysvinit|file-rc)$/) {
 258             tag "package-installs-into-etc-rc.d", "$file";
 259         }
 260         # ---------------- /etc/rc.boot
 261         elsif ($file =~ m,^etc/rc\.boot/\S,) {
 262             tag "package-installs-into-etc-rc.boot", "$file";
 263         }
 264     }
 265     # ---------------- /usr
 266     elsif ($file =~ m,^usr/,) {
 267         # ---------------- /usr/share/doc
 268         if ($file =~ m,^usr/share/doc/\S,) {
 269             if ($type eq 'udeb') {
 270                 tag "udeb-contains-documentation-file", "$file";
 271             } else {
 272                 # file not owned by root?
 273                 if ($owner ne 'root/root') {
 274                     tag "bad-owner-for-doc-file", "$file $owner != root/root";
 275                 }
 276
 277                 # file directly in /usr/share/doc ?
 278                 if ($index_info->{type} =~ m/^[-h]/ and $file =~ m,^usr/share/doc/[^/]+$,) {
 279                     tag "file-directly-in-usr-share-doc", "$file";
 280                 }
 281
 282                 # executable in /usr/share/doc ?
 283                 if ($index_info->{type} =~ m/^[-h]/ and
 284                     $file !~ m,^usr/share/doc/(?:[^/]+/)?examples/, and
 285                     ($operm & 01 or $operm & 010 or $operm & 0100)) {
 286                     if ($script{$file}) {
 287                         tag "script-in-usr-share-doc", "$file";
 288                     } else {
 289                         tag "executable-in-usr-share-doc", $file, (sprintf "%04o", $operm);
 290                     }
 291                 }
 292
 293                 # zero byte file in /usr/share/doc/
 294                 if ($index_info->{size} == 0 and $index_info->{type} =~ m,^-,) {
 295                     # Exceptions: examples may contain empty files for various
 296                     # reasons, Doxygen generates empty *.map files, and Python
 297                     # uses __init__.py to mark module directories.
 298                     unless ($file =~ m,^usr/share/doc/(?:[^/]+/)?examples/,
 299                             or $file =~ m,^usr/share/doc/(?:.+/)?html/.*\.map$,
 300                             or $file =~ m,^usr/share/doc/(?:.+/)?__init__\.py$,) {
 301                         tag "zero-byte-file-in-doc-directory", "$file";
 302                     }
 303                 }
 304                 # gzipped zero byte files:
 305                 # 276 is 255 bytes (maximal length for a filename) + gzip overhead
 306                 if ($file =~ m,.gz$, and $index_info->{size} <= 276
 307                     and $index_info->{type} =~ m,^[-h],
 308                     and $info->file_info->{$file} =~ m/gzip compressed/) {
 309                     unless (`gzip -dc unpacked/$file`) {
 310                         tag "zero-byte-file-in-doc-directory", "$file";
 311                     }
 312                 }
 313
 314                 # contains an INSTALL file?
 315                 my $tmp = quotemeta($pkg);
 316                 if ($file =~ m,^usr/share/doc/$tmp/INSTALL(?:\..+)*$,) {
 317                     tag "package-contains-upstream-install-documentation", "$file";
 318                 }
 319
 320                 # contains a README for another distribution/platform?
 321                 if ($file =~ m,^usr/share/doc/$tmp/readme\.(?:apple|aix|atari|be|beos|bsd|bsdi|
 322                                 cygwin|darwin|irix|gentoo|freebsd|mac|macos|macosx|netbsd|
 323                                 openbsd|osf|redhat|sco|sgi|solaris|suse|sun|vms|win32|win9x|
 324                                 windows)(?:\.txt)?(?:\.gz)?$,xi){
 325                     tag "package-contains-readme-for-other-platform-or-distro", "$file";
 326                 }
 327             }
 328         }
 329         # ---------------- /usr/doc
 330         elsif ($file =~ m,^usr/doc/\S,) {
 331             if ($file =~ m,^usr/doc/examples/\S+, and $index_info->{type} eq 'd') {
 332                 tag "old-style-example-dir", "$file";
 333             }
 334         }
 335         # ---------------- /usr/X11R6/lib/X11/app-defaults
 336         elsif ($file =~ m,usr/X11R6/lib/X11/app-defaults,) {
 337             tag "old-app-defaults-directory", "$file";
 338         }
 339
 340         #----------------- /usr/{include,lib}/X11/
 341         # Packages installing files here will need to pre-depend on x11-common
 342         # so that the symlinks will be sorted out first on a sarge upgrade.
 343         elsif ($file =~ m,^usr/(?:include|lib)/X11(/|\Z),
 344                && !$warned_x11_predepends && $pkg ne 'x11-common') {
 345             tag "file-in-usr-something-x11-without-pre-depends", "$file"
 346                 unless $info->relation('pre-depends')->implies('x11-common (>= 1:7.0.0)');
 347
 348             # Always set this so that we don't redo the check, even if we
 349             # didn't warn.  If the first instance didn't warn, none will.
 350             $warned_x11_predepends = 1;
 351         }
 352
 353         #----------------- /usr/X11R6/
 354         elsif ($file =~ m,^usr/X11R6/bin, && $pkg ne 'x11-common') {
 355             tag "package-installs-file-to-usr-x11r6-bin", "$file";
 356         }
 357         elsif ($file =~ m,^usr/X11R6/lib/X11/fonts,) {
 358             tag "package-installs-font-to-usr-x11r6", "$file";
 359         }
 360         elsif ($file =~ m,^usr/X11R6/, and
 361                $index_info->{type} !~ m,^l,) { #links to FHS locations are allowed
 362             tag "package-installs-file-to-usr-x11r6", "$file";
 363         }
 364
 365         # ---------------- /usr/lib/debug
 366         elsif ($file =~ m,^usr/lib/debug/\S,) {
 367             unless ($warned_debug_name) {
 368                 tag "debug-package-should-be-named-dbg", "$file"
 369                     unless ($pkg =~ /-dbg$/);
 370                 $warned_debug_name = 1;
 371             }
 372         }
 373
 374         # ---------------- /usr/lib/sgml
 375         elsif ($file =~ m,^usr/lib/sgml/\S,) {
 376             tag "file-in-usr-lib-sgml", $file;
 377         }
 378         # ---------------- perllocal.pod
 379         elsif ($file =~ m,^usr/lib/perl.*/perllocal.pod$,) {
 380             tag "package-installs-perllocal-pod", "$file";
 381         }
 382         # ---------------- .packlist files
 383         elsif ($file =~ m,^usr/lib/perl.*/.packlist$,) {
 384             tag "package-installs-packlist", "$file";
 385         }
 386         elsif ($file =~ m,^usr/lib/perl5/.*\.(?:pl|pm)$,) {
 387             push @nonbinary_perl_files_in_lib, $file;
 388         }
 389         elsif ($file =~ m,^usr/lib/perl5/.*\.(?:bs|so)$,) {
 390             $has_binary_perl_file = 1;
 391         }
 392         # ---------------- /usr/lib -- needs to go after the other usr/lib/*
 393         elsif ($file =~ m,^usr/lib/,) {
 394             if ($type ne 'udeb' and $file =~ m,\.(?:gif|jpeg|jpg|png|tiff|xpm|xbm)$, and not defined $link) {
 395                 tag "image-file-in-usr-lib", "$file"
 396             }
 397         }
 398         # ---------------- /usr/local
 399         elsif ($file =~ m,^usr/local/\S+,) {
 400             if ($index_info->{type} =~ m/^d/) {
 401                 tag "dir-in-usr-local", "$file";
 402             } else {
 403                 tag "file-in-usr-local", "$file";
 404             }
 405         }
 406         # ---------------- /usr/share/man and /usr/X11R6/man
 407         elsif ($file =~ m,^usr/X11R6/man/\S+, or $file =~ m,^usr/share/man/\S+,) {
 408             if ($type eq 'udeb') {
 409                 tag "documentation-file", "$file";
 410             }
 411             if ($index_info->{type} =~ m/^d/) {
 412                 tag "stray-directory-in-manpage-directory", "$file"
 413                     if ($file !~ m,^usr/(?:X11R6|share)/man/(?:[^/]+/)?(?:man\d/)?$,);
 414             } elsif ($index_info->{type} =~ m,^[-h], and
 415                 ($operm & 01 or $operm & 010 or $operm & 0100)) {
 416                 tag "executable-manpage", "$file";
 417             }
 418         }
 419         # ---------------- /usr/share/info
 420         elsif ($file =~ m,^usr/share/info\S+,) {
 421             if ($type eq 'udeb') {
 422                 tag "documentation-file", "$file";
 423             }
 424         }
 425         # ---------------- /usr/share/linda/overrides
 426         elsif ($file =~ m,^usr/share/linda/overrides/\S+,) {
 427             tag "package-contains-linda-override", $file;
 428         }
 429         # ---------------- /usr/share
 430         elsif ($file =~ m,^usr/share/[^/]+$,) {
 431             if ($index_info->{type} =~ m/^[-h]/) {
 432                 tag "file-directly-in-usr-share", "$file";
 433             }
 434         }
 435         # ---------------- /usr/bin
 436         elsif ($file =~ m,^usr/bin/,) {
 437             if ($index_info->{type} =~ m/^d/ and $file =~ m,^usr/bin/., and $file !~ m,^usr/bin/(?:X11|mh)/,) {
 438                 tag "subdir-in-usr-bin", "$file";
 439             }
 440         }
 441         # ---------------- /usr subdirs
 442         elsif ($type ne 'udeb' and $file =~ m,^usr/[^/]+/$,) { # FSSTND dirs
 443             if ( $file =~ m,^usr/(?:dict|doc|etc|info|man|adm|preserve)/,) {
 444                 tag "FSSTND-dir-in-usr", "$file";
 445             }
 446             # FHS dirs
 447             elsif ($file !~ m,^usr/(?:X11R6|X386|
 448                                     bin|games|include|
 449                                     lib|lib32|lib64|
 450                                     local|sbin|share|
 451                                     src|spool|tmp)/,x) {
 452                 tag "non-standard-dir-in-usr", "$file";
 453             } elsif ($file =~ m,^usr/share/doc,) {
 454                 tag "uses-FHS-doc-dir", "$file";
 455             }
 456
 457             # unless $file =~ m,^usr/[^/]+-linuxlibc1/,; was tied into print
 458             # above...
 459             # Make an exception for the altdev dirs, which will go away
 460             # at some point and are not worth moving.
 461         }
 462         # ---------------- .desktop files
 463         # People have placed them everywhere, but nowadays the consensus seems
 464         # to be to stick to the fd.org standard drafts, which says that
 465         # .desktop files intended for menus should be placed in
 466         # $XDG_DATA_DIRS/applications.  The default for $XDG_DATA_DIRS is
 467         # /usr/local/share/:/usr/share/, according to the basedir-spec on
 468         # fd.org. As distributor, we should only allow /usr/share.
 469         #
 470         # KDE hasn't moved its files from /usr/share/applnk, so don't warn
 471         # about this yet until KDE adopts the new location.
 472         elsif ($file =~ m,^usr/share/gnome/apps/.*\.desktop$,) {
 473             tag "desktop-file-in-wrong-dir", $file;
 474         }
 475
 476         # ---------------- png files under /usr/share/apps/*/icons/*
 477         elsif ($file =~ m,^usr/share/apps/[^/]+/icons/[^/]+/(\d+x\d+)/.*\.png$,) {
 478             my ($dsize, $fsize) = ($1);
 479             $info->file_info->{$file} =~ m/,\s*(\d+)\s*x\s*(\d+)\s*,/;
 480             $fsize = $1.'x'.$2;
 481             tag 'icon-size-and-directory-name-mismatch', $file, $fsize
 482                 unless ($dsize eq $fsize);
 483         }
 484     }
 485     # ---------------- /var subdirs
 486     elsif ($type ne 'udeb' and $file =~ m,^var/[^/]+/$,) { # FSSTND dirs
 487         if ( $file =~ m,^var/(?:adm|catman|named|nis|preserve)/, ) {
 488             tag "FSSTND-dir-in-var", "$file";
 489         }
 490         # FHS dirs with exception in Debian policy
 491         elsif ( $file !~ m,^var/(?:account|lib|cache|crash|games|lock|log|opt|run|spool|state|tmp|www|yp)/,) {
 492             tag "non-standard-dir-in-var", "$file";
 493         }
 494     }
 495     elsif ($type ne 'udeb' and $file =~ m,^var/lib/games/.,) {
 496         tag "non-standard-dir-in-var", "$file";
 497     }
 498     # ---------------- /var/lock, /var/run
 499     elsif ($file =~ m,^var/lock/.,) {
 500         tag "dir-or-file-in-var-lock", "$file";
 501     }
 502     elsif ($file =~ m,^var/run/.,) {
 503         tag "dir-or-file-in-var-run", "$file";
 504     }
 505     # ---------------- /var/www
 506     # Packages are allowed to create /var/www since it's historically been the
 507     # default document root, but they shouldn't be installing stuff under that
 508     # directory.
 509     elsif ($file =~ m,^var/www/\S+,) {
 510         tag "dir-or-file-in-var-www", $file;
 511     }
 512     # ---------------- /opt
 513     elsif ($file =~ m,^opt/.,) {
 514         tag "dir-or-file-in-opt", "$file";
 515     }
 516     elsif ($file =~ m,^hurd/.,) {
 517         next;
 518     } elsif ($file =~ m,^server/.,) {
 519         next;
 520     }
 521     # ---------------- /tmp, /var/tmp, /usr/tmp
 522     elsif ($file =~ m,^tmp/., or $file =~ m,^(?:var|usr)/tmp/.,) {
 523         tag "dir-or-file-in-tmp", "$file";
 524     }
 525     # ---------------- /mnt
 526     elsif ($file =~ m,^mnt/.,) {
 527         tag "dir-or-file-in-mnt", "$file";
 528     }
 529     # ---------------- /bin
 530     elsif ($file =~ m,^bin/,) {
 531         if ($index_info->{type} =~ m/^d/ and $file =~ m,^bin/.,) {
 532             tag "subdir-in-bin", "$file";
 533         }
 534     }
 535     # ---------------- /srv
 536     elsif ($file =~ m,^srv/.,) {
 537         tag "dir-or-file-in-srv", "$file";
 538     }
 539     # ---------------- FHS directory?
 540     elsif ($file =~ m,^[^/]+/$, and $file ne './' and
 541            $file !~ m,^(?:bin|boot|dev|etc|home|lib(?:64|32)?|mnt|opt|root|sbin|srv|tmp|usr|var)/,) {
 542         # Make an exception for the base-files package here and other similar
 543         # packages because they install a slew of top-level directories for
 544         # setting up the base system.  (Specifically, /cdrom, /floppy,
 545         # /initrd, and /proc are not mentioned in the FHS).
 546         #
 547         # Also make an exception for /emul, which is used for multiarch
 548         # support in Debian at the moment.
 549         tag "non-standard-toplevel-dir", "$file"
 550             unless $pkg eq 'base-files'
 551                 or $pkg eq 'hurd'
 552                 or $pkg =~ /^rootskel(?:-bootfloppy)?/
 553                 or $file =~ m,^emul/,;
 554     }
 555
 556     # ---------------- compatibility symlinks should not be used
 557     if ($file =~ m,^usr/(?:spool|tmp)/, or
 558         $file =~ m,^usr/(?:doc|bin)/X11/, or
 559         $file =~ m,^var/adm/,) {
 560         tag "use-of-compat-symlink", "$file";
 561     }
 562
 563     # ---------------- .ali files (Ada Library Information)
 564     if ($file =~ m,^usr/lib/.*\.ali$, && $operm != 0444) {
 565         tag "bad-permissions-for-ali-file", "$file";
 566     }
 567
 568     # ---------------- any files
 569     if ($index_info->{type} !~ m/^d/) {
 570         unless ($type eq 'udeb'
 571                 or $file =~ m,^usr/(?:bin|dict|doc|games|
 572                                     include|info|lib(?:32|64)?|
 573                                     man|sbin|share|src|X11R6)/,x
 574                 or $file =~ m,^lib(?:32|64)?/(?:modules/|libc5-compat/)?,
 575                 or $file =~ m,^var/(?:games|lib|www|named)/,
 576                 or $file =~ m,^(?:bin|boot|dev|etc|sbin)/,
 577                 # non-FHS, but still usual
 578                 or $file =~ m,^usr/[^/]+-linux[^/]*/,
 579                 or $file =~ m,^usr/iraf/,
 580                 or $file =~ m,^emul/ia32-linux/(?:lib|usr/lib)/,
 581                 # not allowed, but tested indivudually
 582                 or $file =~ m,^(?:mnt|opt|srv|(?:(?:usr|var)/)?tmp)|var/www/,) {
 583             tag "file-in-unusual-dir", "$file";
 584         }
 585     }
 586
 587     # ---------------- .pyc (compiled python files
 588     if ($file =~ m,^usr/lib/python\d\.\d/.*.pyc$,) {
 589         tag "package-installs-python-pyc", "$file"
 590     }
 591
 592     # ---------------- /usr/lib/site-python
 593     if ($file =~ m,^usr/lib/site-python/\S,) {
 594         tag "file-in-usr-lib-site-python", "$file";
 595     }
 596
 597     # ---------------- pythonX.Y extensions
 598     if ($file =~ m,^usr/lib/python\d\.\d/\S,
 599         and not $file =~ m,^usr/lib/python\d\.\d/site-packages/,) {
 600         # check if it's one of the Python proper packages
 601         unless (defined $is_python) {
 602             $is_python = 0;
 603             if (defined $info->field('source')) {
 604                 local $_ = $info->field('source');
 605                 $is_python = 1 if /^python(?:\d\.\d)?(?:$|\s)/;
 606             }
 607         }
 608         tag "third-party-package-in-python-dir", "$file"
 609             unless $is_python;
 610     }
 611     # ---------------- perl modules
 612     if ($file =~ m,^usr/(?:share|lib)/perl/\S,) {
 613        # check if it's the "perl" package itself
 614        unless (defined $is_perl) {
 615            $is_perl = 0;
 616            if (defined $info->field('source')) {
 617                local $_ = $info->field('source');;
 618                $is_perl = 1 if /^perl(?:$|\s)/;
 619            }
 620        }
 621        tag "perl-module-in-core-directory", "$file"
 622            unless $is_perl;
 623     }
 624
 625     # ---------------- license files
 626     if ($file =~ m,(?:copying|licen[cs]e)(?:\.[^/]+)?$,i
 627         # Ignore some common extensions; there was at least one file named
 628         # "license.el".  These are probably license-displaying code, not
 629         # license files.  Also ignore binaries in /usr/bin and friends.
 630         #
 631         # Another exception is made for .html and .php because preserving
 632         # working links is more important than saving some bytes, and
 633         # because a package had a HTML form for licenses called like that.
 634         # Another exception is made for various picture formats since
 635         # those are likely to just be simply pictures.
 636         #
 637         # DTD files are excluded at the request of the Mozilla suite
 638         # maintainers.  Zope products include license files for runtime
 639         # display.  underXXXlicense.docbook files are from KDE.
 640         #
 641         # Ignore extra license files in examples, since various package
 642         # building software includes example packages with licenses.
 643         and not $file =~ m/\.(?:el|c|h|py|cc|pl|pm|html|php|rb|xpm|png|jpe?g|gif|svg|dtd)$/
 644         and not $file =~ m,^usr/share/zope/Products/.*\.(?:dtml|pt|cpt)$,
 645         and not $file =~ m,/under\S+License\.docbook$,
 646         and not $file =~ m,^(?:usr/)?s?bin/,
 647         and not $file =~ m,^usr/share/doc/[^/]+/examples/,
 648         and not defined $link) {
 649         tag "extra-license-file", "$file";
 650     }
 651
 652     # ---------------- .devhelp2? files
 653     if ($file =~ m,\.devhelp2?(?:\.gz)?$,
 654         # If the file is located in a directory not searched by devhelp, we
 655         # check later to see if it's in a symlinked directory.
 656         and not $file =~ m,^usr/share/(?:devhelp/books|gtk-doc/html)/,
 657         and not $file =~ m,^usr/share/doc/[^/]+/examples/,) {
 658         push (@devhelp, $file);
 659     }
 660
 661     # ---------------- weird file names
 662     if ($file =~ m,\s+\z,) {
 663         tag "file-name-ends-in-whitespace", "$file";
 664     }
 665
 666     # ---------------- misplaced lintian overrides
 667     my $tmp = quotemeta($pkg);
 668     if ($file =~ m,^usr/share/doc/$tmp/override\.[lL]intian(?:\.gz)?$, or
 669         $file =~ m,^usr/share/lintian/overrides/$tmp/.+,) {
 670         tag "override-file-in-wrong-location", "$file";
 671     }
 672
 673     # ---------------- plain files
 674     if ($index_info->{type} =~ m/^[-h]/) {
 675         my $wanted_operm;
 676         # ---------------- backup files and autosave files
 677         if ($file =~ /~$/ or $file =~ m,\#[^/]+\#$, or $file =~ m,/\.[^/]+\.swp$,) {
 678             tag "backup-file-in-package", "$file";
 679         }
 680         if ($file =~ m,/\.nfs[^/]+$,) {
 681             tag "nfs-temporary-file-in-package", "$file";
 682         }
 683
 684         # ---------------- vcs control files
 685         if ($file =~ m/\.(?:(?:cvs|git|hg)ignore|arch-inventory|hgtags|hg_archival\.txt)$/) {
 686             tag "package-contains-vcs-control-file", "$file";
 687         }
 688
 689         # ---------------- subversion and svk commit message backups
 690         if ($file =~ m/svn-commit.*\.tmp$/) {
 691             tag "svn-commit-file-in-package", "$file";
 692         }
 693         if ($file =~ m/svk-commit.+\.tmp$/) {
 694             tag "svk-commit-file-in-package", "$file";
 695         }
 696
 697         # ---------------- executables with language extensions
 698         if ($file =~ m,^(?:usr/)?(?:s?bin|games)/[^/]+\.(?:pl|sh|py|php|rb|tcl|bsh|csh|tcl)$,) {
 699             tag "script-with-language-extension", "$file";
 700         }
 701
 702         # ---------------- Devel files for Windows
 703         if ($file =~ m,/.+\.(?:vcproj|sln|dsp|dsw)(?:\.gz)?$,
 704             and $file !~ m,^usr/share/doc/,) {
 705             tag "windows-devel-file-in-package", "$file";
 706         }
 707
 708         # ---------------- Autogenerated databases from other OSes
 709         if ($file =~ m,/Thumbs\.db(?:\.gz)?$,i) {
 710             tag "windows-thumbnail-database-in-package", "$file";
 711         }
 712         if ($file =~ m,/\.DS_Store(?:\.gz)?$,) {
 713             tag "macos-ds-store-file-in-package", "$file";
 714         }
 715         if ($file =~ m,/\._[^_/][^/]*$, and $file !~ m/\.swp$/) {
 716             tag "macos-resource-fork-file-in-package", "$file";
 717         }
 718
 719         # ---------------- embedded Javascript libraries
 720         foreach my $jslibrary (@jslibraries) {
 721             if ($file =~ m,/$jslibrary->[0], and $pkg !~ m,^$jslibrary->[1]$,) {
 722                 tag "embedded-javascript-library", "$file";
 723             }
 724         }
 725
 726         # ---------------- embedded Feedparser library
 727         if ($file =~ m,/feedparser\.py$, and $pkg ne "python-feedparser") {
 728             open(FEEDPARSER, "unpacked/$file") or fail("cannot open feedparser.py file: $!");
 729             while (<FEEDPARSER>) {
 730                 if (m,Universal feed parser,) {
 731                     tag "embedded-feedparser-library", "$file";
 732                     last;
 733                 }
 734             }
 735             close(FEEDPARSER);
 736         }
 737
 738         # ---------------- embedded PEAR modules
 739         foreach my $pearmodule (@pearmodules) {
 740             if ($file =~ m,/$pearmodule->[0], and $pkg ne $pearmodule->[1]) {
 741                 open (PEAR, "unpacked/$file") or fail("cannot open PHP file: $!");
 742                 while (<PEAR>) {
 743                     if (m,/pear[/.],i) {
 744                         tag "embedded-pear-module", "$file";
 745                         last;
 746                     }
 747                 }
 748                 close(PEAR);
 749             }
 750         }
 751
 752         # ---------------- embedded php libraries
 753         foreach my $phplibrary (@phplibraries) {
 754             if ($file =~ m,/$phplibrary->[0], and $pkg ne $phplibrary->[1]) {
 755                 tag "embedded-php-library", "$file";
 756             }
 757         }
 758
 759         # ---------------- fonts
 760         if ($file =~ m,/([\w-]+\.(?:[to]tf|pfb|pcf))$,i) {
 761             my $font = lc $1;
 762             $FONT_PACKAGES = Maemian::Data->new('files/fonts', '\s+')
 763                 unless defined($FONT_PACKAGES);
 764             if ($FONT_PACKAGES->known($font)) {
 765                 tag 'duplicate-font-file', "$file also in", $FONT_PACKAGES->value($font)
 766                     if ($pkg ne $FONT_PACKAGES->value($font) and $type ne 'udeb');
 767             } elsif ($pkg !~ m/^[ot]tf-/) {
 768                 tag 'font-in-non-font-package', $file;
 769             }
 770         }
 771
 772         # ---------------- non-free .swf files
 773         foreach my $flash (@flash_nonfree) {
 774             last if ($pkg_section =~ m,^non-free/,);
 775             if ($file =~ m,/$flash,) {
 776                 tag "non-free-flash", $file;
 777             }
 778         }
 779
 780         # ---------------- .gz files
 781         if ($file =~ m/\.gz$/) {
 782             my $info = $info->file_info->{$file} || '';
 783             if ($info !~ m/gzip compressed/) {
 784                 tag "gz-file-not-gzip", "$file";
 785             }
 786         }
 787
 788         # ---------------- general: setuid/setgid files!
 789         if ($operm & 04000 or $operm & 02000) {
 790             my ($setuid, $setgid) = ("","");
 791             # get more info:
 792             $setuid = $index_info->{owner} if ($operm & 04000);
 793             $setgid = $index_info->{group} if ($operm & 02000);
 794
 795             # 1st special case: program is using svgalib:
 796             if (exists $linked_against_libvga{$file}) {
 797                 # setuid root is ok, so remove it
 798                 if ($setuid eq 'root') {
 799                     undef $setuid;
 800                 }
 801             }
 802
 803             # 2nd special case: program is a setgid game
 804             if ($file =~ m,usr/lib/games/\S+, or $file =~ m,usr/games/\S+,) {
 805                 # setgid games is ok, so remove it
 806                 if ($setgid eq 'games') {
 807                     undef $setgid;
 808                 }
 809             }
 810
 811             # 3rd special case: allow anything with suid in the name
 812             if ($pkg =~ m,-suid,) {
 813                 undef $setuid;
 814             }
 815
 816             # Check for setuid and setgid that isn't expected.
 817             if ($setuid and $setgid) {
 818                 tag "setuid-gid-binary", $file, sprintf("%04o $owner",$operm);
 819             } elsif ($setuid) {
 820                 tag "setuid-binary", $file, sprintf("%04o $owner",$operm);
 821             } elsif ($setgid) {
 822                 tag "setgid-binary", $file, sprintf("%04o $owner",$operm);
 823             }
 824
 825             # Check for permission problems other than the setuid status.
 826             if (($operm & 0444) != 0444) {
 827                 tag "executable-is-not-world-readable", $file,
 828                     sprintf("%04o",$operm);
 829             } elsif ($operm != 04755 && $operm != 02755 && $operm != 06755 && $operm != 04754) {
 830                 tag "non-standard-setuid-executable-perm", $file,
 831                     sprintf("%04o",$operm);
 832             }
 833         }
 834         # ---------------- general: executable files
 835         elsif ($operm & 01 or $operm & 010 or $operm & 0100) {
 836             # executable
 837             if ($owner =~ m,root/games,) {
 838                 if ($operm != 2755) {
 839                     tag "non-standard-game-executable-perm", $file,
 840                         sprintf("%04o != 2755",$operm);
 841                 }
 842             } else {
 843                 if (($operm & 0444) != 0444) {
 844                     tag "executable-is-not-world-readable", $file,
 845                         sprintf("%04o != 0755",$operm);
 846                 } elsif ($operm != 0755) {
 847                     tag "non-standard-executable-perm", $file,
 848                         sprintf("%04o != 0755",$operm);
 849                 }
 850             }
 851         }
 852         # ---------------- general: normal (non-executable) files
 853         else {
 854             # not executable
 855             # special case first: game data
 856             if ($operm == 0664 and $owner =~ m,root/games, and
 857                 $file =~ m,var/(lib/)?games/\S+,) {
 858                 # everything is ok
 859             } elsif ($operm == 0444 and $file =~ m,usr/lib/.*\.ali$,) {
 860                 # Ada library information files should be read-only
 861                 # since GNAT behaviour depends on that
 862                 # everything is ok
 863             } elsif ($operm == 0600 and $file =~ m,etc/backup.d/,) {
 864                 # backupninja expects configurations files to be 0600
 865             } elsif ($operm != 0644) {
 866                 tag "non-standard-file-perm", $file,
 867                     sprintf("%04o != 0644",$operm);
 868             }
 869         }
 870     }
 871     # ---------------- directories
 872     elsif ($index_info->{type} =~ m/^d/) {
 873         # special cases first:
 874         # game directory with setgid bit
 875         if ($file =~ m,var/(?:lib/)?games/\S+, and $operm == 02775
 876             and $owner =~ m,root/games,) {
 877             # do nothing, this is allowed, but not mandatory
 878         }
 879         # otherwise, complain if it's not 0755.
 880         elsif ($operm != 0755) {
 881             tag "non-standard-dir-perm", $file,
 882                 sprintf("%04o != 0755", $operm);
 883         }
 884         if ($file =~ m,/CVS/?$,) {
 885             tag "package-contains-vcs-control-dir", "$file";
 886         }
 887         if ($file =~ m,/\.(?:svn|bzr|git|hg)/?$,) {
 888             tag "package-contains-vcs-control-dir", "$file";
 889         }
 890         if (($file =~ m,/\.arch-ids/?$,)
 891             || ($file =~ m,/\{arch\}/?$,)) {
 892             tag "package-contains-vcs-control-dir", "$file";
 893         }
 894         if ($file =~ m,/\.(?:be|ditrack)/?$,) {
 895             tag "package-contains-bts-control-dir", "$file";
 896         }
 897         if ($file =~ m,/.xvpics/?$,) {
 898             tag "package-contains-xvpics-dir", "$file";
 899         }
 900         if ($file =~ m,usr/share/doc/[^/]+/examples/examples/?$,) {
 901             tag "nested-examples-directory", "$file";
 902         }
 903     }
 904     # ---------------- symbolic links
 905     elsif ($index_info->{type} =~ m/^l/) {
 906         # link
 907
 908         my $mylink = $link;
 909         if ($mylink =~ s,//+,/,g) {
 910             tag "symlink-has-double-slash", "$file $link";
 911         }
 912         if ($mylink =~ s,(.)/$,$1,) {
 913             tag "symlink-ends-with-slash", "$file $link";
 914         }
 915
 916         # determine top-level directory of file
 917         $file =~ m,^/?([^/]*),;
 918         my $filetop = $1;
 919
 920         if ($mylink =~ m,^/([^/]*),) {
 921             # absolute link, including link to /
 922
 923             # determine top-level directory of link
 924             $mylink =~ m,^/([^/]*),;
 925             my $linktop = $1;
 926
 927             if ($type ne 'udeb' and $filetop eq $linktop) {
 928                 # absolute links within one toplevel directory are _not_ ok!
 929                 tag "symlink-should-be-relative", "$file $link";
 930             }
 931
 932             # Any other case is already definitely non-recursive
 933             tag "symlink-is-self-recursive", "$file $link"
 934                 if $mylink eq '/';
 935
 936         } else {
 937             # relative link, we can assume from here that the link starts nor
 938             # ends with /
 939
 940             my @filecomponents = split('/', $file);
 941             # chop off the name of the symlink
 942             pop @filecomponents;
 943
 944             my @linkcomponents = split('/', $mylink);
 945
 946             # handle `../' at beginning of $link
 947             my $lastpop = undef;
 948             my $linkcomponent = undef;
 949             while ($linkcomponent = shift @linkcomponents) {
 950                 if ($linkcomponent eq '.') {
 951                     tag "symlink-contains-spurious-segments", "$file $link"
 952                         unless $mylink eq '.';
 953                     next;
 954                 }
 955                 last if $linkcomponent ne '..';
 956                 if (@filecomponents) {
 957                     $lastpop = pop @filecomponents;
 958                 } else {
 959                     tag "symlink-has-too-many-up-segments", "$file $link";
 960                     goto NEXT_LINK;
 961                 }
 962             }
 963
 964             if (!defined $linkcomponent) {
 965                 # After stripping all starting .. components, nothing left
 966                 tag "symlink-is-self-recursive", "$file $link";
 967             }
 968
 969             # does the link go up and then down into the same directory?
 970             # (lastpop indicates there was a backref at all, no linkcomponent
 971             # means the symlink doesn't get up anymore)
 972             if (defined $lastpop && defined $linkcomponent &&
 973                 $linkcomponent eq $lastpop) {
 974                 tag "lengthy-symlink", "$file $link";
 975             }
 976
 977             if ($#filecomponents == -1) {
 978                 # we've reached the root directory
 979                 if (($type ne 'udeb')
 980                     && (!defined $linkcomponent)
 981                     || ($filetop ne $linkcomponent)) {
 982                     # relative link into other toplevel directory.
 983                     # this hits a relative symbolic link in the root too.
 984                     tag "symlink-should-be-absolute", "$file $link";
 985                 }
 986             }
 987
 988             # check additional segments for mistakes like `foo/../bar/'
 989             foreach (@linkcomponents) {
 990                 if ($_ eq '..' || $_ eq '.') {
 991                     tag "symlink-contains-spurious-segments", "$file $link";
 992                     last;
 993                 }
 994             }
 995         }
 996     NEXT_LINK:
 997
 998         if ($link =~ m,\.(gz|z|Z|bz|bz2|tgz|zip)\s*$,) {
 999             # symlink is pointing to a compressed file
1000
1001             # symlink has correct extension?
1002             unless ($file =~ m,\.$1\s*$,) {
1003                 tag "compressed-symlink-with-wrong-ext", "$file $link";
1004             }
1005         }
1006     }
1007     # ---------------- special files
1008     else {
1009         # special file
1010         tag "special-file", $file, sprintf("%04o",$operm);
1011     }
1012 }
1013
1014 # Check for section games but nothing in /usr/games.  Check for any binary to
1015 # save ourselves from game-data false positives:
1016 my $games = dir_counts($info, "usr/games/");
1017 my $other = dir_counts($info, "bin/") + dir_counts($info, "usr/bin/");
1018 if ($pkg_section =~ m,games$, and $games == 0 and $other > 0) {
1019     tag "package-section-games-but-contains-no-game";
1020 }
1021 if ($pkg_section =~ m,games$, and $games > 0 and $other > 0) {
1022     tag "package-section-games-but-has-usr-bin";
1023 }
1024 if ($pkg_section !~ m,games$, and $games > 0 and $other == 0) {
1025     tag 'games-package-should-be-section-games';
1026 }
1027
1028 # Warn about empty directories, but ignore empty directories in /var (packages
1029 # create directories to hold dynamically created data) or /etc (configuration
1030 # files generated by maintainer scripts).  Also skip base-files, which is a
1031 # very special case.
1032 #
1033 # Empty Perl directories are an ExtUtils::MakeMaker artifact that will be
1034 # fixed in Perl 5.10, and people can cause more problems by trying to fix it,
1035 # so just ignore them.
1036 #
1037 # python-support needs a directory for each package even it might be empty
1038 foreach my $dir (sort keys %{$info->index}) {
1039     next if $dir eq "" or $info->index->{$dir}->{type} ne 'd';
1040     next if ($dir =~ m{^var/} or $dir =~ m{^etc/});
1041     next if $pkg eq 'base-files';
1042     if (dir_counts($info, $dir) == 0) {
1043         if ($dir ne 'usr/lib/perl5/'
1044             and $dir ne 'usr/share/perl5/'
1045             and $dir !~ m;^usr/share/python-support/;) {
1046             tag "package-contains-empty-directory", $dir;
1047         }
1048     }
1049 }
1050
1051 if (!$has_binary_perl_file && @nonbinary_perl_files_in_lib) {
1052     foreach my $file (@nonbinary_perl_files_in_lib) {
1053         tag "package-installs-nonbinary-perl-in-usr-lib-perl5", "$file";
1054     }
1055 }
1056
1057 # Check for .devhelp2? files that aren't symlinked into paths searched by
1058 # devhelp.
1059 for my $file (@devhelp) {
1060     my $found = 0;
1061     for my $link (@devhelp_links) {
1062         if ($file =~ m,^\Q$link,) {
1063             $found = 1;
1064             last;
1065         }
1066     }
1067     tag 'package-contains-devhelp-file-without-symlink', $file unless $found;
1068 }
1069
1070 }
1071
1072 sub dir_counts {
1073     my ($info, $dir) = @_;
1074
1075     if (defined $info->index->{$dir}) {
1076         return $info->index->{$dir}->{count} || 0;
1077     } else {
1078         return 0;
1079     }
1080 }
1081
1082 1;
1083
1084 # Local Variables:
1085 # indent-tabs-mode: t
1086 # cperl-indent-level: 4
1087 # End:
1088 # vim: syntax=perl ts=8 sw=4