Bug#685787: Praat has serious bug #713597
Andreas Tille
tille at debian.org
Mon Oct 28 21:10:00 UTC 2013
[Bug #685787: Short background: Rafael volunteered to check the
difference between the branch of devscripts at
http://anonscm.debian.org/gitweb/?p=users/tille/devscripts.git;a=summary
done at 2012-08-26 to provide a handy way for a patch (according
to some of the various hints I've got to my proposal.]
Hi Rafael,
On Mon, Oct 28, 2013 at 07:44:57PM +0100, Rafael Laboissiere wrote:
> >Ok, I will take a look at it.
>
> I did a 3-way merge using the versions of uscan.pl at master in both
> repositories and the common ancestor of them. The resulting script
> is attached below. It works for me in the praat package, but I did
> not tested it elsewhere.
Thanks.
> FYI, I am also attaching the diffs with the versions at master in
> both yours (uscan.pl.diff-tille) and the developer's repositories.
Good.
> It would be preferable that you had created a side branch in the Git
> repository for your changes, such that the merge would be trivial to
> do.
While seeing it now (14 monthes later since I started the branch) this
would have been probably better. In the (longish) discussion I was
advised to do so because this was somehow the "usual" way to go since
Git would provide that great merging features (I'm remaining at very
beginner level regarding Git) and it was not intended at all to take
that long. :-(
> I think that the best thing to do now is to generated a Git
> patch against the main repository's master version and propose it to
> the developers. What do you think?
Most probably. Specifically I think it makes sense to publish your
diffs in the according bug report to make sure it appears somewhere
online.
> It will also be necessary to prepare a qpatched versions for uscan.1
> and debian/control.
I'd happily provide this if I could be sure that this effort is not
wasted in a way that uscan in devscripts simply moves on and I need
to redo the patch later again. Some signal of devscripts maintainer
regarding this would be helpful.
> BTW, I think that we should add Recommends:
> libtry-tiny-perl libdpkg-perl
That's correct.
Kind regards
Andreas.
--
http://fam-tille.de
-------------- next part --------------
A non-text attachment was scrubbed...
Name: uscan.pl
Type: text/x-perl
Size: 77830 bytes
Desc: not available
URL: <http://lists.alioth.debian.org/pipermail/devscripts-devel/attachments/20131028/1e67f44d/attachment-0001.pl>
-------------- next part --------------
--- uscan.pl-master 2013-10-28 16:43:24.000000000 +0100
+++ uscan.pl-tille-patched 2013-10-28 17:47:33.000000000 +0100
@@ -27,6 +27,7 @@
use Cwd;
use Cwd 'abs_path';
use Dpkg::IPC;
+use Try::Tiny;
use File::Basename;
use File::Copy;
use File::Temp qw/tempfile tempdir/;
@@ -46,6 +47,9 @@
}
}
}
+# Dpkg::Control::Hash prefered by James McCoy (who did the last three uscan.pl edits using a debian.org e-mail address)
+use Dpkg::Control::Hash;
+
my $CURRENT_WATCHFILE_VERSION = 3;
my $progname = basename($0);
@@ -72,6 +76,8 @@
sub dehs_output ();
sub quoted_regex_replace ($);
sub safe_replace ($$);
+sub get_main_source_dir($$$$$);
+sub compress_archive($$$);
sub usage {
print <<"EOF";
@@ -100,6 +106,9 @@
--repack Repack downloaded archives from orig.tar.bz2, orig.tar.lzma,
orig.tar.xz or orig.zip to orig.tar.gz
(does nothing if downloaded archive orig.tar.gz)
+ --repack-compression COMP
+ When some repackaging is done use compression COMP for
+ the resulting tarball
--no-symlink Don\'t make symlink or rename
--verbose Give verbose output
--no-verbose Don\'t give verbose output (default)
@@ -138,6 +147,8 @@
--no-conf, --noconf
Don\'t read devscripts config files;
must be the first option given
+ --no-exclusion no automatic exclusion of files mentioned in
+ debian/copyright field Files-Excluded
--help Show this message
--version Show version information
@@ -169,6 +180,8 @@
my $force_download = 0;
my $report = 0; # report even on up-to-date packages?
my $repack = 0; # repack .tar.bz2, .tar.lzma, .tar.xz or .zip to .tar.gz
+my $default_compression = 'gz' ;
+my $repack_compression = $default_compression;
my $symlink = 'symlink';
my $verbose = 0;
my $check_dirname_level = 1;
@@ -180,6 +193,7 @@
my $pkg_report_header = '';
my $timeout = 20;
my $user_agent_string = 'Debian uscan ###VERSION###';
+my $no_exclusion = 0;
if (@ARGV and $ARGV[0] =~ /^--no-?conf$/) {
$modified_conf_msg = " (no configuration files read)";
@@ -196,6 +210,7 @@
'USCAN_DEHS_OUTPUT' => 'no',
'USCAN_USER_AGENT' => '',
'USCAN_REPACK' => 'no',
+ 'USCAN_NO_EXCLUSION' => 'no',
'DEVSCRIPTS_CHECK_DIRNAME_LEVEL' => 1,
'DEVSCRIPTS_CHECK_DIRNAME_REGEX' => 'PACKAGE(-.+)?',
);
@@ -233,6 +248,8 @@
or $config_vars{'USCAN_DEHS_OUTPUT'}='no';
$config_vars{'USCAN_REPACK'} =~ /^(yes|no)$/
or $config_vars{'USCAN_REPACK'}='no';
+ $config_vars{'USCAN_NO_EXCLUSION'} =~ /^(yes|no)$/
+ or $config_vars{'USCAN_NO_EXCLUSION'}='no';
$config_vars{'DEVSCRIPTS_CHECK_DIRNAME_LEVEL'} =~ /^[012]$/
or $config_vars{'DEVSCRIPTS_CHECK_DIRNAME_LEVEL'}=1;
@@ -263,7 +280,8 @@
# Now read the command line arguments
my $debug = 0;
my ($opt_h, $opt_v, $opt_destdir, $opt_download, $opt_force_download,
- $opt_report, $opt_passive, $opt_symlink, $opt_repack);
+ $opt_report, $opt_passive, $opt_symlink, $opt_repack,
+ $opt_repack_compression, $opt_no_exclusion);
my ($opt_verbose, $opt_level, $opt_regex, $opt_noconf);
my ($opt_package, $opt_uversion, $opt_watchfile, $opt_dehs, $opt_timeout);
my $opt_download_version;
@@ -283,6 +301,7 @@
"symlink!" => sub { $opt_symlink = $_[1] ? 'symlink' : 'no'; },
"rename" => sub { $opt_symlink = 'rename'; },
"repack" => sub { $opt_repack = 1; },
+ "repack-compression=s" => \$opt_repack_compression,
"package=s" => \$opt_package,
"upstream-version=s" => \$opt_uversion,
"watchfile=s" => \$opt_watchfile,
@@ -295,6 +314,7 @@
"useragent=s" => \$opt_user_agent,
"noconf" => \$opt_noconf,
"no-conf" => \$opt_noconf,
+ "no-exclusion" => \$opt_no_exclusion,
"download-current-version" => \$opt_download_current_version,
)
or die "Usage: $progname [options] [directories]\nRun $progname --help for more details\n";
@@ -317,7 +337,18 @@
$timeout = 20 unless defined $timeout and $timeout > 0;
$symlink = $opt_symlink if defined $opt_symlink;
$verbose = $opt_verbose if defined $opt_verbose;
+if ( defined $opt_repack_compression ) {
+ if ( $opt_repack_compression =~ /^gz$/ or
+ $opt_repack_compression =~ /^bz2$/ or
+ $opt_repack_compression =~ /^xz$/ or
+ $opt_repack_compression =~ /^lzma$/ ) {
+ $repack_compression = $opt_repack_compression;
+ } else {
+ print "-- Invalid compression $opt_repack_compression given. Use default $default_compression instead.\n" if $verbose ;
+ }
+}
$dehs = $opt_dehs if defined $opt_dehs;
+$no_exclusion = $opt_no_exclusion if defined $opt_no_exclusion;
$user_agent_string = $opt_user_agent if defined $opt_user_agent;
$download_version = $opt_download_version if defined $opt_download_version;
@@ -1402,71 +1433,67 @@
or uscan_die("$progname warning: OpenPGP signature did not verify.\n");
}
- if ($repack and $newfile_base =~ /^(.*)\.(tar\.bz2|tbz2?)$/) {
+ if ($repack and $newfile_base =~ /^(.*)\.(tar\.bz2|tbz2?)$/ and
+ $repack_compression !~ /^bz2$/ ) {
print "-- Repacking from bzip2 to gzip\n" if $verbose;
- my $newfile_base_gz = "$1.tar.gz";
+ my $newfile_base_compression = "$1.tar.".$repack_compression;
my (undef, $fname) = tempfile(UNLINK => 1);
spawn(exec => ['bunzip2', '-c', "$destdir/$newfile_base"],
to_file => $fname,
wait_child => 1);
spawn(exec => ['gzip', '-n', '-9'],
from_file => $fname,
- to_file => "$destdir/$newfile_base_gz",
+ to_file => "$destdir/$newfile_base_compression",
wait_child => 1);
unlink "$destdir/$newfile_base";
- $newfile_base = $newfile_base_gz;
+ $newfile_base = $newfile_base_compression;
}
- if ($repack and $newfile_base =~ /^(.*)\.(tar\.lzma|tlz(?:ma?)?)$/) {
- print "-- Repacking from lzma to gzip\n" if $verbose;
- my $newfile_base_gz = "$1.tar.gz";
+ if ($repack and $newfile_base =~ /^(.*)\.(tar\.lzma|tlz(?:ma?)?)$/ and
+ $repack_compression !~ /^lzma$/ ) {
+ print "-- Repacking from lzma to $repack_compression\n" if $verbose;
+ my $newfile_base_compression = "$1.tar.".$repack_compression;
my (undef, $fname) = tempfile(UNLINK => 1);
spawn(exec => ['xz', '-F', 'lzma', '-cd', "$destdir/$newfile_base"],
to_file => $fname,
wait_child => 1);
- spawn(exec => ['gzip', '-n', '-9'],
- from_file => $fname,
- to_file => "$destdir/$newfile_base_gz",
- wait_child => 1);
- unlink "$destdir/$newfile_base";
- $newfile_base = $newfile_base_gz;
+ compress_archive("$fname", "$destdir/$newfile_base_compression", $repack_compression);
+ $newfile_base = $newfile_base_compression;
}
- if ($repack and $newfile_base =~ /^(.*)\.(tar\.xz|txz)$/) {
- print "-- Repacking from xz to gzip\n" if $verbose;
- my $newfile_base_gz = "$1.tar.gz";
+ if ($repack and $newfile_base =~ /^(.*)\.(tar\.xz|txz)$/ and
+ $repack_compression !~ /^xz$/ ) {
+ print "-- Repacking from xz to $repack_compression\n" if $verbose;
+ my $newfile_base_compression = "$1.tar.".$repack_compression;
my (undef, $fname) = tempfile(UNLINK => 1);
spawn(exec => ['xz', '-cd', "$destdir/$newfile_base"],
to_file => $fname,
wait_child => 1);
- spawn(exec => ['gzip', '-n', '-9'],
- from_file => $fname,
- to_file => "$destdir/$newfile_base_gz",
- wait_child => 1);
- unlink "$destdir/$newfile_base";
- $newfile_base = $newfile_base_gz;
+ compress_archive("$fname", "$destdir/$newfile_base_compression", $repack_compression);
+ $newfile_base = $newfile_base_compression;
}
- if ($repack and $newfile_base =~ /^(.*)\.zip$/) {
- print "-- Repacking from zip to .tar.gz\n" if $verbose;
+ if ($repack and $newfile_base =~ /^(.*)\.(zip|jar)$/) {
+ print "-- Repacking from zip to .tar.$repack_compression\n" if $verbose;
system('command -v unzip >/dev/null 2>&1') >> 8 == 0
or uscan_die("unzip binary not found. You need to install the package unzip to be able to repack .zip upstream archives.\n");
- my $newfile_base_gz = "$1.tar.gz";
+ my $compress_file_base = "$1.tar" ;
+ my $newfile_base_compression = "$compress_file_base.".$repack_compression;
my $tempdir = tempdir ( "uscanXXXX", TMPDIR => 1, CLEANUP => 1 );
my $globpattern = "*";
my $hidden = ".[!.]*";
my $absdestdir = abs_path($destdir);
system('unzip', '-q', '-a', '-d', $tempdir, "$destdir/$newfile_base") == 0
- or uscan_die("Repacking from zip to tar.gz failed (could not unzip)\n");
+ or uscan_die "Repacking from zip or jar to tar.$repack_compression failed (could not unzip)\n";
if (defined glob("$tempdir/$hidden")) {
$globpattern .= " $hidden";
}
- system("cd $tempdir; GZIP='-n -9' tar --owner=root --group=root --mode=a+rX -czf \"$absdestdir/$newfile_base_gz\" $globpattern") == 0
- or uscan_die("Repacking from zip to tar.gz failed (could not create tarball)\n");
- unlink "$destdir/$newfile_base";
- $newfile_base = $newfile_base_gz;
+ system("cd $tempdir; tar --owner=root --group=root --mode=a+rX -cf \"$absdestdir/$compress_file_base\" $globpattern") == 0
+ or uscan_die "Repacking from zip or jar to tar.$repack_compression failed (could not create tarball)\n";
+ compress_archive("$absdestdir/$compress_file_base", "$absdestdir/$newfile_base_compression", $repack_compression);
+ $newfile_base = $newfile_base_compression;
}
if ($newfile_base =~ /\.(tar\.gz|tgz
@@ -1480,6 +1507,70 @@
}
}
+ my $excludesuffix = '+dfsg';
+ if ( !$no_exclusion ) {
+ my $data ;
+ $data = Dpkg::Control::Hash->new();
+ try {
+ $data->load('debian/copyright');
+ } catch {
+ print "-- No machine readable debian/copyright file.\n" if ( $verbose ) ;
+ $data->{'format'} = '' ;
+ } ;
+ # my $parser = new Parse::DebControl(1);
+ # my $data = $parser->parse_file('debian/copyright', {discardCase=>1,singleBlock=>1,});
+ my $okformat = qr'http://www.debian.org/doc/packaging-manuals/copyright-format/[.\d]+';
+ print "-- Wrong format of debian/copyright file to profit from Files-Excluded.\n" if ( $data->{'files-excluded'} and $data->{'format'} !~ m{^$okformat/?$} and $verbose ) ;
+ if ($data->{'format'} =~ m{^$okformat/?$} and $data->{'files-excluded'} ) {
+ my $tempdir = tempdir ( "uscanXXXX", TMPDIR => 1, CLEANUP => 1 );
+ my $globpattern = "*";
+ my $hidden = ".[!.]*";
+ if (defined glob("$tempdir/$hidden")) {
+ $globpattern .= " $hidden";
+ }
+ my $absdestdir = abs_path($destdir);
+ unless ( system("cd $tempdir; tar -xaf \"$absdestdir/$newfile_base\" 2>/dev/null") == 0 ) {
+ print "-- $newfile_base is no tarball. Try unzip.\n" if $verbose;
+ # try unzip if tar fails - we do want to do something sensible even if no --repack was specified
+ system('command -v unzip >/dev/null 2>&1') >> 8 == 0
+ or die("unzip binary not found. This would serve as fallback because tar just failed.\n");
+ # system('unzip', '-q', '-a', '-d', $tempdir, "$destdir/$newfile_base") == 0
+ # When using -a option (text) files could be changed in size (some whitespace encoding can change
+ # While it makes sense to get proper UNIX whitespaces in the repackaged source it does not help
+ # when verifying the repackaging result via diff. While `diff -b` helps here this is disabled
+ # for the moment.
+ system('unzip', '-q', '-d', $tempdir, "$destdir/$newfile_base") == 0
+ or die("Repacking from zip or jar to tar.gz failed (could not unzip)\n");
+ }
+ # Some source archives contain a useless __MACOSX dir which would prevent a reasonable
+ # normalising of the +dfsg.orig archive - so removing it in advance in case it should
+ # be removed anyway helps creating normalised source archives.
+ my $exclude__MACOSX = grep( /\s*\/?__MACOSX\/?\s*/, $data->{"files-excluded"} );
+ my $main_source_dir = get_main_source_dir($tempdir, $pkg, $newversion, $excludesuffix, $exclude__MACOSX);
+ unless ( -d $main_source_dir ) {
+ print STDERR "Error: $main_source_dir is no directory";
+ }
+ my $nfiles_before = `find "$main_source_dir" | wc -l`;
+ foreach (split /\s+/, $data->{"files-excluded"}) {
+ # delete trailing '/' because otherwise find -path will fail
+ s?/+$?? ;
+ # use -depth to enable deleting directories
+ system('find',$main_source_dir,'-depth','-path',"$main_source_dir/$_",qw(-exec rm -rf {} ;))==0 or
+ die "failure to run find properly";
+ };
+ my $nfiles_after = `find "$main_source_dir" | wc -l`;
+ if ( $nfiles_before == $nfiles_after && ! $exclude__MACOSX ) {
+ print "-- Source tree remains identical - no need for repacking.\n" if $verbose;
+ } else {
+ my $newfile_base_dfsg = "${pkg}_${newversion}${excludesuffix}.orig.tar" ;
+ system("cd $tempdir; tar --owner=root --group=root --mode=a+rX --exclude-vcs -cf \"$absdestdir/$newfile_base_dfsg\" $globpattern") == 0
+ or die("Excluding files failed (could not create tarball)\n");
+ compress_archive("$absdestdir/$newfile_base_dfsg", "$absdestdir/$newfile_base_dfsg.$repack_compression", $repack_compression);
+ $symlink = 'files-excluded' # prevent symlinking or renaming
+ }
+ }
+ }
+
my @renames = (
[qr/\.(tar\.gz|tgz)$/, 'gz'],
[qr/\.(tar\.bz2|tbz2?)$/, 'bz2'],
@@ -1506,6 +1597,8 @@
print " and symlinked $renamed_base to it\n";
} elsif ($symlink eq 'rename') {
print " and renamed it as $renamed_base\n";
+ } elsif ($symlink eq 'files-excluded') {
+ print " and removed files from it in ${pkg}_${newversion}${excludesuffix}.orig.tar.$suffix\n";
}
} elsif ($dehs) {
my $msg = "Successfully downloaded updated package $newfile_base";
@@ -1514,6 +1607,8 @@
$msg .= " and symlinked $renamed_base to it";
} elsif ($symlink eq 'rename') {
$msg .= " and renamed it as $renamed_base";
+ } elsif ($symlink eq 'files-excluded') {
+ $msg .= " and removed files from it in ${pkg}_${newversion}${excludesuffix}.orig.tar.$suffix\n";
} else {
$dehs_tags{'target'} = $newfile_base;
}
@@ -1524,6 +1619,8 @@
print " and symlinked $renamed_base to it\n";
} elsif ($symlink eq 'rename') {
print " and renamed it as $renamed_base\n";
+ } elsif ($symlink eq 'files-excluded') {
+ print " and removed files from it in ${pkg}_${newversion}${excludesuffix}.orig.tar.$suffix\n";
}
}
last;
@@ -2066,3 +2163,88 @@
return 1;
}
}
+
+sub get_main_source_dir($$$$$) {
+ my ($tempdir, $pkg, $newversion, $excludesuffix, $exclude__MACOSX) = @_;
+ my $fcount = 0;
+ my $main_source_dir = '' ;
+ my $any_dir = '' ;
+ opendir DIR, $tempdir or die "opendir $tempdir: $!";
+ my @files = readdir DIR ;
+ closedir DIR ;
+ foreach my $file (@files) {
+ unless ($file =~ /^\.\.?/) {
+ if ( $exclude__MACOSX && $file =~ /^__MACOSX$/ ) {
+ `rm -rf ${tempdir}/__MACOSX` ;
+ next ;
+ }
+ $fcount++;
+ if ( -d $tempdir.'/'.$file ) {
+ $any_dir = $tempdir . '/' . $file ;
+ # check whether there is some dir in upstream source which looks reasonable
+ # If such dir exists, we do not try to undirty the directory structure
+ $main_source_dir = $any_dir if ( $file =~ /^$pkg\w*$newversion$/i ) ;
+ }
+ }
+ }
+ if ( $fcount == 1 and $main_source_dir ) {
+ return $main_source_dir ;
+ }
+ if ( $fcount == 1 and $any_dir ) {
+ # Unusual base dir in tarball - should be rather something like ${pkg}-${newversion}
+ $main_source_dir = $tempdir . '/' . $pkg . '-' . $newversion . $excludesuffix . '.orig';
+ move($any_dir, $main_source_dir) or die("Unable to move $any_dir directory $main_source_dir\n");
+ return $main_source_dir ;
+ }
+ print "-- Dirty tarball found.\n" if $verbose;
+ if ( $main_source_dir ) { # if tarball is dirty but does contain a $pkg-$newversion dir we will not undirty but leave it as is
+ print "-- No idea how to create proper tarball structure - leaving as is.\n" if $verbose;
+ return $tempdir;
+ }
+ print "-- Move files to subdirectory $pkg-$newversion.\n" if $verbose;
+ $main_source_dir = $tempdir . '/' . $pkg . '-' . $newversion . $excludesuffix . '.orig';
+ mkdir($main_source_dir) or die("Unable to create temporary source directory $main_source_dir\n");
+ foreach my $file (@files) {
+ unless ($file =~ /^\.\.?/) {
+ if ( -d "${tempdir}/$file" ) {
+ # HELP: why can't perl move not move directories????
+ system( "mv ${tempdir}/$file $main_source_dir" ) ;
+ } else {
+ move("${tempdir}/$file", $main_source_dir) or die("Unable to move ${tempdir}/$file directory $main_source_dir\n");
+ }
+ }
+ }
+ return $main_source_dir;
+}
+
+
+sub compress_archive($$$) {
+ my ($from_file, $to_file, $compression) = @_;
+ if ( $compression =~ /^gz$/ ) {
+ spawn(exec => ['gzip', '-n', '-9'],
+ from_file => $from_file,
+ to_file => $to_file,
+ wait_child => 1);
+ } elsif ( $compression =~ /^bz2$/ ) {
+ # The actual options should be discussed - supporting small memory seems reasonable
+ spawn(exec => ['bzip2', '--small'],
+ from_file => $from_file,
+ to_file => $to_file,
+ wait_child => 1);
+ } elsif ( $compression =~ /^xz$/ ) {
+ # The actual options should be discussed - supporting small memory seems reasonable
+ spawn(exec => ['xz', '--memlimit=150MiB'],
+ from_file => $from_file,
+ to_file => $to_file,
+ wait_child => 1);
+ } elsif ( $compression =~ /^lzma$/ ) {
+ # The actual options should be discussed - no idea what might be reasonable here
+ spawn(exec => ['lzma'],
+ from_file => $from_file,
+ to_file => $to_file,
+ wait_child => 1);
+ } else {
+ die("Unknown compression method $compression.");
+ }
+ unlink "$from_file";
+}
-------------- next part --------------
--- uscan.pl-tille 2013-10-28 16:43:36.000000000 +0100
+++ uscan.pl-tille-patched 2013-10-28 17:47:33.000000000 +0100
@@ -1,4 +1,5 @@
#! /usr/bin/perl -w
+# -*- tab-width: 8; indent-tabs-mode: t; cperl-indent-level: 4 -*-
# uscan: This program looks for watchfiles and checks upstream ftp sites
# for later versions of the software.
@@ -48,8 +49,6 @@
}
# Dpkg::Control::Hash prefered by James McCoy (who did the last three uscan.pl edits using a debian.org e-mail address)
use Dpkg::Control::Hash;
-# Parse::DebControl suggested by Jonas Smedegaard
-# use Parse::DebControl;
my $CURRENT_WATCHFILE_VERSION = 3;
@@ -62,6 +61,7 @@
if ($@) {
$haveSSL = 0;
}
+my $havegpgv = (-x '/usr/bin/gpgv');
# Did we find any new upstream versions on our wanderings?
our $found = 0;
@@ -71,8 +71,8 @@
sub recursive_regex_dir ($$$);
sub newest_dir ($$$$$);
sub dehs_msg ($);
-sub dehs_warn ($);
-sub dehs_die ($);
+sub uscan_warn (@);
+sub uscan_die (@);
sub dehs_output ();
sub quoted_regex_replace ($);
sub safe_replace ($$);
@@ -351,36 +351,32 @@
$no_exclusion = $opt_no_exclusion if defined $opt_no_exclusion;
$user_agent_string = $opt_user_agent if defined $opt_user_agent;
$download_version = $opt_download_version if defined $opt_download_version;
-if ($dehs) {
- $SIG{'__WARN__'} = \&dehs_warn;
- $SIG{'__DIE__'} = \&dehs_die;
-}
if (defined $opt_level) {
if ($opt_level =~ /^[012]$/) { $check_dirname_level = $opt_level; }
else {
- die "$progname: unrecognised --check-dirname-level value (allowed are 0,1,2)\n";
+ uscan_die "$progname: unrecognised --check-dirname-level value (allowed are 0,1,2)\n";
}
}
$check_dirname_regex = $opt_regex if defined $opt_regex;
if (defined $opt_package) {
- die "$progname: --package requires the use of --watchfile\nas well; run $progname --help for more details\n"
+ uscan_die "$progname: --package requires the use of --watchfile\nas well; run $progname --help for more details\n"
unless defined $opt_watchfile;
$download = -$download unless defined $opt_download;
}
-die "$progname: Can't use --verbose if you're using --dehs!\n"
+uscan_die "$progname: Can't use --verbose if you're using --dehs!\n"
if $verbose and $dehs;
-die "$progname: Can't use --report-status if you're using --verbose!\n"
+uscan_die "$progname: Can't use --report-status if you're using --verbose!\n"
if $verbose and $report;
-die "$progname: Can't use --report-status if you're using --download!\n"
+uscan_die "$progname: Can't use --report-status if you're using --download!\n"
if $download and $report;
-warn "$progname: You're going to get strange (non-XML) output using --debug and --dehs together!\n"
+uscan_warn "$progname: You're going to get strange (non-XML) output using --debug and --dehs together!\n"
if $debug and $dehs;
# We'd better be verbose if we're debugging
@@ -427,7 +423,7 @@
$user_agent->agent($user_agent_string);
if (defined $opt_watchfile) {
- die "Can't have directory arguments if using --watchfile" if @ARGV;
+ uscan_die "Can't have directory arguments if using --watchfile" if @ARGV;
# no directory traversing then, and things are very simple
if (defined $opt_package) {
@@ -436,23 +432,23 @@
} else {
# Check for debian/changelog file
until (-r 'debian/changelog') {
- chdir '..' or die "$progname: can't chdir ..: $!\n";
+ chdir '..' or uscan_die "$progname: can't chdir ..: $!\n";
if (cwd() eq '/') {
- die "$progname: cannot find readable debian/changelog anywhere!\nAre you in the source code tree?\n";
+ uscan_die "$progname: cannot find readable debian/changelog anywhere!\nAre you in the source code tree?\n";
}
}
# Figure out package info we need
my $changelog = `dpkg-parsechangelog`;
unless ($? == 0) {
- die "$progname: Problems running dpkg-parsechangelog\n";
+ uscan_die "$progname: Problems running dpkg-parsechangelog\n";
}
my ($package, $debversion, $uversion);
$changelog =~ /^Source: (.*?)$/m and $package=$1;
$changelog =~ /^Version: (.*?)$/m and $debversion=$1;
if (! defined $package || ! defined $debversion) {
- die "$progname: Problems determining package name and/or version from\n debian/changelog\n";
+ uscan_die "$progname: Problems determining package name and/or version from\n debian/changelog\n";
}
# Check the directory is properly named for safety
@@ -468,7 +464,7 @@
}
}
if (! $good_dirname) {
- die "$progname: not processing watchfile because this directory does not match the package name\n" .
+ uscan_die "$progname: not processing watchfile because this directory does not match the package name\n" .
" or the settings of the--check-dirname-level and --check-dirname-regex options if any.\n";
}
@@ -499,7 +495,7 @@
# otherwise.
my @dirs;
open FIND, '-|', 'find', @ARGV, qw(-follow -type d -name debian -print)
- or die "$progname: couldn't exec find: $!\n";
+ or uscan_die "$progname: couldn't exec find: $!\n";
while (<FIND>) {
chomp;
@@ -507,19 +503,19 @@
}
close FIND;
-die "$progname: No debian directories found\n" unless @dirs;
+uscan_die "$progname: No debian directories found\n" unless @dirs;
my @debdirs = ();
my $origdir = cwd;
for my $dir (@dirs) {
unless (chdir $origdir) {
- warn "$progname warning: Couldn't chdir back to $origdir, skipping: $!\n";
+ uscan_warn "$progname warning: Couldn't chdir back to $origdir, skipping: $!\n";
next;
}
$dir =~ s%/debian$%%;
unless (chdir $dir) {
- warn "$progname warning: Couldn't chdir $dir, skipping: $!\n";
+ uscan_warn "$progname warning: Couldn't chdir $dir, skipping: $!\n";
next;
}
@@ -528,7 +524,7 @@
# Figure out package info we need
my $changelog = `dpkg-parsechangelog`;
unless ($? == 0) {
- warn "$progname warning: Problems running dpkg-parsechangelog in $dir, skipping\n";
+ uscan_warn "$progname warning: Problems running dpkg-parsechangelog in $dir, skipping\n";
next;
}
@@ -536,7 +532,7 @@
$changelog =~ /^Source: (.*?)$/m and $package=$1;
$changelog =~ /^Version: (.*?)$/m and $debversion=$1;
if (! defined $package || ! defined $debversion) {
- warn "$progname warning: Problems determining package name and/or version from\n $dir/debian/changelog, skipping\n";
+ uscan_warn "$progname warning: Problems determining package name and/or version from\n $dir/debian/changelog, skipping\n";
next;
}
@@ -569,23 +565,23 @@
push @debdirs, [$debversion, $dir, $package, $uversion];
}
elsif (-r 'debian/watch') {
- warn "$progname warning: Found watchfile in $dir,\n but couldn't find/read changelog; skipping\n";
+ uscan_warn "$progname warning: Found watchfile in $dir,\n but couldn't find/read changelog; skipping\n";
next;
}
elsif (-f 'debian/watch') {
- warn "$progname warning: Found watchfile in $dir,\n but it is not readable; skipping\n";
+ uscan_warn "$progname warning: Found watchfile in $dir,\n but it is not readable; skipping\n";
next;
}
}
-warn "$progname: no watch file found\n" if (@debdirs == 0 and $report);
+uscan_warn "$progname: no watch file found\n" if (@debdirs == 0 and $report);
# Was there a --uversion option?
if (defined $opt_uversion) {
if (@debdirs == 1) {
$debdirs[0][3] = $opt_uversion;
} else {
- warn "$progname warning: ignoring --uversion as more than one debian/watch file found\n";
+ uscan_warn "$progname warning: ignoring --uversion as more than one debian/watch file found\n";
}
}
@@ -606,16 +602,16 @@
my $version = $$debdir[2];
if (exists $donepkgs{$parentdir}{$package}) {
- warn "$progname warning: Skipping $dir/debian/watch\n as this package has already been scanned successfully\n";
+ uscan_warn "$progname warning: Skipping $dir/debian/watch\n as this package has already been scanned successfully\n";
next;
}
unless (chdir $origdir) {
- warn "$progname warning: Couldn't chdir back to $origdir, skipping: $!\n";
+ uscan_warn "$progname warning: Couldn't chdir back to $origdir, skipping: $!\n";
next;
}
unless (chdir $dir) {
- warn "$progname warning: Couldn't chdir $dir, skipping: $!\n";
+ uscan_warn "$progname warning: Couldn't chdir $dir, skipping: $!\n";
next;
}
@@ -729,13 +725,14 @@
# Comma-separated list of features that sites being queried might
# want to be aware of
$headers->header('X-uscan-features' => 'enhanced-matching');
+ $headers->header('Accept' => '*/*');
%dehs_tags = ('package' => $pkg);
if ($watch_version == 1) {
($site, $dir, $filepattern, $lastversion, $action) = split ' ', $line, 5;
if (! defined $lastversion or $site =~ /\(.*\)/ or $dir =~ /\(.*\)/) {
- warn "$progname warning: there appears to be a version 2 format line in\n the version 1 watchfile $watchfile;\n Have you forgotten a 'version=2' line at the start, perhaps?\n Skipping the line: $line\n";
+ uscan_warn "$progname warning: there appears to be a version 2 format line in\n the version 1 watchfile $watchfile;\n Have you forgotten a 'version=2' line at the start, perhaps?\n Skipping the line: $line\n";
return 1;
}
if ($site !~ m%\w+://%) {
@@ -750,7 +747,7 @@
$filepattern =~ s/\?/./g;
$filepattern =~ s/\*/.*/g;
$style='old';
- warn "$progname warning: Using very old style of filename pattern in $watchfile\n (this might lead to incorrect results): $3\n";
+ uscan_warn "$progname warning: Using very old style of filename pattern in $watchfile\n (this might lead to incorrect results): $3\n";
}
}
@@ -769,7 +766,7 @@
} elsif ($line =~ s/^(\S+)\s+//) {
$opts=$1;
} else {
- warn "$progname warning: malformed opts=... in watchfile, skipping line:\n$origline\n";
+ uscan_warn "$progname warning: malformed opts=... in watchfile, skipping line:\n$origline\n";
return 1;
}
@@ -798,8 +795,11 @@
elsif ($opt =~ /^downloadurlmangle\s*=\s*(.+)/) {
@{$options{'downloadurlmangle'}} = split /;/, $1;
}
+ elsif ($opt =~ /^pgpsigurlmangle\s*=\s*(.+)/) {
+ @{$options{'pgpsigurlmangle'}} = split /;/, $1;
+ }
else {
- warn "$progname warning: unrecognised option $opt\n";
+ uscan_warn "$progname warning: unrecognised option $opt\n";
}
}
}
@@ -815,19 +815,30 @@
}
if ((!$lastversion or $lastversion eq 'debian') and not defined $pkg_version) {
- warn "$progname warning: Unable to determine current version\n in $watchfile, skipping:\n $line\n";
+ uscan_warn "$progname warning: Unable to determine current version\n in $watchfile, skipping:\n $line\n";
return 1;
}
# Check all's OK
if (not $filepattern or $filepattern !~ /\(.*\)/) {
- warn "$progname warning: Filename pattern missing version delimiters ()\n in $watchfile, skipping:\n $line\n";
+ uscan_warn "$progname warning: Filename pattern missing version delimiters ()\n in $watchfile, skipping:\n $line\n";
return 1;
}
# Check validity of options
if ($base =~ /^ftp:/ and exists $options{'downloadurlmangle'}) {
- warn "$progname warning: downloadurlmangle option invalid for ftp sites,\n ignoring in $watchfile:\n $line\n";
+ uscan_warn "$progname warning: downloadurlmangle option invalid for ftp sites,\n ignoring in $watchfile:\n $line\n";
+ }
+
+ # Check validity of options
+ if (exists $options{'pgpsigurlmangle'}) {
+ if (not (-r 'debian/upstream-signing-key.pgp')) {
+ uscan_warn "$progname warning: pgpsigurlmangle option exists, but debian/upstream-signing-key.pgp does not exist,\n ignoring in $watchfile:\n $line\n";
+ delete $options{'pgpsigurlmangle'};
+ } elsif (! $havegpgv) {
+ uscan_warn "$progname warning: pgpsignurlmangle option exists, but you must have gpgv installed to verify\n in $watchfile, skipping:\n $line\n";
+ return 1;
+ }
}
# Handle sf.net addresses specially
@@ -838,7 +849,7 @@
if ($base =~ m%^(\w+://[^/]+)%) {
$site = $1;
} else {
- warn "$progname warning: Can't determine protocol and site in\n $watchfile, skipping:\n $line\n";
+ uscan_warn "$progname warning: Can't determine protocol and site in\n $watchfile, skipping:\n $line\n";
return 1;
}
@@ -858,7 +869,7 @@
if (defined $pkg_version) {
$lastversion=$pkg_version;
} else {
- warn "$progname warning: Unable to determine current version\n in $watchfile, skipping:\n $line\n";
+ uscan_warn "$progname warning: Unable to determine current version\n in $watchfile, skipping:\n $line\n";
return 1;
}
}
@@ -867,7 +878,7 @@
$mangled_lastversion = $lastversion;
foreach my $pat (@{$options{'dversionmangle'}}) {
if (! safe_replace(\$mangled_lastversion, $pat)) {
- warn "$progname: In $watchfile, potentially"
+ uscan_warn "$progname: In $watchfile, potentially"
. " unsafe or malformed dversionmangle"
. " pattern:\n '$pat'"
. " found. Skipping watchline\n"
@@ -882,7 +893,7 @@
# Check all's OK
if ($pattern !~ /\(.*\)/) {
- warn "$progname warning: Filename pattern missing version delimiters ()\n in $watchfile, skipping:\n $line\n";
+ uscan_warn "$progname warning: Filename pattern missing version delimiters ()\n in $watchfile, skipping:\n $line\n";
return 1;
}
@@ -892,16 +903,16 @@
# What is the most recent file, based on the filenames?
# We first have to find the candidates, then we sort them using
- # Devscripts::Versort::versort
+ # Devscripts::Versort::upstream_versort
if ($site =~ m%^http(s)?://%) {
if (defined($1) and !$haveSSL) {
- die "$progname: you must have the libcrypt-ssleay-perl package installed\nto use https URLs\n";
+ uscan_die "$progname: you must have the libcrypt-ssleay-perl package installed\nto use https URLs\n";
}
print STDERR "$progname debug: requesting URL $base\n" if $debug;
$request = HTTP::Request->new('GET', $base, $headers);
$response = $user_agent->request($request);
if (! $response->is_success) {
- warn "$progname warning: In watchfile $watchfile, reading webpage\n $base failed: " . $response->status_line . "\n";
+ uscan_warn "$progname warning: In watchfile $watchfile, reading webpage\n $base failed: " . $response->status_line . "\n";
return 1;
}
@@ -980,7 +991,7 @@
$href =~ m&^$_pattern$&);
foreach my $pat (@{$options{'uversionmangle'}}) {
if (! safe_replace(\$mangled_version, $pat)) {
- warn "$progname: In $watchfile, potentially"
+ uscan_warn "$progname: In $watchfile, potentially"
. " unsafe or malformed uversionmangle"
. " pattern:\n '$pat'"
. " found. Skipping watchline\n"
@@ -996,30 +1007,30 @@
if (@hrefs) {
if ($verbose) {
print "-- Found the following matching hrefs:\n";
- foreach my $href (@hrefs) { print " $$href[1]\n"; }
+ foreach my $href (@hrefs) { print " $$href[1] ($$href[0])\n"; }
}
if (defined $download_version) {
my @vhrefs = grep { $$_[0] eq $download_version } @hrefs;
if (@vhrefs) {
($newversion, $newfile) = @{$vhrefs[0]};
} else {
- warn "$progname warning: In $watchfile no matching hrefs for version $download_version"
+ uscan_warn "$progname warning: In $watchfile no matching hrefs for version $download_version"
. " in watch line\n $line\n";
return 1;
}
} else {
- @hrefs = Devscripts::Versort::versort(@hrefs);
+ @hrefs = Devscripts::Versort::upstream_versort(@hrefs);
($newversion, $newfile) = @{$hrefs[0]};
}
} else {
- warn "$progname warning: In $watchfile,\n no matching hrefs for watch line\n $line\n";
+ uscan_warn "$progname warning: In $watchfile,\n no matching hrefs for watch line\n $line\n";
return 1;
}
}
else {
# Better be an FTP site
if ($site !~ m%^ftp://%) {
- warn "$progname warning: Unknown protocol in $watchfile, skipping:\n $site\n";
+ uscan_warn "$progname warning: Unknown protocol in $watchfile, skipping:\n $site\n";
return 1;
}
@@ -1034,7 +1045,7 @@
else { delete $ENV{'FTP_PASSIVE'}; }
}
if (! $response->is_success) {
- warn "$progname warning: In watchfile $watchfile, reading FTP directory\n $base failed: " . $response->status_line . "\n";
+ uscan_warn "$progname warning: In watchfile $watchfile, reading FTP directory\n $base failed: " . $response->status_line . "\n";
return 1;
}
@@ -1058,7 +1069,7 @@
my $mangled_version = join(".", $file =~ m/^$pattern$/);
foreach my $pat (@{$options{'uversionmangle'}}) {
if (! safe_replace(\$mangled_version, $pat)) {
- warn "$progname: In $watchfile, potentially"
+ uscan_warn "$progname: In $watchfile, potentially"
. " unsafe or malformed uversionmangle"
. " pattern:\n '$pat'"
. " found. Skipping watchline\n"
@@ -1077,7 +1088,7 @@
my $mangled_version = join(".", $file =~ m/^$filepattern$/);
foreach my $pat (@{$options{'uversionmangle'}}) {
if (! safe_replace(\$mangled_version, $pat)) {
- warn "$progname: In $watchfile, potentially"
+ uscan_warn "$progname: In $watchfile, potentially"
. " unsafe or malformed uversionmangle"
. " pattern:\n '$pat'"
. " found. Skipping watchline\n"
@@ -1093,23 +1104,23 @@
if (@files) {
if ($verbose) {
print "-- Found the following matching files:\n";
- foreach my $file (@files) { print " $$file[1]\n"; }
+ foreach my $file (@files) { print " $$file[1] ($$file[0])\n"; }
}
if (defined $download_version) {
my @vfiles = grep { $$_[0] eq $download_version } @files;
if (@vfiles) {
($newversion, $newfile) = @{$vfiles[0]};
} else {
- warn "$progname warning: In $watchfile no matching files for version $download_version"
+ uscan_warn "$progname warning: In $watchfile no matching files for version $download_version"
. " in watch line\n $line\n";
return 1;
}
} else {
- @files = Devscripts::Versort::versort(@files);
+ @files = Devscripts::Versort::upstream_versort(@files);
($newversion, $newfile) = @{$files[0]};
}
} else {
- warn "$progname warning: In $watchfile no matching files for watch line\n $line\n";
+ uscan_warn "$progname warning: In $watchfile no matching files for watch line\n $line\n";
return 1;
}
}
@@ -1124,7 +1135,7 @@
if ($newversion =~ /^\D*(\d+\.(?:\d+\.)*\d+)\D*$/) {
$newversion = $1;
} else {
- warn <<"EOF";
+ uscan_warn <<"EOF";
$progname warning: In $watchfile, couldn\'t determine a
pure numeric version number from the file name for watch line
$line
@@ -1141,7 +1152,7 @@
}
foreach my $pat (@{$options{'filenamemangle'}}) {
if (! safe_replace(\$newfile_base, $pat)) {
- warn "$progname: In $watchfile, potentially"
+ uscan_warn "$progname: In $watchfile, potentially"
. " unsafe or malformed filenamemangle"
. " pattern:\n '$pat'"
. " found. Skipping watchline\n"
@@ -1160,6 +1171,7 @@
# So what have we got to report now?
my $upstream_url;
+ my $pgpsig_url;
# Upstream URL? Copying code from below - ugh.
if ($site =~ m%^https?://%) {
# absolute URL?
@@ -1184,7 +1196,7 @@
}
if (!defined($upstream_url)) {
if ($debug) {
- warn "$progname warning: Unable to determine upstream url from redirections,\n" .
+ uscan_warn "$progname warning: Unable to determine upstream url from redirections,\n" .
"defaulting to using site specified in watchfile\n";
}
$upstream_url = "$sites[0]$newfile";
@@ -1209,7 +1221,7 @@
}
if (!defined($upstream_url)) {
if ($debug) {
- warn "$progname warning: Unable to determine upstream url from redirections,\n" .
+ uscan_warn "$progname warning: Unable to determine upstream url from redirections,\n" .
"defaulting to using site specified in watchfile\n";
}
$upstream_url = "$urlbase$newfile";
@@ -1224,7 +1236,7 @@
if (exists $options{'downloadurlmangle'}) {
foreach my $pat (@{$options{'downloadurlmangle'}}) {
if (! safe_replace(\$upstream_url, $pat)) {
- warn "$progname: In $watchfile, potentially"
+ uscan_warn "$progname: In $watchfile, potentially"
. " unsafe or malformed downloadurlmangle"
. " pattern:\n '$pat'"
. " found. Skipping watchline\n"
@@ -1239,6 +1251,20 @@
$upstream_url = "$base$newfile";
}
+ if (exists $options{'pgpsigurlmangle'}) {
+ $pgpsig_url = $upstream_url;
+ foreach my $pat (@{$options{'pgpsigurlmangle'}}) {
+ if (! safe_replace(\$pgpsig_url, $pat)) {
+ uscan_warn "$progname: In $watchfile, potentially"
+ . " unsafe or malformed pgpsigurlmangle"
+ . " pattern:\n '$pat'"
+ . " found. Skipping watchline\n"
+ . " $line\n";
+ return 1;
+ }
+ }
+ }
+
$dehs_tags{'debian-uversion'} = $lastversion;
$dehs_tags{'debian-mangled-uversion'} = $mangled_lastversion;
$dehs_tags{'upstream-version'} = $newversion;
@@ -1246,7 +1272,7 @@
# Can't just use $lastversion eq $newversion, as then 0.01 and 0.1
# compare different, whereas they are treated as equal by dpkg
- if (system("dpkg", "--compare-versions", "$mangled_lastversion", "eq", "$newversion") == 0) {
+ if (system("dpkg", "--compare-versions", "1:${mangled_lastversion}-0", "eq", "1:${newversion}-0") == 0) {
if ($verbose or ($download == 0 and $report and ! $dehs)) {
print $pkg_report_header;
$pkg_report_header = '';
@@ -1273,7 +1299,7 @@
# We use dpkg's rules to determine whether our current version
# is newer or older than the remote version.
if (!defined $download_version) {
- if (system("dpkg", "--compare-versions", "$mangled_lastversion", "gt", "$newversion") == 0) {
+ if (system("dpkg", "--compare-versions", "1:${mangled_lastversion}-0", "gt", "1:${newversion}-0") == 0) {
if ($verbose) {
print " => remote site does not even have current version\n";
} elsif ($dehs) {
@@ -1346,18 +1372,20 @@
# Download newer package
if ($upstream_url =~ m%^http(s)?://%) {
if (defined($1) and !$haveSSL) {
- die "$progname: you must have the libcrypt-ssleay-perl package installed\nto use https URLs\n";
+ uscan_die "$progname: you must have the libcrypt-ssleay-perl package installed\nto use https URLs\n";
}
# substitute HTML entities
# Is anything else than "&" required? I doubt it.
print STDERR "$progname debug: requesting URL $upstream_url\n" if $debug;
- $request = HTTP::Request->new('GET', $upstream_url);
+ my $headers = HTTP::Headers->new;
+ $headers->header('Accept' => '*/*');
+ $request = HTTP::Request->new('GET', $upstream_url, $headers);
$response = $user_agent->request($request, "$destdir/$newfile_base");
if (! $response->is_success) {
if (defined $pkg_dir) {
- warn "$progname warning: In directory $pkg_dir, downloading\n $upstream_url failed: " . $response->status_line . "\n";
+ uscan_warn "$progname warning: In directory $pkg_dir, downloading\n $upstream_url failed: " . $response->status_line . "\n";
} else {
- warn "$progname warning: Downloading\n $upstream_url failed:\n" . $response->status_line . "\n";
+ uscan_warn "$progname warning: Downloading\n $upstream_url failed:\n" . $response->status_line . "\n";
}
return 1;
}
@@ -1376,12 +1404,33 @@
}
if (! $response->is_success) {
if (defined $pkg_dir) {
- warn "$progname warning: In directory $pkg_dir, downloading\n $upstream_url failed: " . $response->status_line . "\n";
+ uscan_warn "$progname warning: In directory $pkg_dir, downloading\n $upstream_url failed: " . $response->status_line . "\n";
+ } else {
+ uscan_warn "$progname warning: Downloading\n $upstream_url failed:\n" . $response->status_line . "\n";
+ }
+ return 1;
+ }
+ }
+
+ if (defined $pgpsig_url) {
+ print "-- Downloading OpenPGP signature for package as $newfile_base.pgp\n" if $verbose;
+ my $sigrequest = HTTP::Request->new('GET', "$pgpsig_url");
+ my $sigresponse = $user_agent->request($sigrequest, "$destdir/$newfile_base.pgp");
+
+ if (! $sigresponse->is_success) {
+ if (defined $pkg_dir) {
+ uscan_warn "$progname warning: In directory $pkg_dir, downloading OpenPGP signature\n $upstream_url failed: " . $sigresponse->status_line . "\n";
} else {
- warn "$progname warning: Downloading\n $upstream_url failed:\n" . $response->status_line . "\n";
+ uscan_warn "$progname warning: Downloading OpenPGP signature\n $pgpsig_url failed:\n" . $sigresponse->status_line . "\n";
}
return 1;
}
+
+ print "-- Verifying OpenPGP signature $newfile_base.pgp for $newfile_base\n" if $verbose;
+ system('/usr/bin/gpgv', '--homedir', '/dev/null',
+ '--keyring', 'debian/upstream-signing-key.pgp',
+ "$destdir/$newfile_base.pgp", "$destdir/$newfile_base") >> 8 == 0
+ or uscan_die("$progname warning: OpenPGP signature did not verify.\n");
}
if ($repack and $newfile_base =~ /^(.*)\.(tar\.bz2|tbz2?)$/ and
@@ -1428,7 +1477,7 @@
print "-- Repacking from zip to .tar.$repack_compression\n" if $verbose;
system('command -v unzip >/dev/null 2>&1') >> 8 == 0
- or die("unzip binary not found. You need to install the package unzip to be able to repack .zip upstream archives.\n");
+ or uscan_die("unzip binary not found. You need to install the package unzip to be able to repack .zip upstream archives.\n");
my $compress_file_base = "$1.tar" ;
my $newfile_base_compression = "$compress_file_base.".$repack_compression;
@@ -1437,12 +1486,12 @@
my $hidden = ".[!.]*";
my $absdestdir = abs_path($destdir);
system('unzip', '-q', '-a', '-d', $tempdir, "$destdir/$newfile_base") == 0
- or die("Repacking from zip or jar to tar.$repack_compression failed (could not unzip)\n");
+ or uscan_die "Repacking from zip or jar to tar.$repack_compression failed (could not unzip)\n";
if (defined glob("$tempdir/$hidden")) {
$globpattern .= " $hidden";
}
system("cd $tempdir; tar --owner=root --group=root --mode=a+rX -cf \"$absdestdir/$compress_file_base\" $globpattern") == 0
- or die("Repacking from zip or jar to tar.$repack_compression failed (could not create tarball)\n");
+ or uscan_die "Repacking from zip or jar to tar.$repack_compression failed (could not create tarball)\n";
compress_archive("$absdestdir/$compress_file_base", "$absdestdir/$newfile_base_compression", $repack_compression);
$newfile_base = $newfile_base_compression;
}
@@ -1453,7 +1502,7 @@
|tar.xz|txz)$/x) {
my $filetype = `file -b -k \"$destdir/$newfile_base\"`;
unless ($filetype =~ /compressed data/) {
- warn "$progname warning: $destdir/$newfile_base does not appear to be a compressed file;\nthe file command says: $filetype\nNot processing this file any further!\n";
+ uscan_warn "$progname warning: $destdir/$newfile_base does not appear to be a compressed file;\nthe file command says: $filetype\nNot processing this file any further!\n";
return 1;
}
}
@@ -1651,13 +1700,13 @@
if ($site =~ m%^http(s)?://%) {
if (defined($1) and !$haveSSL) {
- die "$progname: you must have the libcrypt-ssleay-perl package installed\nto use https URLs\n";
+ uscan_die "$progname: you must have the libcrypt-ssleay-perl package installed\nto use https URLs\n";
}
print STDERR "$progname debug: requesting URL $base\n" if $debug;
$request = HTTP::Request->new('GET', $base);
$response = $user_agent->request($request);
if (! $response->is_success) {
- warn "$progname warning: In watchfile $watchfile, reading webpage\n $base failed: " . $response->status_line . "\n";
+ uscan_warn "$progname warning: In watchfile $watchfile, reading webpage\n $base failed: " . $response->status_line . "\n";
return 1;
}
@@ -1684,10 +1733,10 @@
}
}
if (@hrefs) {
- @hrefs = Devscripts::Versort::versort(@hrefs);
+ @hrefs = Devscripts::Versort::upstream_versort(@hrefs);
if ($debug) {
print "-- Found the following matching hrefs (newest first):\n";
- foreach my $href (@hrefs) { print " $$href[1]\n"; }
+ foreach my $href (@hrefs) { print " $$href[1] ($$href[0])\n"; }
}
my $newdir = $hrefs[0][1];
# just give the final directory component
@@ -1695,7 +1744,7 @@
$newdir =~ s%^.*/%%;
return $newdir;
} else {
- warn "$progname warning: In $watchfile,\n no matching hrefs for pattern\n $site$dir$pattern";
+ uscan_warn "$progname warning: In $watchfile,\n no matching hrefs for pattern\n $site$dir$pattern";
return 1;
}
}
@@ -1716,7 +1765,7 @@
else { delete $ENV{'FTP_PASSIVE'}; }
}
if (! $response->is_success) {
- warn "$progname warning: In watchfile $watchfile, reading webpage\n $base failed: " . $response->status_line . "\n";
+ uscan_warn "$progname warning: In watchfile $watchfile, reading webpage\n $base failed: " . $response->status_line . "\n";
return '';
}
@@ -1756,11 +1805,11 @@
print STDERR "-- Found the following matching dirs:\n";
foreach my $dir (@dirs) { print STDERR " $$dir[1]\n"; }
}
- @dirs = Devscripts::Versort::versort(@dirs);
+ @dirs = Devscripts::Versort::upstream_versort(@dirs);
my ($newversion, $newdir) = @{$dirs[0]};
return $newdir;
} else {
- warn "$progname warning: In $watchfile no matching dirs for pattern\n $base$pattern\n";
+ uscan_warn "$progname warning: In $watchfile no matching dirs for pattern\n $base$pattern\n";
return '';
}
}
@@ -1776,7 +1825,7 @@
%dehs_tags = ();
unless (open WATCH, $watchfile) {
- warn "$progname warning: could not open $watchfile: $!\n";
+ uscan_warn "$progname warning: could not open $watchfile: $!\n";
return 1;
}
@@ -1789,7 +1838,7 @@
chomp;
if (s/(?<!\\)\\$//) {
if (eof(WATCH)) {
- warn "$progname warning: $watchfile ended with \\; skipping last line\n";
+ uscan_warn "$progname warning: $watchfile ended with \\; skipping last line\n";
$status=1;
last;
}
@@ -1802,12 +1851,12 @@
$watch_version=$1;
if ($watch_version < 2 or
$watch_version > $CURRENT_WATCHFILE_VERSION) {
- warn "$progname ERROR: $watchfile version number is unrecognised; skipping watchfile\n";
+ uscan_warn "$progname ERROR: $watchfile version number is unrecognised; skipping watchfile\n";
last;
}
next;
} else {
- warn "$progname warning: $watchfile is an obsolete version 1 watchfile;\n please upgrade to a higher version\n (see uscan(1) for details).\n";
+ uscan_warn "$progname warning: $watchfile is an obsolete version 1 watchfile;\n please upgrade to a higher version\n (see uscan(1) for details).\n";
$watch_version=1;
}
}
@@ -1830,7 +1879,7 @@
}
close WATCH or
- $status=1, warn "$progname warning: problems reading $watchfile: $!\n";
+ $status=1, uscan_warn "$progname warning: problems reading $watchfile: $!\n";
return $status;
}
@@ -1844,21 +1893,31 @@
push @{$dehs_tags{'messages'}}, $msg;
}
-sub dehs_warn ($)
+sub uscan_warn (@)
{
- my $warning = $_[0];
- $warning =~ s/\s*$//;
- push @{$dehs_tags{'warnings'}}, $warning;
+ if ($dehs) {
+ my $warning = $_[0];
+ $warning =~ s/\s*$//;
+ push @{$dehs_tags{'warnings'}}, $warning;
+ }
+ else {
+ warn @_;
+ }
}
-sub dehs_die ($)
+sub uscan_die (@)
{
- my $msg = $_[0];
- $msg =~ s/\s*$//;
- %dehs_tags = ('errors' => "$msg");
- $dehs_end_output=1;
- dehs_output;
- exit 1;
+ if ($dehs) {
+ my $msg = $_[0];
+ $msg =~ s/\s*$//;
+ %dehs_tags = ('errors' => "$msg");
+ $dehs_end_output=1;
+ dehs_output;
+ exit 1;
+ }
+ else {
+ die @_;
+ }
}
sub dehs_output ()
More information about the devscripts-devel
mailing list