vcs.maemo.org Git - maemian/blob - lib/Maemian/Collect/Binary.pm

   1 # Maemian::Collect::Binary -- interface to binary package data collection
   2
   3 # Copyright (C) 2008, 2009 Russ Allbery
   4 # Copyright (C) 2008 Frank Lichtenheld
   5 #
   6 # This program is free software; you can redistribute it and/or modify it
   7 # under the terms of the GNU General Public License as published by the Free
   8 # Software Foundation; either version 2 of the License, or (at your option)
   9 # any later version.
  10 #
  11 # This program is distributed in the hope that it will be useful, but WITHOUT
  12 # ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  13 # FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License for
  14 # more details.
  15 #
  16 # You should have received a copy of the GNU General Public License along with
  17 # this program.  If not, see <http://www.gnu.org/licenses/>.
  18
  19 package Maemian::Collect::Binary;
  20
  21 use strict;
  22 use warnings;
  23 use base 'Maemian::Collect';
  24
  25 use Maemian::Relation;
  26 use Carp qw(croak);
  27 use Parse::DebianChangelog;
  28
  29 use Util;
  30
  31 # Initialize a new binary package collect object.  Takes the package name,
  32 # which is currently unused.
  33 sub new {
  34     my ($class, $pkg) = @_;
  35     my $self = {};
  36     bless($self, $class);
  37     return $self;
  38 }
  39
  40 # Returns whether the package is a native package according to
  41 # its version number
  42 # sub native Needs-Info <>
  43 sub native {
  44     my ($self) = @_;
  45     return $self->{native} if exists $self->{native};
  46     my $version = $self->field('version');
  47     $self->{native} = ($version !~ m/-/);
  48     return $self->{native};
  49 }
  50
  51 # Get the changelog file of a binary package as a Parse::DebianChangelog
  52 # object.  Returns undef if the changelog file couldn't be found.
  53 sub changelog {
  54     my ($self) = @_;
  55     return $self->{changelog} if exists $self->{changelog};
  56     # sub changelog Needs-Info changelog-file
  57     if (-l 'changelog' || ! -f 'changelog') {
  58         $self->{changelog} = undef;
  59     } else {
  60         my %opts = (infile => 'changelog', quiet => 1);
  61         $self->{changelog} = Parse::DebianChangelog->init(\%opts);
  62     }
  63     return $self->{changelog};
  64 }
  65
  66 # Returns the information from the indices
  67 # FIXME: should maybe return an object
  68 # sub index Needs-Info <>
  69 sub index {
  70     my ($self) = @_;
  71     return $self->{index} if exists $self->{index};
  72
  73     my (%idx, %dir_counts);
  74     open my $idx, '<', "index"
  75         or fail("cannot open index file index: $!");
  76     open my $num_idx, '<', "index-owner-id"
  77         or fail("cannot open index file index-owner-id: $!");
  78     while (<$idx>) {
  79         chomp;
  80
  81         my (%file, $perm, $owner, $name);
  82         ($perm,$owner,$file{size},$file{date},$file{time},$name) =
  83             split(' ', $_, 6);
  84         $file{operm} = perm2oct($perm);
  85         $file{type} = substr $perm, 0, 1;
  86
  87         my $numeric = <$num_idx>;
  88         chomp $numeric;
  89         fail("cannot read index file index-owner-id") unless defined $numeric;
  90         my ($owner_id, $name_chk) = (split(' ', $numeric, 6))[1, 5];
  91         fail("mismatching contents of index files: $name $name_chk")
  92             if $name ne $name_chk;
  93
  94         ($file{owner}, $file{group}) = split '/', $owner, 2;
  95         ($file{uid}, $file{gid}) = split '/', $owner_id, 2;
  96
  97         $name =~ s,^\./,,;
  98         if ($name =~ s/ link to (.*)//) {
  99             $file{type} = 'h';
 100             $file{link} = $1;
 101             $file{link} =~ s,^\./,,;
 102         } elsif ($file{type} eq 'l') {
 103             ($name, $file{link}) = split ' -> ', $name, 2;
 104         }
 105         $file{name} = $name;
 106
 107         # count directory contents:
 108         $dir_counts{$name} ||= 0 if $file{type} eq 'd';
 109         $dir_counts{$1} = ($dir_counts{$1} || 0) + 1
 110             if $name =~ m,^(.+/)[^/]+/?$,;
 111
 112         $idx{$name} = \%file;
 113     }
 114     foreach my $file (keys %idx) {
 115         if ($dir_counts{$idx{$file}->{name}}) {
 116             $idx{$file}->{count} = $dir_counts{$idx{$file}->{name}};
 117         }
 118     }
 119     $self->{index} = \%idx;
 120
 121     return $self->{index};
 122 }
 123
 124 # Returns the information from collect/file-info
 125 sub file_info {
 126     my ($self) = @_;
 127     return $self->{file_info} if exists $self->{file_info};
 128
 129     my %file_info;
 130     # sub file_info Needs-Info file-info
 131     open(my $idx, '<', "file-info")
 132         or fail("cannot open file-info: $!");
 133     while (<$idx>) {
 134         chomp;
 135
 136         m/^(.+?):\s+(.*)$/o
 137             or fail("an error in the file pkg is preventing lintian from checking this package: $_");
 138         my ($file, $info) = ($1,$2);
 139
 140         $file =~ s,^\./,,o;
 141         $file =~ s,/+$,,o;
 142
 143         $file_info{$file} = $info;
 144     }
 145     close $idx;
 146     $self->{file_info} = \%file_info;
 147
 148     return $self->{file_info};
 149 }
 150
 151 sub scripts {
 152     my ($self) = @_;
 153     return $self->{scripts} if exists $self->{scripts};
 154
 155     my %scripts;
 156     # sub scripts Needs-Info scripts
 157     open(SCRIPTS, '<', "scripts")
 158         or fail("cannot open scripts file: $!");
 159     while (<SCRIPTS>) {
 160         chomp;
 161         my (%file, $name);
 162
 163         m/^(env )?(\S*) (.*)$/o
 164             or fail("bad line in scripts file: $_");
 165         ($file{calls_env}, $file{interpreter}, $name) = ($1, $2, $3);
 166
 167         $name =~ s,^\./,,o;
 168         $name =~ s,/+$,,o;
 169         $file{name} = $name;
 170         $scripts{$name} = \%file;
 171     }
 172     close SCRIPTS;
 173     $self->{scripts} = \%scripts;
 174
 175     return $self->{scripts};
 176 }
 177
 178
 179 # Returns the information from collect/objdump-info
 180 sub objdump_info {
 181     my ($self) = @_;
 182     return $self->{objdump_info} if exists $self->{objdump_info};
 183
 184     my %objdump_info;
 185     my ($dynsyms, $file);
 186     # sub objdump_info Needs-Info objdump-info
 187     open(my $idx, '<', "objdump-info")
 188         or fail("cannot open objdump-info: $!");
 189     while (<$idx>) {
 190         chomp;
 191
 192         next if m/^\s*$/o;
 193
 194         if (m,^-- \./(\S+)\s*$,o) {
 195             if ($file) {
 196                 $objdump_info{$file->{name}} = $file;
 197             }
 198             $file = { name => $1 };
 199             $dynsyms = 0;
 200         } elsif ($dynsyms) {
 201             # The .*? near the end is added because a number of optional fields
 202             # might be printed.  The symbol name should be the last word.
 203             if (m/^[0-9a-fA-F]+.{6}\w\w?\s+(\S+)\s+[0-9a-zA-Z]+\s+(\S+)\s+(\S+)$/){
 204                 my ($foo, $sec, $sym) = ($1, $2, $3);
 205                 push @{$file->{SYMBOLS}}, [ $foo, $sec, $sym ];
 206
 207                 if ($foo eq '.text' and $sec eq 'Base' and $sym eq 'caml_main') {
 208                     $file->{OCAML} = 1;
 209                 }
 210             }
 211         } else {
 212             if (m/^\s*NEEDED\s*(\S+)/o) {
 213                 push @{$file->{NEEDED}}, $1;
 214             } elsif (m/^\s*RPATH\s*(\S+)/o) {
 215                 foreach (split m/:/, $1) {
 216                     $file->{RPATH}{$_}++;
 217                 }
 218             } elsif (m/^\s*SONAME\s*(\S+)/o) {
 219                 push @{$file->{SONAME}}, $1;
 220             } elsif (m/^\s*\d+\s+\.comment\s+/o) {
 221                 $file->{COMMENT_SECTION} = 1;
 222             } elsif (m/^\s*\d+\s+\.note\s+/o) {
 223                 $file->{NOTE_SECTION} = 1;
 224             } elsif (m/^DYNAMIC SYMBOL TABLE:/) {
 225                 $dynsyms = 1;
 226             } elsif (m/^objdump: (.*?): File format not recognized$/) {
 227                 push @{$file->{NOTES}}, "File format not recognized";
 228             } elsif (m/^objdump: (.*?): File truncated$/) {
 229                 push @{$file->{NOTES}}, "File truncated";
 230             } elsif (m/^objdump: \.(.*?): Packed with UPX$/) {
 231                 push @{$file->{NOTES}}, "Packed with UPX";
 232             } elsif (m/objdump: \.(.*?): Invalid operation$/) {
 233                 # Don't anchor this regex since it can be interspersed with other
 234                 # output and hence not on the beginning of a line.
 235                 push @{$file->{NOTES}}, "Invalid operation";
 236             } elsif (m/CXXABI/) {
 237                 $file->{CXXABI} = 1;
 238             } elsif (m%Requesting program interpreter:\s+/lib/klibc-\S+\.so%) {
 239                 $file->{KLIBC} = 1;
 240             } elsif (m/^\s*TEXTREL\s/o) {
 241                 $file->{TEXTREL} = 1;
 242             } elsif (m/^\s*INTERP\s/) {
 243                 $file->{INTERP} = 1;
 244             } elsif (m/^\s*STACK\s/) {
 245                 $file->{STACK} = 0;
 246             } else {
 247                 if (defined $file->{STACK} and $file->{STACK} eq 0) {
 248                     m/\sflags\s+(\S+)/o;
 249                     $file->{STACK} = $1;
 250                 } else {
 251                     $file->{OTHER_DATA} = 1;
 252                 }
 253             }
 254         }
 255     }
 256     if ($file) {
 257         $objdump_info{$file->{name}} = $file;
 258     }
 259     $self->{objdump_info} = \%objdump_info;
 260
 261     return $self->{objdump_info};
 262 }
 263
 264 # Return a Maemian::Relation object for the given relationship field.  In
 265 # addition to all the normal relationship fields, the following special
 266 # field names are supported: all (pre-depends, depends, recommends, and
 267 # suggests), strong (pre-depends and depends), and weak (recommends and
 268 # suggests).
 269 # sub relation Needs-Info <>
 270 sub relation {
 271     my ($self, $field) = @_;
 272     $field = lc $field;
 273     return $self->{relation}->{$field} if exists $self->{relation}->{$field};
 274
 275     my %special = (all    => [ qw(pre-depends depends recommends suggests) ],
 276                    strong => [ qw(pre-depends depends) ],
 277                    weak   => [ qw(recommends suggests) ]);
 278     my $result;
 279     if ($special{$field}) {
 280         my $merged;
 281         for my $f (@{ $special{$field} }) {
 282             my $value = $self->field($f);
 283             $merged .= ', ' if (defined($merged) and defined($value));
 284             $merged .= $value if defined($value);
 285         }
 286         $result = $merged;
 287     } else {
 288         my %known = map { $_ => 1 }
 289             qw(pre-depends depends recommends suggests enhances breaks
 290                conflicts provides replaces);
 291         croak("unknown relation field $field") unless $known{$field};
 292         my $value = $self->field($field);
 293         $result = $value if defined($value);
 294     }
 295     $self->{relation}->{$field} = Maemian::Relation->new($result);
 296     return $self->{relation}->{$field};
 297 }
 298
 299 =head1 NAME
 300
 301 Maemian::Collect::Binary - Maemian interface to binary package data collection
 302
 303 =head1 SYNOPSIS
 304
 305     my ($name, $type) = ('foobar', 'binary');
 306     my $collect = Maemian::Collect->new($name, $type);
 307     if ($collect->native) {
 308         print "Package is native\n";
 309     }
 310
 311 =head1 DESCRIPTION
 312
 313 Maemian::Collect::Binary provides an interface to package data for binary
 314 packages.  It implements data collection methods specific to binary
 315 packages.
 316
 317 This module is in its infancy.  Most of Maemian still reads all data from
 318 files in the laboratory whenever that data is needed and generates that
 319 data via collect scripts.  The goal is to eventually access all data about
 320 source packages via this module so that the module can cache data where
 321 appropriate and possibly retire collect scripts in favor of caching that
 322 data in memory.
 323
 324 =head1 CLASS METHODS
 325
 326 =over 4
 327
 328 =item new(PACKAGE)
 329
 330 Creates a new Maemian::Collect::Binary object.  Currently, PACKAGE is
 331 ignored.  Normally, this method should not be called directly, only via
 332 the Maemian::Collect constructor.
 333
 334 =back
 335
 336 =head1 INSTANCE METHODS
 337
 338 In addition to the instance methods listed below, all instance methods
 339 documented in the Maemian::Collect module are also available.
 340
 341 =over 4
 342
 343 =item changelog()
 344
 345 Returns the changelog of the binary package as a Parse::DebianChangelog
 346 object, or undef if the changelog doesn't exist.  The changelog-file
 347 collection script must have been run to create the changelog file, which
 348 this method expects to find in F<changelog>.
 349
 350 =item native()
 351
 352 Returns true if the binary package is native and false otherwise.
 353 Nativeness will be judged by its version number.
 354
 355 =item index()
 356
 357 Returns a reference to an array of hash references with content
 358 information about the binary package.  Each hash may have the
 359 following keys:
 360
 361 =over 4
 362
 363 =item name
 364
 365 Name of the index entry without leading slash.
 366
 367 =item owner
 368
 369 =item group
 370
 371 =item uid
 372
 373 =item gid
 374
 375 The former two are in string form and may depend on the local system,
 376 the latter two are the original numerical values as saved by tar.
 377
 378 =item date
 379
 380 Format "YYYY-MM-DD".
 381
 382 =item time
 383
 384 Format "hh:mm".
 385
 386 =item type
 387
 388 Entry type as one character.
 389
 390 =item operm
 391
 392 Entry permissions as octal number.
 393
 394 =item size
 395
 396 Entry size in bytes.  Note that tar(1) lists the size of directories as
 397 0 (so this is what you will get) contrary to what ls(1) does.
 398
 399 =item link
 400
 401 If the entry is either a hardlink or symlink, contains the target of the
 402 link.
 403
 404 =item count
 405
 406 If the entry is a directory, contains the number of other entries this
 407 directory contains.
 408
 409 =back
 410
 411 =item relation(FIELD)
 412
 413 Returns a Maemian::Relation object for the specified FIELD, which should
 414 be one of the possible relationship fields of a Debian package or one of
 415 the following special values:
 416
 417 =over 4
 418
 419 =item all
 420
 421 The concatenation of Pre-Depends, Depends, Recommends, and Suggests.
 422
 423 =item strong
 424
 425 The concatenation of Pre-Depends and Depends.
 426
 427 =item weak
 428
 429 The concatenation of Recommends and Suggests.
 430
 431 =back
 432
 433 If FIELD isn't present in the package, the returned Maemian::Relation
 434 object will be empty (always satisfied and implies nothing).
 435
 436 =back
 437
 438 =head1 AUTHOR
 439
 440 Originally written by Frank Lichtenheld <djpig@debian.org> for Maemian.
 441
 442 =head1 SEE ALSO
 443
 444 lintian(1), Maemian::Collect(3), Maemian::Relation(3)
 445
 446 =cut
 447
 448 1;
 449
 450 # Local Variables:
 451 # indent-tabs-mode: nil
 452 # cperl-indent-level: 4
 453 # End:
 454 # vim: syntax=perl sw=4 sts=4 ts=4 et shiftround