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

   1 # -*- perl -*-
   2 # Maemian::Collect::Source -- interface to source package data collection
   3
   4 # Copyright (C) 2008 Russ Allbery
   5 # Copyright (C) 2009 Raphael Geissert
   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 Maemian::Collect::Source;
  21
  22 use strict;
  23 use warnings;
  24 use base 'Maemian::Collect';
  25
  26 use Maemian::Relation;
  27 use Parse::DebianChangelog;
  28
  29 use Util;
  30
  31 our @ISA = qw(Maemian::Collect);
  32
  33 # Initialize a new source package collect object.  Takes the package name,
  34 # which is currently unused.
  35 sub new {
  36     my ($class, $pkg) = @_;
  37     my $self = {};
  38     bless($self, $class);
  39     return $self;
  40 }
  41
  42 # Get the changelog file of a source package as a Parse::DebianChangelog
  43 # object.  Returns undef if the changelog file couldn't be found.
  44 # sub changelog Needs-Info <>
  45 sub changelog {
  46     my ($self) = @_;
  47     return $self->{changelog} if exists $self->{changelog};
  48     if (-l 'debfiles/changelog' || ! -f 'debfiles/changelog') {
  49         $self->{changelog} = undef;
  50     } else {
  51         my %opts = (infile => 'debfiles/changelog', quiet => 1);
  52         $self->{changelog} = Parse::DebianChangelog->init(\%opts);
  53     }
  54     return $self->{changelog};
  55 }
  56
  57 # Returns whether the package is a native package.  For everything except
  58 # format 3.0 (quilt) packages, we base this on whether we have a Debian
  59 # *.diff.gz file.  3.0 (quilt) packages are always non-native.  Returns true
  60 # if the package is native and false otherwise.
  61 # sub native Needs-Info <>
  62 sub native {
  63     my ($self) = @_;
  64     return $self->{native} if exists $self->{native};
  65     my $format = $self->field('format');
  66     if ($format =~ /^\s*2\.0\s*$/ or $format =~ /^\s*3\.0\s+\(quilt\)\s*$/) {
  67         $self->{native} = 0;
  68     } else {
  69         my $version = $self->field('version');
  70         $version =~ s/^\d+://;
  71         my $name = $self->{name};
  72         $self->{native} = (-f "${name}_${version}.diff.gz" ? 0 : 1);
  73     }
  74     return $self->{native};
  75 }
  76
  77 # Returns a hash of binaries to the package type, assuming a type of deb
  78 # unless the package type field is present.
  79 sub binaries {
  80     my ($self) = @_;
  81     return $self->{binaries} if exists $self->{binaries};
  82     my %binaries;
  83     # sub binaries Needs-Info source-control-file
  84     opendir(BINPKGS, 'control') or fail("can't open control directory: $!");
  85     for my $package (readdir BINPKGS) {
  86         next if $package =~ /^\.\.?$/;
  87         my $type = $self->binary_field($package, 'xc-package-type') || 'deb';
  88         $binaries{$package} = lc $type;
  89     }
  90     closedir BINPKGS;
  91     $self->{binaries} = \%binaries;
  92     return $self->{binaries};
  93 }
  94
  95 # Returns the value of a control field for a binary package or the empty
  96 # string if that control field isn't present.  This does not implement
  97 # inheritance from the settings in the source stanza.
  98 sub binary_field {
  99     my ($self, $package, $field) = @_;
 100     return $self->{binary_field}{$package}{$field}
 101         if exists $self->{binary_field}{$package}{$field};
 102     my $value = '';
 103     # sub binary_field Needs-Info source-control-file
 104     if (-f "control/$package/$field") {
 105         $value = slurp_entire_file("control/$package/$field");
 106         chomp $value;
 107     }
 108     $self->{binary_field}{$package}{$field} = $value;
 109     return $self->{binary_field}{$package}{$field};
 110 }
 111
 112 # Return a Maemian::Relation object for the given relationship field in a
 113 # binary package.  In addition to all the normal relationship fields, the
 114 # following special field names are supported:  all (pre-depends, depends,
 115 # recommends, and suggests), strong (pre-depends and depends), and weak
 116 # (recommends and suggests).
 117 sub binary_relation {
 118     my ($self, $package, $field) = @_;
 119     $field = lc $field;
 120     return $self->{binary_relation}->{$package}->{$field}
 121         if exists $self->{binary_relation}->{$package}->{$field};
 122
 123     my %special = (all    => [ qw(pre-depends depends recommends suggests) ],
 124                    strong => [ qw(pre-depends depends) ],
 125                    weak   => [ qw(recommends suggests) ]);
 126     my $result;
 127     if ($special{$field}) {
 128         my $merged;
 129         for my $f (@{ $special{$field} }) {
 130             # sub binary_relation Needs-Info :binary_field
 131             my $value = $self->binary_field($f);
 132             $merged .= ', ' if (defined($merged) and defined($value));
 133             $merged .= $value if defined($value);
 134         }
 135         $result = $merged;
 136     } else {
 137         my %known = map { $_ => 1 }
 138             qw(pre-depends depends recommends suggests enhances breaks
 139                conflicts provides replaces);
 140         croak("unknown relation field $field") unless $known{$field};
 141         my $value = $self->binary_field($field);
 142         $result = $value if defined($value);
 143     }
 144     $result = Maemian::Relation->new($result);
 145     $self->{binary_relation}->{$package}->{$field} = $result;
 146     return $self->{binary_relation}->{$field};
 147 }
 148
 149 # Returns the information from collect/file-info.
 150 sub file_info {
 151     my ($self) = @_;
 152     return $self->{file_info} if exists $self->{file_info};
 153
 154     my %file_info;
 155     # sub file_info Needs-Info file-info
 156     open(my $idx, '<', "file-info") or fail("cannot open file-info: $!");
 157     while (<$idx>) {
 158         chomp;
 159         m/^(.+?):\s+(.*)$/o or fail("cannot parse file output: $_");
 160         my ($file, $info) = ($1,$2);
 161         $file =~ s,^\./,,o;
 162         $file =~ s,/+$,,o;
 163         $file_info{$file} = $info;
 164     }
 165     close $idx;
 166     $self->{file_info} = \%file_info;
 167     return $self->{file_info};
 168 }
 169
 170 # Return a Maemian::Relation object for the given build relationship
 171 # field.  In addition to all the normal build relationship fields, the
 172 # following special field names are supported:  build-depends-all
 173 # (build-depends and build-depends-indep) and build-conflicts-all
 174 # (build-conflicts and build-conflicts-indep).
 175 # sub relation Needs-Info <>
 176 sub relation {
 177     my ($self, $field) = @_;
 178     $field = lc $field;
 179     return $self->{relation}->{$field} if exists $self->{relation}->{$field};
 180
 181     my $result;
 182     if ($field =~ /^build-(depends|conflicts)-all$/) {
 183         my $type = $1;
 184         my $merged;
 185         for my $f ("build-$type", "build-$type-indep") {
 186             my $value = $self->field($f);
 187             $merged .= ', ' if (defined($merged) and defined($value));
 188             $merged .= $value if defined($value);
 189         }
 190         $result = $merged;
 191     } elsif ($field =~ /^build-(depends|conflicts)(-indep)?$/) {
 192         my $value = $self->field($field);
 193         $result = $value if defined($value);
 194     } else {
 195         croak("unknown relation field $field");
 196     }
 197     $self->{relation}->{$field} = Maemian::Relation->new($result);
 198     return $self->{relation}->{$field};
 199 }
 200
 201 # Similar to relation(), return a Maemian::Relation object for the given build
 202 # relationship field, but ignore architecture restrictions.  It supports the
 203 # same special field names.
 204 # sub relation_noarch Needs-Info <>
 205 sub relation_noarch {
 206     my ($self, $field) = @_;
 207     $field = lc $field;
 208     return $self->{relation_noarch}->{$field}
 209         if exists $self->{relation_noarch}->{$field};
 210
 211     my $result;
 212     if ($field =~ /^build-(depends|conflicts)-all$/) {
 213         my $type = $1;
 214         my $merged;
 215         for my $f ("build-$type", "build-$type-indep") {
 216             my $value = $self->field($f);
 217             $merged .= ', ' if (defined($merged) and defined($value));
 218             $merged .= $value if defined($value);
 219         }
 220         $result = $merged;
 221     } elsif ($field =~ /^build-(depends|conflicts)(-indep)?$/) {
 222         my $value = $self->field($field);
 223         $result = $value if defined($value);
 224     } else {
 225         croak("unknown relation field $field");
 226     }
 227     $self->{relation_noarch}->{$field}
 228         = Maemian::Relation->new_noarch($result);
 229     return $self->{relation_noarch}->{$field};
 230 }
 231
 232 =head1 NAME
 233
 234 Maemian::Collect::Source - Maemian interface to source package data collection
 235
 236 =head1 SYNOPSIS
 237
 238     my ($name, $type) = ('foobar', 'source');
 239     my $collect = Maemian::Collect->new($name, $type);
 240     if ($collect->native) {
 241         print "Package is native\n";
 242     }
 243
 244 =head1 DESCRIPTION
 245
 246 Maemian::Collect::Source provides an interface to package data for source
 247 packages.  It implements data collection methods specific to source
 248 packages.
 249
 250 This module is in its infancy.  Most of Maemian still reads all data from
 251 files in the laboratory whenever that data is needed and generates that
 252 data via collect scripts.  The goal is to eventually access all data about
 253 source packages via this module so that the module can cache data where
 254 appropriate and possibly retire collect scripts in favor of caching that
 255 data in memory.
 256
 257 =head1 CLASS METHODS
 258
 259 =over 4
 260
 261 =item new(PACKAGE)
 262
 263 Creates a new Maemian::Collect::Source object.  Currently, PACKAGE is
 264 ignored.  Normally, this method should not be called directly, only via
 265 the Maemian::Collect constructor.
 266
 267 =back
 268
 269 =head1 INSTANCE METHODS
 270
 271 In addition to the instance methods listed below, all instance methods
 272 documented in the Maemian::Collect module are also available.
 273
 274 =over 4
 275
 276 =item binaries()
 277
 278 Returns a hash reference with the binary package names as keys and the
 279 Package-Type as value (which should be either C<deb> or C<udeb>
 280 currently).  The source-control-file collection script must have been run
 281 to parse the F<debian/control> file and put the fields in the F<control>
 282 directory in the lab.
 283
 284 =item binary_field(PACKAGE, FIELD)
 285
 286 Returns the content of the field FIELD for the binary package PACKAGE in
 287 the F<debian/control> file, or an empty string if that field isn't set.
 288 Inheritance of field values from the source section of the control file is
 289 not implemented.  Only the literal value of the field is returned.
 290
 291 The source-control-file collection script must have been run to parse the
 292 F<debian/control> file and put the fields in the F<control> directory in
 293 the lab.
 294
 295 =item binary_relation(PACKAGE, FIELD)
 296
 297 Returns a Maemian::Relation object for the specified FIELD in the binary
 298 package PACKAGE in the F<debian/control> file.  FIELD should be one of the
 299 possible relationship fields of a Debian package or one of the following
 300 special values:
 301
 302 =over 4
 303
 304 =item all
 305
 306 The concatenation of Pre-Depends, Depends, Recommends, and Suggests.
 307
 308 =item strong
 309
 310 The concatenation of Pre-Depends and Depends.
 311
 312 =item weak
 313
 314 The concatenation of Recommends and Suggests.
 315
 316 =back
 317
 318 If FIELD isn't present in the package, the returned Maemian::Relation
 319 object will be empty (always satisfied and implies nothing).
 320
 321 Any substvars in F<debian/control> will be represented in the returned
 322 relation as packages named after the substvar.
 323
 324 =item changelog()
 325
 326 Returns the changelog of the source package as a Parse::DebianChangelog
 327 object, or undef if the changelog is a symlink or doesn't exist.  The
 328 debfiles collection script must have been run to create the changelog
 329 file, which this method expects to find in F<debfiles/changelog>.
 330
 331 =item native()
 332
 333 Returns true if the source package is native and false otherwise.
 334
 335 =item relation(FIELD)
 336
 337 Returns a Maemian::Relation object for the given build relationship field
 338 FIELD.  In addition to the normal build relationship fields, the
 339 following special field names are supported:
 340
 341 =over 4
 342
 343 =item build-depends-all
 344
 345 The concatenation of Build-Depends and Build-Depends-Indep.
 346
 347 =item build-conflicts-all
 348
 349 The concatenation of Build-Conflicts and Build-Conflicts-Indep.
 350
 351 =back
 352
 353 If FIELD isn't present in the package, the returned Maemian::Relation
 354 object will be empty (always satisfied and implies nothing).
 355
 356 =item relation_noarch(FIELD)
 357
 358 The same as relation(), but ignores architecture restrictions in the
 359 FIELD field.
 360
 361 =back
 362
 363 =head1 AUTHOR
 364
 365 Originally written by Russ Allbery <rra@debian.org> for Maemian.
 366
 367 =head1 SEE ALSO
 368
 369 lintian(1), Maemian::Collect(3), Maemian::Relation(3)
 370
 371 =cut
 372
 373 1;
 374
 375 # Local Variables:
 376 # indent-tabs-mode: nil
 377 # cperl-indent-level: 4
 378 # End:
 379 # vim: syntax=perl sw=4 sts=4 ts=4 et shiftround