/usr/share/lintian/lib/Lintian/Collect/Package.pm is in lintian 2.5.6.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 | # -*- perl -*-
# Lintian::Collect::Package -- interface to data collection for packages
# Copyright (C) 2011 Niels Thykier
#
# This program is free software; you can redistribute it and/or modify it
# under the terms of the GNU General Public License as published by the Free
# Software Foundation; either version 2 of the License, or (at your option)
# any later version.
#
# This program is distributed in the hope that it will be useful, but WITHOUT
# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
# FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
# more details.
#
# You should have received a copy of the GNU General Public License along with
# this program. If not, see <http://www.gnu.org/licenses/>.
# This handles common things for things available in source and binary packages
package Lintian::Collect::Package;
use strict;
use warnings;
use base 'Lintian::Collect';
use Carp qw(croak);
use Util qw(perm2oct);
# Returns the path to the dir where the package is unpacked
# or a file therein (see pod below)
# May croak if the package has not been unpacked.
# sub unpacked Needs-Info unpacked
sub unpacked {
my ($self, $file) = @_;
return $self->_fetch_extracted_dir('unpacked', 'unpacked', $file);
}
# Returns the information from collect/file-info
sub file_info {
my ($self) = @_;
return $self->{file_info} if exists $self->{file_info};
my $base_dir = $self->base_dir();
my %file_info;
# sub file_info Needs-Info file-info
open(my $idx, '<', "$base_dir/file-info")
or croak "cannot open $base_dir/file-info: $!";
while (<$idx>) {
chomp;
m/^(.+?)\x00\s+(.*)$/o
or croak "an error in the file pkg is preventing lintian from checking this package: $_";
my ($file, $info) = ($1,$2);
$file =~ s,^\./,,o;
$file =~ s,/+$,,o;
$file_info{$file} = $info;
}
close $idx;
$self->{file_info} = \%file_info;
return $self->{file_info};
}
# Returns the information from the indices
# FIXME: should maybe return an object
# sub index Needs-Info index
sub index {
my ($self) = @_;
return $self->_fetch_index_data('index', 'index', 'index-owner-id');
}
# Returns sorted file index (eqv to sort keys %{$info->index}), except it is cached.
# sub sorted_index Needs-Info index
sub sorted_index {
my ($self) = @_;
my $index;
my @result;
return $self->{sorted_index} if exists $self->{sorted_index};
$index = $self->index();
@result = sort keys %{$index};
$self->{sorted_index} = \@result;
return \@result;
}
# Backing method for unpacked, debfiles and others; this is not a part of the
# API.
# sub _fetch_extracted_dir Needs-Info <>
sub _fetch_extracted_dir {
my ($self, $field, $dirname, $file) = @_;
my $dir = $self->{$field};
if ( not defined $dir ) {
my $base_dir = $self->base_dir;
$dir = "$base_dir/$dirname";
croak "$field ($dirname) is not available" unless -d "$dir/";
$self->{$field} = $dir;
}
if ($file) {
# strip leading ./ - if that leaves something, return the path there
$file =~ s,^\.?/*+,,go;
return "$dir/$file" if $file;
}
return $dir;
}
# Backing method for index and others; this is not a part of the API.
# sub _fetch_index_data Needs-Info <>
sub _fetch_index_data {
my ($self, $field, $index, $indexown) = @_;
return $self->{$field} if exists $self->{$index};
my $base_dir = $self->base_dir();
my (%idxh, %dir_counts);
my $num_idx;
my %rhlinks;
open my $idx, '<', "$base_dir/$index"
or croak "cannot open index file $base_dir/$index: $!";
if ($indexown) {
open $num_idx, '<', "$base_dir/$indexown"
or croak "cannot open index file $base_dir/$indexown: $!";
}
while (<$idx>) {
chomp;
my (%file, $perm, $owner, $name);
($perm,$owner,$file{size},$file{date},$file{time},$name) =
split(' ', $_, 6);
$file{operm} = perm2oct($perm);
$file{type} = substr $perm, 0, 1;
if ($num_idx) {
# If we have a "numeric owner" index file, read that as well
my $numeric = <$num_idx>;
chomp $numeric;
croak 'cannot read index file $indexown' unless defined $numeric;
my ($owner_id, $name_chk) = (split(' ', $numeric, 6))[1, 5];
croak "mismatching contents of index files: $name $name_chk"
if $name ne $name_chk;
($file{uid}, $file{gid}) = split '/', $owner_id, 2;
}
($file{owner}, $file{group}) = split '/', $owner, 2;
$file{owner} = 'root' if $file{owner} eq '0';
$file{group} = 'root' if $file{group} eq '0';
$name =~ s,^\./,,;
if ($name =~ s/ link to (.*)//) {
my $target = $1;
$target =~ s,^\./,,;
$file{type} = 'h';
$file{link} = $target;
push @{$rhlinks{$target}}, $name;
} elsif ($file{type} eq 'l') {
($name, $file{link}) = split ' -> ', $name, 2;
}
$file{name} = $name;
# count directory contents:
$dir_counts{$name} ||= 0 if $file{type} eq 'd';
$dir_counts{$1} = ($dir_counts{$1} || 0) + 1
if $name =~ m,^(.+/)[^/]+/?$,;
$idxh{$name} = \%file;
}
foreach my $file (keys %idxh) {
my $e = $idxh{$file};
if ($dir_counts{$e->{name}}) {
$e->{count} = $dir_counts{$e->{name}};
}
if ($rhlinks{$e->{name}}) {
# There is hard link pointing to this file (or hardlink).
my %candidates = ();
my @check = ($e->{name});
my @sorted;
my $target;
while ( my $current = pop @check) {
$candidates{$current} = 1;
foreach my $rdep (@{$rhlinks{$current}}) {
# There should not be any cicles, but just in case
push @check, $rdep unless $candidates{$rdep};
}
# Remove links we are fixing
delete $rhlinks{$current};
}
# keys %candidates will be a complete list of hardlinks
# that points (in)directly to $file. Time to normalize
# the links.
#
# Sort in reverse order (allows pop instead of unshift)
@sorted = sort {$b cmp $a} keys %candidates;
# Our prefered target
$target = pop @sorted;
foreach my $link (@sorted) {
next unless exists $idxh{$target};
my $le = $idxh{$link};
# We may be "demoting" a "real file" to a "hardlink"
$le->{type} = 'h';
$le->{link} = $target;
}
if ($target ne $e->{name}) {
$idxh{$target}->{type} = '-';
# hardlinks does not have size, so copy that from the original
# entry.
$idxh{$target}->{size} = $e->{size};
delete $idxh{$target}->{link};
}
}
}
$self->{$field} = \%idxh;
close $idx;
close $num_idx if $num_idx;
return $self->{$field};
}
1;
=head1 NAME
Lintian::Collect::Package - Lintian base interface to binary and source package data collection
=head1 SYNOPSIS
my ($name, $type) = ('foobar', 'source');
my $collect = Lintian::Collect->new($name, $type);
my $file;
eval { $file = $collect->unpacked('/bin/ls'); };
if ( $file && -e $file ) {
# work with $file
;
} elsif ($file) {
print "/bin/ls is not available in the Package\n";
} else {
print "Package has not been unpacked\n";
}
=head1 DESCRIPTION
Lintian::Collect::Package provides part of an interface to package
data for source and binary packages. It implements data collection
methods specific to all packages that can be unpacked (or can contain
files)
This module is in its infancy. Most of Lintian still reads all data from
files in the laboratory whenever that data is needed and generates that
data via collect scripts. The goal is to eventually access all data about
source packages via this module so that the module can cache data where
appropriate and possibly retire collect scripts in favor of caching that
data in memory.
=head1 INSTANCE METHODS
=over 4
=item unpacked([$name])
Returns the path to the directory in which the package has been
unpacked. If C<$name> is given, it will return the path to that
specific file (or dir). The method will strip any leading "./" and
"/" from C<$name>, but it will not check if C<$name> actually exists
nor will it check for path traversals.
Caller is responsible for checking the sanity of the path passed to
unpacked and verifying that the returned path points to the expected
file.
The path returned is not guaranteed to be inside the Lintian Lab as
the package may have been unpacked outside the Lab (e.g. as
optimization).
The following code may be helpful in checking for path traversal:
use Cwd qw(realpath);
my $collect = ... ;
my $file = '../../../etc/passwd';
# Append slash to follow symlink if $collect->unpacked returns a symlink
my $uroot = realpath($collect->unpacked() . '/');
my $ufile = realpath($collect->unpacked($file));
if ($ufile =~ m,^$uroot,) {
# has not escaped $uroot
do_stuff($ufile);
} else {
# escaped $uroot
die "Possibly path traversal ($file)";
}
Alternatively one can use Util::resolve_pkg_path.
=item file_info
Returns a hashref mapping file names to the output of file for that file.
Note the file names do not have any leading "./" nor "/".
=item index
Returns a hashref to the index information (permissions, file type etc).
Note the file names do not have any leading "./" nor "/".
=item sorted_index
Returns a sorted list of all files listed in index (or file_info hashref).
It may contain an "empty" entry denoting the "root dir".
=back
=head1 AUTHOR
Originally written by Niels Thykier <niels@thykier.net> for Lintian.
=head1 SEE ALSO
lintian(1), Lintian::Collect(3), Lintian::Collect::Binary(3),
Lintian::Collect::Source(3)
=cut
# Local Variables:
# indent-tabs-mode: nil
# cperl-indent-level: 4
# End:
# vim: syntax=perl sw=4 sts=4 sr et
|