1 # Maemian::Collect::Binary -- interface to binary package data collection
3 # Copyright (C) 2008, 2009 Russ Allbery
4 # Copyright (C) 2008 Frank Lichtenheld
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)
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
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/>.
19 package Maemian::Collect::Binary;
23 use base 'Maemian::Collect';
25 use Maemian::Relation;
27 use Parse::DebianChangelog;
31 # Initialize a new binary package collect object. Takes the package name,
32 # which is currently unused.
34 my ($class, $pkg) = @_;
40 # Returns whether the package is a native package according to
42 # sub native Needs-Info <>
45 return $self->{native} if exists $self->{native};
46 my $version = $self->field('version');
47 $self->{native} = ($version !~ m/-/);
48 return $self->{native};
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.
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;
60 my %opts = (infile => 'changelog', quiet => 1);
61 $self->{changelog} = Parse::DebianChangelog->init(\%opts);
63 return $self->{changelog};
66 # Returns the information from the indices
67 # FIXME: should maybe return an object
68 # sub index Needs-Info <>
71 return $self->{index} if exists $self->{index};
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: $!");
81 my (%file, $perm, $owner, $name);
82 ($perm,$owner,$file{size},$file{date},$file{time},$name) =
84 $file{operm} = perm2oct($perm);
85 $file{type} = substr $perm, 0, 1;
87 my $numeric = <$num_idx>;
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;
94 ($file{owner}, $file{group}) = split '/', $owner, 2;
95 ($file{uid}, $file{gid}) = split '/', $owner_id, 2;
98 if ($name =~ s/ link to (.*)//) {
101 $file{link} =~ s,^\./,,;
102 } elsif ($file{type} eq 'l') {
103 ($name, $file{link}) = split ' -> ', $name, 2;
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,^(.+/)[^/]+/?$,;
112 $idx{$name} = \%file;
114 foreach my $file (keys %idx) {
115 if ($dir_counts{$idx{$file}->{name}}) {
116 $idx{$file}->{count} = $dir_counts{$idx{$file}->{name}};
119 $self->{index} = \%idx;
121 return $self->{index};
124 # Returns the information from collect/file-info
127 return $self->{file_info} if exists $self->{file_info};
130 # sub file_info Needs-Info file-info
131 open(my $idx, '<', "file-info")
132 or fail("cannot open file-info: $!");
137 or fail("an error in the file pkg is preventing lintian from checking this package: $_");
138 my ($file, $info) = ($1,$2);
143 $file_info{$file} = $info;
146 $self->{file_info} = \%file_info;
148 return $self->{file_info};
153 return $self->{scripts} if exists $self->{scripts};
156 # sub scripts Needs-Info scripts
157 open(SCRIPTS, '<', "scripts")
158 or fail("cannot open scripts file: $!");
163 m/^(env )?(\S*) (.*)$/o
164 or fail("bad line in scripts file: $_");
165 ($file{calls_env}, $file{interpreter}, $name) = ($1, $2, $3);
170 $scripts{$name} = \%file;
173 $self->{scripts} = \%scripts;
175 return $self->{scripts};
179 # Returns the information from collect/objdump-info
182 return $self->{objdump_info} if exists $self->{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: $!");
194 if (m,^-- \./(\S+)\s*$,o) {
196 $objdump_info{$file->{name}} = $file;
198 $file = { name => $1 };
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 ];
207 if ($foo eq '.text' and $sec eq 'Base' and $sym eq 'caml_main') {
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}{$_}++;
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:/) {
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/) {
238 } elsif (m%Requesting program interpreter:\s+/lib/klibc-\S+\.so%) {
240 } elsif (m/^\s*TEXTREL\s/o) {
241 $file->{TEXTREL} = 1;
242 } elsif (m/^\s*INTERP\s/) {
244 } elsif (m/^\s*STACK\s/) {
247 if (defined $file->{STACK} and $file->{STACK} eq 0) {
251 $file->{OTHER_DATA} = 1;
257 $objdump_info{$file->{name}} = $file;
259 $self->{objdump_info} = \%objdump_info;
261 return $self->{objdump_info};
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
269 # sub relation Needs-Info <>
271 my ($self, $field) = @_;
273 return $self->{relation}->{$field} if exists $self->{relation}->{$field};
275 my %special = (all => [ qw(pre-depends depends recommends suggests) ],
276 strong => [ qw(pre-depends depends) ],
277 weak => [ qw(recommends suggests) ]);
279 if ($special{$field}) {
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);
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);
295 $self->{relation}->{$field} = Maemian::Relation->new($result);
296 return $self->{relation}->{$field};
301 Maemian::Collect::Binary - Maemian interface to binary package data collection
305 my ($name, $type) = ('foobar', 'binary');
306 my $collect = Maemian::Collect->new($name, $type);
307 if ($collect->native) {
308 print "Package is native\n";
313 Maemian::Collect::Binary provides an interface to package data for binary
314 packages. It implements data collection methods specific to binary
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
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.
336 =head1 INSTANCE METHODS
338 In addition to the instance methods listed below, all instance methods
339 documented in the Maemian::Collect module are also available.
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>.
352 Returns true if the binary package is native and false otherwise.
353 Nativeness will be judged by its version number.
357 Returns a reference to an array of hash references with content
358 information about the binary package. Each hash may have the
365 Name of the index entry without leading slash.
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.
388 Entry type as one character.
392 Entry permissions as octal number.
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.
401 If the entry is either a hardlink or symlink, contains the target of the
406 If the entry is a directory, contains the number of other entries this
411 =item relation(FIELD)
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:
421 The concatenation of Pre-Depends, Depends, Recommends, and Suggests.
425 The concatenation of Pre-Depends and Depends.
429 The concatenation of Recommends and Suggests.
433 If FIELD isn't present in the package, the returned Maemian::Relation
434 object will be empty (always satisfied and implies nothing).
440 Originally written by Frank Lichtenheld <djpig@debian.org> for Maemian.
444 lintian(1), Maemian::Collect(3), Maemian::Relation(3)
451 # indent-tabs-mode: nil
452 # cperl-indent-level: 4
454 # vim: syntax=perl sw=4 sts=4 ts=4 et shiftround