Your IP : 216.73.216.155
| Current Path : /usr/bin/ |
|
|
| Current File : //usr/bin/dpkg-scansources |
#!/usr/bin/perl
#
# Copyright © 1999 Roderick Schertler
# Copyright © 2002 Wichert Akkerman <wakkerma@debian.org>
# Copyright © 2006-2009 Guillem Jover <guillem@debian.org>
#
# 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/>.
use strict;
use warnings;
use Getopt::Long qw(:config posix_default bundling no_ignorecase);
use Dpkg;
use Dpkg::Gettext;
use Dpkg::ErrorHandling;
use Dpkg::Control;
use Dpkg::Checksums;
use Dpkg::Compression::FileHandle;
use Dpkg::Compression;
textdomain("dpkg-dev");
# Errors with a single package are warned about but don't affect the
# exit code. Only errors which affect everything cause a non-zero exit.
my $Exit = 0;
# %Override is a hash of lists. The subs following describe what's in
# the lists.
my %Override;
sub O_PRIORITY () { 0 }
sub O_SECTION () { 1 }
sub O_MAINT_FROM () { 2 } # undef for non-specific, else listref
sub O_MAINT_TO () { 3 } # undef if there's no maint override
my %Extra_Override;
my %Priority = (
'extra' => 1,
'optional' => 2,
'standard' => 3,
'important' => 4,
'required' => 5,
);
# Switches
my $Debug = 0;
my $No_sort = 0;
my $Src_override = undef;
my $Extra_override_file = undef;
my @Option_spec = (
'debug!' => \$Debug,
'help!' => \&usage,
'no-sort|n' => \$No_sort,
'source-override|s=s' => \$Src_override,
'extra-override|e=s' => \$Extra_override_file,
'version' => \&version,
);
sub debug {
print @_, "\n" if $Debug;
}
sub version {
printf _g("Debian %s version %s.\n"), $progname, $version;
exit;
}
sub usage {
printf _g(
"Usage: %s [<option> ...] <binarypath> [<overridefile> [<pathprefix>]] > Sources
Options:
-n, --no-sort don't sort by package before outputting.
-e, --extra-override <file>
use extra override file.
-s, --source-override <file>
use file for additional source overrides, default
is regular override file with .src appended.
--debug turn debugging on.
--help show this help message.
--version show the version.
See the man page for the full documentation.
"), $progname;
exit;
}
sub close_msg {
my $name = shift;
return sprintf(_g("error closing %s (\$? %d, \$! `%s')"),
$name, $?, $!)."\n";
}
sub load_override {
my $file = shift;
local $_;
my $comp_file = Dpkg::Compression::FileHandle->new(filename => $file);
while (<$comp_file>) {
s/#.*//;
next if /^\s*$/;
s/\s+$//;
my @data = split ' ', $_, 4;
unless (@data == 3 || @data == 4) {
warning(_g("invalid override entry at line %d (%d fields)"),
$., 0 + @data);
next;
}
my ($package, $priority, $section, $maintainer) = @data;
if (exists $Override{$package}) {
warning(_g("ignoring duplicate override entry for %s at line %d"),
$package, $.);
next;
}
if (!$Priority{$priority}) {
warning(_g("ignoring override entry for %s, invalid priority %s"),
$package, $priority);
next;
}
$Override{$package} = [];
$Override{$package}[O_PRIORITY] = $priority;
$Override{$package}[O_SECTION] = $section;
if (!defined $maintainer) {
# do nothing
}
elsif ($maintainer =~ /^(.*\S)\s*=>\s*(.*)$/) {
$Override{$package}[O_MAINT_FROM] = [split m-\s*//\s*-, $1];
$Override{$package}[O_MAINT_TO] = $2;
}
else {
$Override{$package}[O_MAINT_TO] = $maintainer;
}
}
close($comp_file);
}
sub load_src_override {
my ($user_file, $regular_file) = @_;
my ($file);
local $_;
if (defined $user_file) {
$file = $user_file;
}
elsif (defined $regular_file) {
my $comp = compression_guess_from_filename($regular_file);
if (defined($comp)) {
$file = $regular_file;
my $ext = compression_get_property($comp, "file_ext");
$file =~ s/\.$ext$/.src.$ext/;
} else {
$file = "$regular_file.src";
}
return unless -e $file;
}
else {
return;
}
debug "source override file $file";
my $comp_file = Dpkg::Compression::FileHandle->new(filename => $file);
while (<$comp_file>) {
s/#.*//;
next if /^\s*$/;
s/\s+$//;
my @data = split ' ', $_;
unless (@data == 2) {
warning(_g("invalid source override entry at line %d (%d fields)"),
$., 0 + @data);
next;
}
my ($package, $section) = @data;
my $key = "source/$package";
if (exists $Override{$key}) {
warning(_g("ignoring duplicate source override entry for %s at line %d"),
$package, $.);
next;
}
$Override{$key} = [];
$Override{$key}[O_SECTION] = $section;
}
close($comp_file);
}
sub load_override_extra
{
my $extra_override = shift;
my $comp_file = Dpkg::Compression::FileHandle->new(filename => $extra_override);
while (<$comp_file>) {
s/\#.*//;
s/\s+$//;
next unless $_;
my ($p, $field, $value) = split(/\s+/, $_, 3);
$Extra_Override{$p}{$field} = $value;
}
close($comp_file);
}
# Given PREFIX and DSC-FILE, process the file and returns the fields.
sub process_dsc {
my ($prefix, $file) = @_;
my $basename = $file;
my $dir = ($basename =~ s{^(.*)/}{}) ? $1 : '';
$dir = "$prefix$dir";
$dir =~ s-/+$--;
$dir = '.' if $dir eq '';
# Parse ‘.dsc’ file.
my $fields = Dpkg::Control->new(type => CTRL_PKG_SRC);
$fields->load($file);
$fields->set_options(type => CTRL_INDEX_SRC);
# Get checksums
my $checksums = Dpkg::Checksums->new();
$checksums->add_from_file($file, key => $basename);
$checksums->add_from_control($fields, use_files_for_md5 => 1);
my $source = $fields->{Source};
my @binary = split /\s*,\s*/, $fields->{Binary};
error(_g("no binary packages specified in %s"), $file) unless (@binary);
# Rename the source field to package.
$fields->{Package} = $fields->{Source};
delete $fields->{Source};
# The priority for the source package is the highest priority of the
# binary packages it produces.
my @binary_by_priority = sort {
($Override{$a} ? $Priority{$Override{$a}[O_PRIORITY]} : 0)
<=>
($Override{$b} ? $Priority{$Override{$b}[O_PRIORITY]} : 0)
} @binary;
my $priority_override = $Override{$binary_by_priority[-1]};
my $priority = $priority_override
? $priority_override->[O_PRIORITY]
: undef;
$fields->{Priority} = $priority if defined $priority;
# For the section override, first check for a record from the source
# override file, else use the regular override file.
my $section_override = $Override{"source/$source"} || $Override{$source};
my $section = $section_override
? $section_override->[O_SECTION]
: undef;
$fields->{Section} = $section if defined $section;
# For the maintainer override, use the override record for the first
# binary. Modify the maintainer if necessary.
my $maintainer_override = $Override{$binary[0]};
if ($maintainer_override && defined $maintainer_override->[O_MAINT_TO]) {
if (!defined $maintainer_override->[O_MAINT_FROM] ||
grep { $fields->{Maintainer} eq $_ }
@{ $maintainer_override->[O_MAINT_FROM] }) {
$fields->{Maintainer} = $maintainer_override->[O_MAINT_TO];
}
}
# Process extra override
if (exists $Extra_Override{$source}) {
my ($field, $value);
while(($field, $value) = each %{$Extra_Override{$source}}) {
$fields->{$field} = $value;
}
}
# A directory field will be inserted just before the files field.
$fields->{Directory} = $dir;
$checksums->export_to_control($fields, use_files_for_md5 => 1);
return $fields;
}
sub main {
my (@out);
GetOptions(@Option_spec) or usage;
@ARGV >= 1 && @ARGV <= 3 or usageerr(_g("1 to 3 args expected\n"));
push @ARGV, undef if @ARGV < 2;
push @ARGV, '' if @ARGV < 3;
my ($dir, $override, $prefix) = @ARGV;
load_override $override if defined $override;
load_src_override $Src_override, $override;
load_override_extra $Extra_override_file if defined $Extra_override_file;
open FIND, "find -L \Q$dir\E -name '*.dsc' -print |"
or syserr(_g("cannot fork for %s"), "find");
while (<FIND>) {
chomp;
s-^\./+--;
my $fields;
# FIXME: Fix it instead to not die on syntax and general errors?
eval {
$fields = process_dsc($prefix, $_);
};
if ($@) {
warn $@;
next;
}
if ($No_sort) {
$fields->output(\*STDOUT);
print "\n";
}
else {
push @out, $fields;
}
}
close FIND or error(close_msg, 'find');
if (@out) {
map {
$_->output(\*STDOUT);
print "\n";
} sort {
$a->{Package} cmp $b->{Package}
} @out;
}
return 0;
}
$Exit = main || $Exit;
$Exit = 1 if $Exit and not $Exit % 256;
exit $Exit;