vcs.maemo.org Git - maemian/blob - nokia-lintian/lib/Lintian/Collect/Binary.pm

   1 # -*- perl -*-
   2 # Lintian::Collect::Binary -- interface to binary package data collection
   3
   4 # Copyright (C) 2008 Russ Allbery
   5 # Copyright (C) 2008 Frank Lichtenheld
   6 #
   7 # This program is free software; you can redistribute it and/or modify it
   8 # under the terms of the GNU General Public License as published by the Free
   9 # Software Foundation; either version 2 of the License, or (at your option)
  10 # any later version.
  11 #
  12 # This program is distributed in the hope that it will be useful, but WITHOUT
  13 # ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  14 # FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License for
  15 # more details.
  16 #
  17 # You should have received a copy of the GNU General Public License along with
  18 # this program.  If not, see <http://www.gnu.org/licenses/>.
  19
  20 package Lintian::Collect::Binary;
  21 use strict;
  22
  23 use Lintian::Collect;
  24 use Util;
  25
  26 our @ISA = qw(Lintian::Collect);
  27
  28 # Initialize a new binary package collect object.  Takes the package name,
  29 # which is currently unused.
  30 sub new {
  31     my ($class, $pkg) = @_;
  32     my $self = {};
  33     bless($self, $class);
  34     return $self;
  35 }
  36
  37 # Returns whether the package is a native package according to
  38 # its version number
  39 sub native {
  40     my ($self) = @_;
  41     return $self->{native} if exists $self->{native};
  42     my $version = $self->field('version');
  43     $self->{native} = ($version !~ m/-/);
  44 }
  45
  46 # Returns the information from the indices
  47 # FIXME: should maybe return an object
  48 sub index {
  49     my ($self) = @_;
  50     return $self->{index} if exists $self->{index};
  51
  52     my (@idx, %dir_counts);
  53     open my $idx, '<', "index"
  54         or fail("cannot open index file index: $!");
  55     open my $num_idx, '<', "index-owner-id"
  56         or fail("cannot open index file index-owner-id: $!");
  57     while (<$idx>) {
  58         chomp;
  59
  60         my (%file, $perm, $owner, $name);
  61         ($perm,$owner,$file{size},$file{date},$file{time},$name) =
  62             split(' ', $_, 6);
  63         $file{operm} = perm2oct($perm);
  64         $file{type} = substr $perm, 0, 1;
  65
  66         my $numeric = <$num_idx>;
  67         chomp $numeric;
  68         fail("cannot read index file index-owner-id") unless defined $numeric;
  69         my ($owner_id, $name_chk) = (split(' ', $numeric, 6))[1, 5];
  70         fail("mismatching contents of index files: $name $name_chk")
  71             if $name ne $name_chk;
  72
  73         ($file{owner}, $file{group}) = split '/', $owner, 2;
  74         ($file{uid}, $file{gid}) = split '/', $owner_id, 2;
  75
  76         $name =~ s,^\./,,;
  77         if ($name =~ s/ link to (.*)//) {
  78             $file{type} = 'h';
  79             $file{link} = $1;
  80             $file{link} =~ s,^\./,,;
  81         } elsif ($file{type} eq 'l') {
  82             ($name, $file{link}) = split ' -> ', $name, 2;
  83         }
  84         $file{name} = $name;
  85
  86         # count directory contents:
  87         $dir_counts{$name} ||= 0 if $file{type} eq 'd';
  88         $dir_counts{$1} = ($dir_counts{$1} || 0) + 1
  89             if $name =~ m,^(.+/)[^/]+/?$,;
  90
  91         push @idx, \%file;
  92     }
  93     foreach my $file (@idx) {
  94         if ($dir_counts{$file->{name}}) {
  95             $file->{count} = $dir_counts{$file->{name}};
  96         }
  97     }
  98     $self->{index} = \@idx;
  99
 100     return $self->{index};
 101 }
 102
 103 # Returns the information from collect/file-info
 104 sub file_info {
 105     my ($self) = @_;
 106     return $self->{file_info} if exists $self->{file_info};
 107
 108     my %file_info;
 109     open(my $idx, '<', "file-info")
 110         or fail("cannot open file-info: $!");
 111     while (<$idx>) {
 112         chomp;
 113
 114         m/^(.+?):\s+(.*)$/o
 115             or fail("an error in the file pkg is preventing lintian from checking this package: $_");
 116         my ($file, $info) = ($1,$2);
 117
 118         $file =~ s,^./,,o;
 119         $file =~ s,/+$,,o;
 120
 121         $file_info{$file} = $info;
 122     }
 123     close $idx;
 124     $self->{file_info} = \%file_info;
 125
 126     return $self->{file_info};
 127 }
 128
 129 # Returns the information from collect/objdump-info
 130 sub objdump_info {
 131     my ($self) = @_;
 132     return $self->{objdump_info} if exists $self->{objdump_info};
 133
 134     my %objdump_info;
 135     my ($dynsyms, $file);
 136     open(my $idx, '<', "objdump-info")
 137         or fail("cannot open objdump-info: $!");
 138     while (<$idx>) {
 139         chomp;
 140
 141         next if m/^\s*$/o;
 142
 143         if (m,^-- \./(\S+)\s*$,o) {
 144             if ($file) {
 145                 $objdump_info{$file->{name}} = $file;
 146             }
 147             $file = { name => $1 };
 148             $dynsyms = 0;
 149         } elsif ($dynsyms) {
 150             # The .*? near the end is added because a number of optional fields
 151             # might be printed.  The symbol name should be the last word.
 152             if (m/^[0-9a-fA-F]+.{6}\w\w?\s+(\S+)\s+[0-9a-zA-Z]+\s+(\S+)\s+(\S+)$/){
 153                 my ($foo, $sec, $sym) = ($1, $2, $3);
 154                 push @{$file->{SYMBOLS}}, [ $foo, $sec, $sym ];
 155             }
 156         } else {
 157             if (m/^\s*NEEDED\s*(\S+)/o) {
 158                 push @{$file->{NEEDED}}, $1;
 159             } elsif (m/^\s*RPATH\s*(\S+)/o) {
 160                 foreach (split m/:/, $1) {
 161                     $file->{RPATH}{$_}++;
 162                 }
 163             } elsif (m/^\s*SONAME\s*(\S+)/o) {
 164                 push @{$file->{SONAME}}, $1;
 165             } elsif (m/^\s*\d+\s+\.comment\s+/o) {
 166                 $file->{COMMENT_SECTION} = 1;
 167             } elsif (m/^\s*\d+\s+\.note\s+/o) {
 168                 $file->{NOTE_SECTION} = 1;
 169             } elsif (m/^DYNAMIC SYMBOL TABLE:/) {
 170                 $dynsyms = 1;
 171             } elsif (m/^objdump: (.*?): File format not recognized$/) {
 172                 push @{$file->{NOTES}}, "File format not recognized";
 173             } elsif (m/^objdump: \.(.*?): Packed with UPX$/) {
 174                 push @{$file->{NOTES}}, "Packed with UPX";
 175             } elsif (m/objdump: \.(.*?): Invalid operation$/) {
 176                 # Don't anchor this regex since it can be interspersed with other
 177                 # output and hence not on the beginning of a line.
 178                 push @{$file->{NOTES}}, "Invalid operation";
 179             } elsif (m/CXXABI/) {
 180                 $file->{CXXABI} = 1;
 181             } elsif (m%Requesting program interpreter:\s+/lib/klibc-\S+\.so%) {
 182                 $file->{KLIBC} = 1;
 183             }
 184         }
 185     }
 186     if ($file) {
 187         $objdump_info{$file->{name}} = $file;
 188     }
 189     $self->{objdump_info} = \%objdump_info;
 190
 191     return $self->{objdump_info};
 192 }
 193
 194 =head1 NAME
 195
 196 Lintian::Collect::Binary - Lintian interface to binary package data collection
 197
 198 =head1 SYNOPSIS
 199
 200     my $collect = Lintian::Collect->new($name, $type);
 201     if ($collect->native) {
 202         print "Package is native\n";
 203     }
 204
 205 =head1 DESCRIPTION
 206
 207 Lintian::Collect::Binary provides an interface to package data for binary
 208 packages.  It implements data collection methods specific to binary
 209 packages.
 210
 211 This module is in its infancy.  Most of Lintian still reads all data from
 212 files in the laboratory whenever that data is needed and generates that
 213 data via collect scripts.  The goal is to eventually access all data about
 214 source packages via this module so that the module can cache data where
 215 appropriate and possibly retire collect scripts in favor of caching that
 216 data in memory.
 217
 218 =head1 CLASS METHODS
 219
 220 =item new(PACKAGE)
 221
 222 Creates a new Lintian::Collect::Binary object.  Currently, PACKAGE is
 223 ignored.  Normally, this method should not be called directly, only via
 224 the Lintian::Collect constructor.
 225
 226 =back
 227
 228 =head1 INSTANCE METHODS
 229
 230 In addition to the instance methods listed below, all instance methods
 231 documented in the Lintian::Collect module are also available.
 232
 233 =over 4
 234
 235 =item native()
 236
 237 Returns true if the binary package is native and false otherwise.
 238 Nativeness will be judged by its version number.
 239
 240 =item index()
 241
 242 Returns a reference to an array of hash references with content
 243 information about the binary package.  Each hash may have the
 244 following keys:
 245
 246 =over 4
 247
 248 =item name
 249
 250 Name of the index entry without leading slash.
 251
 252 =item owner
 253
 254 =item group
 255
 256 =item uid
 257
 258 =item gid
 259
 260 The former two are in string form and may depend on the local system,
 261 the latter two are the original numerical values as saved by tar.
 262
 263 =item date
 264
 265 Format "YYYY-MM-DD".
 266
 267 =item time
 268
 269 Format "hh:mm".
 270
 271 =item type
 272
 273 Entry type as one character.
 274
 275 =item operm
 276
 277 Entry permissions as octal number.
 278
 279 =item size
 280
 281 Entry size in bytes.  Note that tar(1) lists the size of directories as
 282 0 (so this is what you will get) contrary to what ls(1) does.
 283
 284 =item link
 285
 286 If the entry is either a hardlink or symlink, contains the target of the
 287 link.
 288
 289 =item count
 290
 291 If the entry is a directory, contains the number of other entries this
 292 directory contains.
 293
 294 =back
 295
 296 =head1 AUTHOR
 297
 298 Originally written by Frank Lichtenheld <djpig@debian.org> for Lintian.
 299
 300 =head1 SEE ALSO
 301
 302 lintian(1), Lintian::Collect(3)
 303
 304 =cut
 305
 306 1;
 307
 308 # Local Variables:
 309 # indent-tabs-mode: nil
 310 # cperl-indent-level: 4
 311 # End:
 312 # vim: syntax=perl sw=4 sts=4 ts=4 et shiftround