[devscripts] 01/01: Reorganize code for readability
Osamu Aoki
osamu at moszumanska.debian.org
Sat Jan 13 14:07:29 UTC 2018
This is an automated email from the git hooks/post-receive script.
osamu pushed a commit to branch master
in repository devscripts.
commit 37c7e96e6b387144af3a654bc0c19bf5df6026e8
Author: Osamu Aoki <osamu at debian.org>
Date: Sat Jan 13 15:56:56 2018 +0900
Reorganize code for readability
* Move process_watchfile etc., for consistent function order
* Add code block comments with {{{ ... }}} editor jump hints
* Code refactoring around downloader
* Move downloader out of main code path
* Make downloader a simple function
* Remove tailing spaces
* Use consistent sub declaration style
* Use \%options to call, $optref to be called, $$optref to use
Signed-off-by: Osamu Aoki <osamu at debian.org>
---
scripts/uscan.pl | 900 ++++++++++++++++++++++++++++++++-----------------------
1 file changed, 529 insertions(+), 371 deletions(-)
diff --git a/scripts/uscan.pl b/scripts/uscan.pl
index ddf2c76..89f1465 100755
--- a/scripts/uscan.pl
+++ b/scripts/uscan.pl
@@ -22,6 +22,9 @@
# You should have received a copy of the GNU General Public License
# along with this program. If not, see <https://www.gnu.org/licenses/>.
+#######################################################################
+# {{{ code 0: POD for manpage
+#######################################################################
=pod
=head1 NAME
@@ -825,7 +828,7 @@ signature file in the unrelated file path.
files/(?:\d+)/@PACKAGE@@ANY_VERSION@@SIGNATURE_EXT@ previous uupdate
B<(?:\d+)> part can be any random value. The tarball file can have B<53>,
-while the signature file can have B<33>.
+while the signature file can have B<33>.
B<([\d\.]+)> part for the signature file has a strict requirement to match that
for the upstream tarball specified in the previous line by having B<previous>
@@ -867,7 +870,7 @@ their signature files.
=head2 HTTP site (recursive directory scanning)
-Here is an example with the recursive directory scanning for the upstream tarball
+Here is an example with the recursive directory scanning for the upstream tarball
and its signature files released in a directory named
after their version.
@@ -1152,8 +1155,8 @@ and other stanzas.):
...
Here is another example for the F<debian/copyright> file which initiates
-automatic repackaging of the multiple upstream tarballs into
-I<< <spkg>_<oversion>.orig.tar.gz >> and
+automatic repackaging of the multiple upstream tarballs into
+I<< <spkg>_<oversion>.orig.tar.gz >> and
I<< <spkg>_<oversion>.orig-bar.tar.gz >>:
Format: http://www.debian.org/doc/packaging-manuals/copyright-format/1.0/
@@ -1521,7 +1524,7 @@ equivalent to the B<--destdir> option.
If this is set to yes, then after having downloaded a bzip tar, lzma tar, xz
tar, or zip archive, uscan will repack it to the specified compression (see
-B<--compression>). This is equivalent to the B<--repack> option.
+B<--compression>). This is equivalent to the B<--repack> option.
=item B<USCAN_EXCLUSION>
@@ -1620,7 +1623,7 @@ Never check the directory name.
Only check the directory name if we have had to change directory in
our search for F<debian/changelog>, that is, the directory containing
-F<debian/changelog> is not the directory from which B<uscan> was invoked.
+F<debian/changelog> is not the directory from which B<uscan> was invoked.
This is the default behavior.
=item B<2>
@@ -1721,6 +1724,13 @@ Gilbey.
=cut
+#######################################################################
+# }}} code 0: POD for manpage
+#######################################################################
+#######################################################################
+# {{{ code 1: initializer, command parser, and loop over watchfiles
+#######################################################################
+
use 5.010; # defined-or (//)
use strict;
use warnings;
@@ -1754,8 +1764,26 @@ BEGIN {
}
}
-sub uscan_die ($);
+sub process_watchfile ($$$$);
+sub process_watchline ($$$$$$);
+sub printwarn ($);
+sub uscan_msg($);
+sub uscan_verbose($);
+sub dehs_verbose ($);
sub uscan_warn ($);
+sub uscan_debug($);
+sub uscan_die ($);
+sub dehs_output ();
+sub fix_href ($);
+sub downloader ($$$$$);
+sub recursive_regex_dir ($$$);
+sub newest_dir ($$$$$);
+sub get_compression ($);
+sub get_suffix ($);
+sub get_priority ($);
+sub quoted_regex_parse($);
+sub safe_replace($$);
+
# From here, do not use bare "warn" nor "die".
# Use "uscan_warn" or "uscan_die" instead to make --dehs work as expected.
@@ -1774,22 +1802,6 @@ if ($@) {
# Did we find any new upstream versions on our wanderings?
our $found = 0;
-sub process_watchline ($$$$$$);
-sub process_watchfile ($$$$);
-sub get_compression ($);
-sub get_suffix ($);
-sub get_priority ($);
-sub recursive_regex_dir ($$$);
-sub newest_dir ($$$$$);
-sub dehs_output ();
-sub quoted_regex_replace ($);
-sub safe_replace ($$);
-sub printwarn($);
-sub uscan_msg($);
-sub uscan_verbose($);
-sub uscan_debug($);
-sub dehs_verbose ($);
-
my $havegpgv = first { !system('sh', '-c', "command -v $_ >/dev/null 2>&1") } qw(gpgv2 gpgv);
my $havegpg = first { !system('sh', '-c', "command -v $_ >/dev/null 2>&1") } qw(gpg2 gpg);
uscan_die "Please install gpgv or gpgv2.\n" unless defined $havegpgv;
@@ -2108,12 +2120,12 @@ $safe = 1 if defined $opt_safe;
$download = 0 if $safe == 1;
# $download: 0 = no-download,
-# 1 = download (default, only-new),
+# 1 = download (default, only-new),
# 2 = force-download (even if file is up-to-date version),
# 3 = overwrite-download (even if file exists)
$download = $opt_download if defined $opt_download;
-# $signature: -1 = no downloading signature and no verifying signature,
-# 0 = no downloading signature but verifying signature,
+# $signature: -1 = no downloading signature and no verifying signature,
+# 0 = no downloading signature but verifying signature,
# 1 = downloading signature and verifying signature
$signature = -1 if $download== 0; # Change default 1 -> -1
$signature = $opt_signature if defined $opt_signature;
@@ -2415,9 +2427,139 @@ $dehs_end_output=1;
dehs_output if $dehs;
exit ($found ? 0 : 1);
+#######################################################################
+# }}} code 1: initializer, command parser, and loop over watchfiles
+#######################################################################
+#######################################################################
+# {{{ code 2: process watchfile by looping over watchline
+#######################################################################
-# This is the heart of the code: Process a single watch line
-#
+# parameters are dir, package, upstream version, good dirname
+sub process_watchfile ($$$$)
+{
+ my ($dir, $package, $version, $watchfile) = @_;
+ my $watch_version=0;
+ my $status=0;
+ my $nextline;
+ %dehs_tags = ();
+ @origtars = ();
+
+ uscan_verbose "Process $dir/$watchfile (package=$package version=$version)\n";
+
+ # set $keyring: upstream/signing-key.pgp and upstream-signing-key.pgp are deprecated but supported
+ if ( -r "debian/upstream/signing-key.asc") {
+ $keyring = "debian/upstream/signing-key.asc";
+ } else {
+ my $binkeyring = first { -r $_ } qw(debian/upstream/signing-key.pgp debian/upstream-signing-key.pgp);
+ if (defined $binkeyring) {
+ make_path('debian/upstream', 0700, 'true');
+ # convert to the policy complying armored key
+ uscan_verbose "Found upstream binary signing keyring: $binkeyring\n";
+ # Need to convert to an armored key
+ $keyring = "debian/upstream/signing-key.asc";
+ spawn(exec => [$havegpg, '--homedir', "/dev/null",
+ '--no-options', '-q', '--batch',
+ '--no-default-keyring', '--output',
+ $keyring, '--enarmor', $binkeyring],
+ wait_child => 1);
+ uscan_warn "Generated upstream signing keyring: $keyring\n";
+ move $binkeyring, "$binkeyring.backup";
+ uscan_verbose "Renamed upstream binary signing keyring: $binkeyring.backup\n";
+ }
+ }
+ if (defined $keyring) {
+ uscan_verbose "Found upstream signing keyring: $keyring\n";
+ if ($keyring =~ m/\.asc$/) { # always true
+ # Need to convert an armored key to binary for use by gpgv
+ $gpghome = tempdir(CLEANUP => 1);
+ my $newkeyring = "$gpghome/trustedkeys.gpg";
+ spawn(exec => [$havegpg, '--homedir', $gpghome,
+ '--no-options', '-q', '--batch',
+ '--no-default-keyring', '--output',
+ $newkeyring, '--dearmor', $keyring],
+ wait_child => 1);
+ $keyring = $newkeyring
+ }
+ }
+
+ $origcount = 0; # reset to 0 for each watch file
+ unless (open WATCH, $watchfile) {
+ uscan_warn "could not open $watchfile: $!\n";
+ return 1;
+ }
+
+ while (<WATCH>) {
+ next if /^\s*\#/;
+ next if /^\s*$/;
+ s/^\s*//;
+
+ CHOMP:
+ chomp;
+ if (s/(?<!\\)\\$//) {
+ if (eof(WATCH)) {
+ uscan_warn "$watchfile ended with \\; skipping last line\n";
+ $status=1;
+ last;
+ }
+ if ($watch_version > 3) {
+ # drop leading \s only if version 4
+ $nextline = <WATCH>;
+ $nextline =~ s/^\s*//;
+ $_ .= $nextline;
+ } else {
+ $_ .= <WATCH>;
+ }
+ goto CHOMP;
+ }
+
+ if (! $watch_version) {
+ if (/^version\s*=\s*(\d+)(\s|$)/) {
+ $watch_version=$1;
+ if ($watch_version < 2 or
+ $watch_version > $CURRENT_WATCHFILE_VERSION) {
+ uscan_warn "$watchfile version number is unrecognised; skipping watch file\n";
+ last;
+ }
+ next;
+ } else {
+ uscan_warn "$watchfile is an obsolete version 1 watch file;\n please upgrade to a higher version\n (see uscan(1) for details).\n";
+ $watch_version=1;
+ }
+ }
+
+ # Are there any warnings from this part to give if we're using dehs?
+ dehs_output if $dehs;
+
+ # Handle shell \\ -> \
+ s/\\\\/\\/g if $watch_version==1;
+
+ # Handle @PACKAGE@ @ANY_VERSION@ @ARCHIVE_EXT@ substitutions
+ my $any_version = '[-_]?(\d[\-+\.:\~\da-zA-Z]*)';
+ my $archive_ext = '(?i)\.(?:tar\.xz|tar\.bz2|tar\.gz|zip)';
+ my $signature_ext = $archive_ext . '\.(?:asc|pgp|gpg|sig|sign)';
+ s/\@PACKAGE\@/$package/g;
+ s/\@ANY_VERSION\@/$any_version/g;
+ s/\@ARCHIVE_EXT\@/$archive_ext/g;
+ s/\@SIGNATURE_EXT\@/$signature_ext/g;
+
+ $status +=
+ process_watchline($_, $watch_version, $dir, $package, $version,
+ $watchfile);
+ dehs_output if $dehs;
+ }
+
+ close WATCH or
+ $status=1, uscan_warn "problems reading $watchfile: $!\n";
+
+ return $status;
+}
+#######################################################################
+# }}} code 2: process watchfile by looping over watchline
+#######################################################################
+
+#######################################################################
+# {{{ code 3: process watchline
+#######################################################################
# watch_version=1: Lines have up to 5 parameters which are:
#
# $1 = Remote site
@@ -2446,6 +2588,9 @@ exit ($found ? 0 : 1);
sub process_watchline ($$$$$$)
{
+#######################################################################
+# {{{ code 3.0: initializer and watchline parser
+#######################################################################
my ($line, $watch_version, $pkg_dir, $pkg, $pkg_version, $watchfile) = @_;
# $line watch line string
# $watch_version usually 4 (or 3)
@@ -2859,7 +3004,17 @@ sub process_watchline ($$$$$$)
# We first have to find the candidates, then we sort them using
# Devscripts::Versort::upstream_versort (if it is real upstream version string) or
# Devscripts::Versort::versort (if it is suffixed upstream version string)
+#######################################################################
+# }}} code 3.0: initializer and watchline parser
+#######################################################################
+
+#######################################################################
+# {{{ code 3.1: search $newversion, $newfile in $content
+#######################################################################
if ($options{'mode'} eq 'git') {
+#######################################################################
+# {{{ code 3.1.1: search $newversion, $newfile (git mode)
+#######################################################################
# TODO: sanitize $base
uscan_verbose "Execute: git ls-remote $base\n";
open(REFS, "-|", 'git', 'ls-remote', $base) ||
@@ -2918,7 +3073,13 @@ sub process_watchline ($$$$$$)
" $line\n";
return 1;
}
+#######################################################################
+# }}} code 3.1.1: search $newversion, $newfile (git mode)
+#######################################################################
} elsif ($site =~ m%^http(s)?://%) {
+#######################################################################
+# {{{ code 3.1.2: search $newversion, $newfile (http mode)
+#######################################################################
# HTTP site
if (defined($1) and !$haveSSL) {
uscan_die "you must have the liblwp-protocol-https-perl package installed\nto use https URLs\n";
@@ -3009,7 +3170,6 @@ sub process_watchline ($$$$$$)
while ($content =~ m/<\s*a\s+[^>]*href\s*=\s*([\"\'])(.*?)\1/sgi) {
my $href = $2;
my $mangled_version;
- $href =~ s/\n//g;
$href = fix_href($href);
if (exists $options{'hrefdecode'}) {
if ($options{'hrefdecode'} eq 'percent-encoding') {
@@ -3088,7 +3248,13 @@ sub process_watchline ($$$$$$)
return 1;
}
}
+#######################################################################
+# }}} code 3.1.2: search $newversion, $newfile (http mode)
+#######################################################################
} elsif ($site =~ m%^ftp://%) {
+#######################################################################
+# {{{ code 3.1.3: search $newversion, $newfile (ftp mode)
+#######################################################################
# FTP site
if (exists $options{'pasv'}) {
$ENV{'FTP_PASSIVE'}=$options{'pasv'};
@@ -3137,7 +3303,7 @@ sub process_watchline ($$$$$$)
}
uscan_debug "$mangled_version by uversionmangle rule.\n";
}
- $match = '';
+ $match = '';
if (defined $download_version) {
if ($mangled_version eq $download_version) {
$match = "matched with the download version";
@@ -3168,7 +3334,7 @@ sub process_watchline ($$$$$$)
}
uscan_debug "$mangled_version by uversionmangle rule.\n";
}
- $match = '';
+ $match = '';
if (defined $download_version) {
if ($mangled_version eq $download_version) {
$match = "matched with the download version";
@@ -3204,17 +3370,32 @@ sub process_watchline ($$$$$$)
return 1;
}
}
+#######################################################################
+# }}} code 3.1.3: search $newversion, $newfile (ftp mode)
+#######################################################################
} else {
+#######################################################################
+# {{{ code 3.1.4: search $newversion, $newfile (non-existing mode)
+#######################################################################
if ($options{'mode'} eq 'LWP') {
- # Neither HTTP nor FTP
+ # mode=LWP but neither HTTP nor FTP
uscan_warn "Unknown protocol in $watchfile, skipping:\n $site\n";
} else {
uscan_warn "Unknown mode=$options{'mode'} set in $watchfile\n";
}
return 1;
+#######################################################################
+# }}} code 3.1.4: search $newversion, $newfile (non-existing mode)
+#######################################################################
}
# End Checking $site and look for $filepattern which is newer than $lastversion
+#######################################################################
+# }}} code 3.1: search $newversion, $newfile in $content
+#######################################################################
+#######################################################################
+# {{{ code 3.2: watchfile version=1 and older backward compatibility
+#######################################################################
# The original version of the code didn't use (...) in the watch
# file to delimit the version number; thus if there is no (...)
# in the pattern, we will use the old heuristics, otherwise we
@@ -3235,13 +3416,28 @@ EOF
return 1;
}
}
-
- # Determin download URL for tarball or signature
+#######################################################################
+# }}} code 3.2: watchfile version=1 and older backward compatibility
+#######################################################################
+
+#######################################################################
+# {{{ code 3.3: determine $upstream_url
+#######################################################################
+ # Determine download URL for tarball or signature
my $upstream_url;
# Upstream URL? Copying code from below - ugh.
if ($options{'mode'} eq 'git') {
+#######################################################################
+# {{{ code 3.3.1: determine $upstream_url (git mode)
+#######################################################################
$upstream_url = "$base $newfile";
+#######################################################################
+# }}} code 3.3.1: determine $upstream_url (git mode)
+#######################################################################
} elsif ($site =~ m%^https?://%) {
+#######################################################################
+# {{{ code 3.3.2: determine $upstream_url (http mode)
+#######################################################################
# absolute URL?
if ($newfile =~ m%^\w+://%) {
$upstream_url = $newfile;
@@ -3308,12 +3504,26 @@ EOF
uscan_debug "$upstream_url by downloadurlmangle rule.\n";
}
}
+#######################################################################
+# }}} code 3.3.2: determine $upstream_url (http mode)
+#######################################################################
} else {
- # FTP site
+#######################################################################
+# {{{ code 3.3.3: determine $upstream_url (ftp mode)
+#######################################################################
$upstream_url = "$base$newfile";
+#######################################################################
+# }}} code 3.3.3: determine $upstream_url (ftp mode)
+#######################################################################
}
uscan_verbose "Upstream URL (downloadurlmangled):\n $upstream_url\n";
+#######################################################################
+# }}} code 3.3: determine $upstream_url
+#######################################################################
+#######################################################################
+# {{{ code 3.4: determine $newversion and $newfile_base
+#######################################################################
# $newversion = version used for pkg-ver.tar.gz and version comparison
uscan_verbose "Newest upstream tarball version selected for download (uversionmangled): $newversion\n" if $newversion;
@@ -3365,6 +3575,13 @@ EOF
}
}
uscan_verbose "Download filename (filenamemangled): $newfile_base\n";
+#######################################################################
+# }}} code 3.4: determine $newversion and $newfile_base
+#######################################################################
+
+#######################################################################
+# {{{ code 3.5: compare $newversion against $mangled_lastversion
+#######################################################################
unless (defined $common_newversion) {
$common_newversion = $newversion;
}
@@ -3441,91 +3658,13 @@ EOF
{
return 0;
}
+#######################################################################
+# }}} code 3.5: compare $newversion against $mangled_lastversion
+#######################################################################
- ############################# BEGIN SUB DOWNLOAD ##################################
- my $downloader = sub {
- my ($url, $fname, $mode) = @_;
- if ($mode eq 'git') {
- my $curdir = cwd();
- $fname =~ m%(.*)/([^/]*)-([^_/-]*)\.tar\.(gz|xz|bz2|lzma)%;
- my $dst = $1;
- my $pkg = $2;
- my $ver = $3;
- my $suffix = $4;
- my ($gitrepo, $gitref) = split /[[:space:]]+/, $url, 2;
- my $gitrepodir = "$pkg.$$.git";
- uscan_verbose "Execute: git clone --bare $gitrepo $dst/$gitrepodir\n";
- system('git', 'clone', '--bare', $gitrepo, "$dst/$gitrepodir") == 0 or uscan_die("git clone failed\n");
- chdir "$dst/$gitrepodir" or uscan_die("Unable to chdir(\"$dst/$gitrepodir\"): $!\n");
- uscan_verbose "Execute: git archive --format=tar --prefix=$pkg-$ver/ --output=$curdir/$dst/$pkg-$ver.tar $gitref\n";
- system('git', 'archive', '--format=tar', "--prefix=$pkg-$ver/", "--output=$curdir/$dst/$pkg-$ver.tar", $gitref) == 0 or uscan_die("git archive failed\n");;
- chdir "$curdir/$dst" or uscan_die("Unable to chdir($curdir/$dst): $!\n");
- if ($suffix eq 'gz') {
- uscan_verbose "Execute: gzip -n -9 $pkg-$ver.tar\n";
- system("gzip", "-n", "-9", "$pkg-$ver.tar") == 0 or uscan_die("gzip failed\n");
- } elsif ($suffix eq 'xz') {
- uscan_verbose "Execute: xz $pkg-$ver.tar\n";
- system("xz", "$pkg-$ver.tar") == 0 or uscan_die("xz failed\n");
- } elsif ($suffix eq 'bz2') {
- uscan_verbose "Execute: bzip2 $pkg-$ver.tar\n";
- system("bzip2", "$pkg-$ver.tar") == 0 or uscan_die("bzip2 failed\n");
- } elsif ($suffix eq 'lzma') {
- uscan_verbose "Execute: lzma $pkg-$ver.tar\n";
- system("lzma", "$pkg-$ver.tar") == 0 or uscan_die("lzma failed\n");
- } else {
- uscan_warn "Unknown suffix file to repack: $suffix\n";
- exit 1;
- }
- chdir "$curdir" or uscan_die("Unable to chdir($curdir): $!\n");
- } elsif ($url =~ m%^http(s)?://%) {
- if (defined($1) and !$haveSSL) {
- uscan_die "$progname: you must have the liblwp-protocol-https-perl package installed\nto use https URLs\n";
- }
- # substitute HTML entities
- # Is anything else than "&" required? I doubt it.
- uscan_verbose "Requesting URL:\n $url\n";
- my $headers = HTTP::Headers->new;
- $headers->header('Accept' => '*/*');
- $headers->header('Referer' => $base);
- $request = HTTP::Request->new('GET', $url, $headers);
- $response = $user_agent->request($request, $fname);
- if (! $response->is_success) {
- if (defined $pkg_dir) {
- uscan_warn "In directory $pkg_dir, downloading\n $url failed: " . $response->status_line . "\n";
- } else {
- uscan_warn "Downloading\n $url failed:\n" . $response->status_line . "\n";
- }
- return 0;
- }
- } else {
- # FTP site
- if (exists $options{'pasv'}) {
- $ENV{'FTP_PASSIVE'}=$options{'pasv'};
- }
- uscan_verbose "Requesting URL:\n $url\n";
- $request = HTTP::Request->new('GET', "$url");
- $response = $user_agent->request($request, $fname);
- if (exists $options{'pasv'}) {
- if (defined $passive) {
- $ENV{'FTP_PASSIVE'}=$passive;
- } else {
- delete $ENV{'FTP_PASSIVE'};
- }
- }
- if (! $response->is_success) {
- if (defined $pkg_dir) {
- uscan_warn "In directory $pkg_dir, downloading\n $url failed: " . $response->status_line . "\n";
- } else {
- uscan_warn "Downloading\n $url failed:\n" . $response->status_line . "\n";
- }
- return 0;
- }
- }
- return 1;
- };
- ############################# END SUB DOWNLOAD ##################################
-
- # Download tarball
+#######################################################################
+# {{{ code 3.6: download tarball
+#######################################################################
my $download_available;
my $signature_available;
my $sigfile;
@@ -3534,7 +3673,7 @@ EOF
# try download package
if ( $download == 3 and -e "$destdir/$newfile_base") {
uscan_verbose "Downloading and overwriting existing file: $newfile_base\n";
- $download_available = $downloader->($upstream_url, "$destdir/$newfile_base", $options{'mode'});
+ $download_available = downloader($upstream_url, "$destdir/$newfile_base", \%options, $base, $pkg_dir);
if ($download_available) {
dehs_verbose "Successfully downloaded package: $newfile_base\n";
} else {
@@ -3545,7 +3684,7 @@ EOF
dehs_verbose "Not downloading, using existing file: $newfile_base\n";
} elsif ($download >0) {
uscan_verbose "Downloading upstream package: $newfile_base\n";
- $download_available = $downloader->($upstream_url, "$destdir/$newfile_base", $options{'mode'});
+ $download_available = downloader($upstream_url, "$destdir/$newfile_base", \%options, $base, $pkg_dir);
if ($download_available) {
dehs_verbose "Successfully downloaded package: $newfile_base\n";
} else {
@@ -3625,8 +3764,13 @@ EOF
}
}
}
+#######################################################################
+# }}} code 3.6: download tarball
+#######################################################################
- # Download signature
+#######################################################################
+# {{{ code 3.7: download signature
+#######################################################################
my $pgpsig_url;
my $suffix_sig;
if (($options{'pgpmode'} eq 'default' or $options{'pgpmode'} eq 'auto') and $signature == 1) {
@@ -3674,7 +3818,7 @@ EOF
$sigfile = "$sigfile_base.$suffix_sig";
if ($signature == 1) {
uscan_verbose "Downloading OpenPGP signature from\n $pgpsig_url (pgpsigurlmangled)\n as $sigfile\n";
- $signature_available = $downloader->($pgpsig_url, "$destdir/$sigfile", $options{'mode'});
+ $signature_available = downloader($pgpsig_url, "$destdir/$sigfile", \%options, $base, $pkg_dir);
} else { # -1, 0
uscan_verbose "Not downloading OpenPGP signature from\n $pgpsig_url (pgpsigurlmangled)\n as $sigfile\n";
$signature_available = (-e "$destdir/$sigfile") ? 1 : 0;
@@ -3684,7 +3828,7 @@ EOF
$sigfile = $newfile_base;
if ($signature == 1) {
uscan_verbose "Downloading OpenPGP signature from\n $pgpsig_url (pgpmode=previous)\n as $sigfile\n";
- $signature_available = $downloader->($pgpsig_url, "$destdir/$sigfile", $options{'mode'});
+ $signature_available = downloader($pgpsig_url, "$destdir/$sigfile", \%options, $base, $pkg_dir);
} else { # -1, 0
uscan_verbose "Not downloading OpenPGP signature from\n $pgpsig_url (pgpmode=previous)\n as $sigfile\n";
$signature_available = (-e "$destdir/$sigfile") ? 1 : 0;
@@ -3694,8 +3838,13 @@ EOF
$sigfile_base = $previous_sigfile_base;
uscan_verbose "Use $newfile_base as upstream package (pgpmode=previous)\n";
}
+#######################################################################
+# }}} code 3.7: download signature
+#######################################################################
- # Signature check
+#######################################################################
+# {{{ code 3.8: signature verification (pgpmode)
+#######################################################################
if ($options{'pgpmode'} eq 'mangle' or $options{'pgpmode'} eq 'previous') {
if ($signature == -1) {
uscan_verbose("SKIP Checking OpenPGP signature (by request).\n");
@@ -3748,7 +3897,6 @@ EOF
uscan_warn "strange ... unknown pgpmode = $options{'pgpmode'}\n";
return 1;
}
-
my $mangled_newversion = $newversion;
foreach my $pat (@{$options{'oversionmangle'}}) {
if (! safe_replace(\$mangled_newversion, $pat)) {
@@ -3769,7 +3917,6 @@ EOF
# MUT disables repacksuffix so it is safe to have this before mk-origtargz
$common_mangled_newversion = $mangled_newversion;
}
-
if ($options{'pgpmode'} eq 'next') {
uscan_verbose "Read the next watch line (pgpmode=next)\n";
return 0;
@@ -3789,6 +3936,13 @@ EOF
if ($signature_available == 1 and $options{'decompress'}) {
$signature_available = 2;
}
+#######################################################################
+# }}} code 3.8: signature verification (pgpmode)
+#######################################################################
+
+#######################################################################
+# {{{ code 3.9: call mk-origtargz
+#######################################################################
#########################################################################
# upstream tar file and, if available, signature file are downloaded
# by parsing a watch file line.
@@ -3798,11 +3952,11 @@ EOF
# * for pgpmode=self -- the tarball as gpg extracted
# * for other cases -- the tarball as downloaded
# signature file: $destdir/$sigfile"
- # * for $signature_available = 0 -- no signature file
+ # * for $signature_available = 0 -- no signature file
# * for $signature_available = 1 -- normal signature file
# * for $signature_available = 2 -- signature file on decompressed
# * for $signature_available = 3 -- non-detached signature (XXX FIXME XXX)
- # If pgpmode=self case in the above is fixed, below
+ # If pgpmode=self case in the above is fixed, below
# " and ($options{'pgpmode'} ne 'self')" may be dropped.
# New version after making the new orig[-component].tar.gz:
# $common_mangled_newversion
@@ -3822,7 +3976,7 @@ EOF
push @cmd, "--copy" if $symlink eq "copy";
push @cmd, "--signature", $signature_available
if ($signature_available != 0);
- push @cmd, "--signature-file", "$destdir/$sigfile"
+ push @cmd, "--signature-file", "$destdir/$sigfile"
if ($signature_available != 0);
push @cmd, "--repack" if $options{'repack'};
push @cmd, "--component", $options{'component'} if defined $options{'component'};
@@ -3891,7 +4045,13 @@ EOF
dehs_verbose "$mk_origtargz_out\n" if defined $mk_origtargz_out;
$dehs_tags{target} = $target;
$dehs_tags{'target-path'} = $path;
+#######################################################################
+# }}} code 3.9: call mk-origtargz
+#######################################################################
+#######################################################################
+# {{{ code 3.10: call uupdate
+#######################################################################
# Do whatever the user wishes to do
if ($action) {
my @cmd = shellwords($action);
@@ -3935,24 +4095,229 @@ EOF
}
return 0;
+#######################################################################
+# }}} code 3.10: call uupdate
+#######################################################################
}
+#######################################################################
+# }}} code 3: process watchline
+#######################################################################
-
-sub recursive_regex_dir ($$$) {
- # If return '', parent code to cause return 1
- my ($base, $optref, $watchfile)=@_;
-
- $base =~ m%^(\w+://[^/]+)/(.*)$%;
- my $site = $1;
- my @dirs = ();
- if (defined $2) {
- @dirs = split /(\/)/, $2;
+#######################################################################
+# {{{ code 4: utility functions (message)
+#######################################################################
+# Message handling
+sub printwarn ($)
+{
+ my $msg = $_[0];
+ if ($dehs) {
+ warn $msg;
+ } else {
+ print $msg;
}
- my $dir = '/';
+}
- foreach my $dirpattern (@dirs) {
- if ($dirpattern =~ /\(.*\)/) {
- uscan_verbose "dir=>$dir dirpattern=>$dirpattern\n";
+sub uscan_msg($)
+{
+ my $msg = $_[0];
+ printwarn "$progname: $msg";
+}
+
+sub uscan_verbose($)
+{
+ my $msg = $_[0];
+ if ($verbose > 0) {
+ printwarn "$progname info: $msg";
+ }
+}
+
+sub dehs_verbose ($)
+{
+ my $msg = $_[0];
+ push @{$dehs_tags{'messages'}}, $msg;
+ uscan_verbose($msg)
+}
+
+sub uscan_warn ($)
+{
+ my $msg = $_[0];
+ push @{$dehs_tags{'warnings'}}, $msg if $dehs;
+ warn "$progname warn: $msg";
+}
+
+sub uscan_debug($)
+{
+ my $msg = $_[0];
+ warn "$progname debug: $msg" if $verbose > 1;
+}
+
+sub uscan_die ($)
+{
+ my $msg = $_[0];
+ if ($dehs) {
+ %dehs_tags = ('errors' => "$msg");
+ $dehs_end_output=1;
+ dehs_output;
+ }
+ die "$progname die: $msg";
+}
+
+sub dehs_output ()
+{
+ return unless $dehs;
+
+ if (! $dehs_start_output) {
+ print "<dehs>\n";
+ $dehs_start_output=1;
+ }
+
+ for my $tag (qw(package debian-uversion debian-mangled-uversion
+ upstream-version upstream-url
+ status target target-path messages warnings errors)) {
+ if (exists $dehs_tags{$tag}) {
+ if (ref $dehs_tags{$tag} eq "ARRAY") {
+ foreach my $entry (@{$dehs_tags{$tag}}) {
+ $entry =~ s/</</g;
+ $entry =~ s/>/>/g;
+ $entry =~ s/&/&/g;
+ print "<$tag>$entry</$tag>\n";
+ }
+ } else {
+ $dehs_tags{$tag} =~ s/</</g;
+ $dehs_tags{$tag} =~ s/>/>/g;
+ $dehs_tags{$tag} =~ s/&/&/g;
+ print "<$tag>$dehs_tags{$tag}</$tag>\n";
+ }
+ }
+ }
+ if ($dehs_end_output) {
+ print "</dehs>\n";
+ }
+
+ # Don't repeat output
+ %dehs_tags = ();
+}
+#######################################################################
+# }}} code 4: utility functions (message)
+#######################################################################
+
+#######################################################################
+# {{{ code 5: utility functions (download)
+#######################################################################
+sub fix_href ($)
+{
+ my ($href) = @_;
+
+ # Remove newline (code moved from outside fix_href)
+ $href =~ s/\n//g;
+
+ # Remove whitespace from URLs:
+ # https://www.w3.org/TR/html5/links.html#links-created-by-a-and-area-elements
+ $href =~ s/^\s+//;
+ $href =~ s/\s+$//;
+
+ return $href;
+}
+
+sub downloader ($$$$$)
+{
+ my ($url, $fname, $optref, $base, $pkg_dir) = @_;
+ my ($request, $response);
+ if ($$optref{'mode'} eq 'git') {
+ my $curdir = cwd();
+ $fname =~ m%(.*)/([^/]*)-([^_/-]*)\.tar\.(gz|xz|bz2|lzma)%;
+ my $dst = $1;
+ my $pkg = $2;
+ my $ver = $3;
+ my $suffix = $4;
+ my ($gitrepo, $gitref) = split /[[:space:]]+/, $url, 2;
+ my $gitrepodir = "$pkg.$$.git";
+ uscan_verbose "Execute: git clone --bare $gitrepo $dst/$gitrepodir\n";
+ system('git', 'clone', '--bare', $gitrepo, "$dst/$gitrepodir") == 0 or uscan_die("git clone failed\n");
+ chdir "$dst/$gitrepodir" or uscan_die("Unable to chdir(\"$dst/$gitrepodir\"): $!\n");
+ uscan_verbose "Execute: git archive --format=tar --prefix=$pkg-$ver/ --output=$curdir/$dst/$pkg-$ver.tar $gitref\n";
+ system('git', 'archive', '--format=tar', "--prefix=$pkg-$ver/", "--output=$curdir/$dst/$pkg-$ver.tar", $gitref) == 0 or uscan_die("git archive failed\n");;
+ chdir "$curdir/$dst" or uscan_die("Unable to chdir($curdir/$dst): $!\n");
+ if ($suffix eq 'gz') {
+ uscan_verbose "Execute: gzip -n -9 $pkg-$ver.tar\n";
+ system("gzip", "-n", "-9", "$pkg-$ver.tar") == 0 or uscan_die("gzip failed\n");
+ } elsif ($suffix eq 'xz') {
+ uscan_verbose "Execute: xz $pkg-$ver.tar\n";
+ system("xz", "$pkg-$ver.tar") == 0 or uscan_die("xz failed\n");
+ } elsif ($suffix eq 'bz2') {
+ uscan_verbose "Execute: bzip2 $pkg-$ver.tar\n";
+ system("bzip2", "$pkg-$ver.tar") == 0 or uscan_die("bzip2 failed\n");
+ } elsif ($suffix eq 'lzma') {
+ uscan_verbose "Execute: lzma $pkg-$ver.tar\n";
+ system("lzma", "$pkg-$ver.tar") == 0 or uscan_die("lzma failed\n");
+ } else {
+ uscan_warn "Unknown suffix file to repack: $suffix\n";
+ exit 1;
+ }
+ chdir "$curdir" or uscan_die("Unable to chdir($curdir): $!\n");
+ } elsif ($url =~ m%^http(s)?://%) {
+ if (defined($1) and !$haveSSL) {
+ uscan_die "$progname: you must have the liblwp-protocol-https-perl package installed\nto use https URLs\n";
+ }
+ # substitute HTML entities
+ # Is anything else than "&" required? I doubt it.
+ uscan_verbose "Requesting URL:\n $url\n";
+ my $headers = HTTP::Headers->new;
+ $headers->header('Accept' => '*/*');
+ $headers->header('Referer' => $base);
+ $request = HTTP::Request->new('GET', $url, $headers);
+ $response = $user_agent->request($request, $fname);
+ if (! $response->is_success) {
+ if (defined $pkg_dir) {
+ uscan_warn "In directory $pkg_dir, downloading\n $url failed: " . $response->status_line . "\n";
+ } else {
+ uscan_warn "Downloading\n $url failed:\n" . $response->status_line . "\n";
+ }
+ return 0;
+ }
+ } else {
+ # FTP site
+ if (exists $$optref{'pasv'}) {
+ $ENV{'FTP_PASSIVE'}=$$optref{'pasv'};
+ }
+ uscan_verbose "Requesting URL:\n $url\n";
+ $request = HTTP::Request->new('GET', "$url");
+ $response = $user_agent->request($request, $fname);
+ if (exists $$optref{'pasv'}) {
+ if (defined $passive) {
+ $ENV{'FTP_PASSIVE'}=$passive;
+ } else {
+ delete $ENV{'FTP_PASSIVE'};
+ }
+ }
+ if (! $response->is_success) {
+ if (defined $pkg_dir) {
+ uscan_warn "In directory $pkg_dir, downloading\n $url failed: " . $response->status_line . "\n";
+ } else {
+ uscan_warn "Downloading\n $url failed:\n" . $response->status_line . "\n";
+ }
+ return 0;
+ }
+ }
+ return 1;
+ };
+
+sub recursive_regex_dir ($$$)
+{
+ # If return '', parent code to cause return 1
+ my ($base, $optref, $watchfile)=@_;
+
+ $base =~ m%^(\w+://[^/]+)/(.*)$%;
+ my $site = $1;
+ my @dirs = ();
+ if (defined $2) {
+ @dirs = split /(\/)/, $2;
+ }
+ my $dir = '/';
+
+ foreach my $dirpattern (@dirs) {
+ if ($dirpattern =~ /\(.*\)/) {
+ uscan_verbose "dir=>$dir dirpattern=>$dirpattern\n";
my $newest_dir =
newest_dir($site, $dir, $dirpattern, $optref, $watchfile);
uscan_verbose "newest_dir => '$newest_dir'\n";
@@ -3970,7 +4335,8 @@ sub recursive_regex_dir ($$$) {
# very similar to code above
-sub newest_dir ($$$$$) {
+sub newest_dir ($$$$$)
+{
# return string $newdir as success
# return string '' if error, to cause grand parent code to return 1
my ($site, $dir, $pattern, $optref, $watchfile) = @_;
@@ -4194,128 +4560,13 @@ sub newest_dir ($$$$$) {
}
return $newdir;
}
+#######################################################################
+# }}} code 5: utility functions (download)
+#######################################################################
-
-# parameters are dir, package, upstream version, good dirname
-sub process_watchfile ($$$$)
-{
- my ($dir, $package, $version, $watchfile) = @_;
- my $watch_version=0;
- my $status=0;
- my $nextline;
- %dehs_tags = ();
- @origtars = ();
-
- uscan_verbose "Process $dir/$watchfile (package=$package version=$version)\n";
-
- # set $keyring: upstream/signing-key.pgp and upstream-signing-key.pgp are deprecated but supported
- if ( -r "debian/upstream/signing-key.asc") {
- $keyring = "debian/upstream/signing-key.asc";
- } else {
- my $binkeyring = first { -r $_ } qw(debian/upstream/signing-key.pgp debian/upstream-signing-key.pgp);
- if (defined $binkeyring) {
- make_path('debian/upstream', 0700, 'true');
- # convert to the policy complying armored key
- uscan_verbose "Found upstream binary signing keyring: $binkeyring\n";
- # Need to convert to an armored key
- $keyring = "debian/upstream/signing-key.asc";
- spawn(exec => [$havegpg, '--homedir', "/dev/null",
- '--no-options', '-q', '--batch',
- '--no-default-keyring', '--output',
- $keyring, '--enarmor', $binkeyring],
- wait_child => 1);
- uscan_warn "Generated upstream signing keyring: $keyring\n";
- move $binkeyring, "$binkeyring.backup";
- uscan_verbose "Renamed upstream binary signing keyring: $binkeyring.backup\n";
- }
- }
- if (defined $keyring) {
- uscan_verbose "Found upstream signing keyring: $keyring\n";
- if ($keyring =~ m/\.asc$/) { # always true
- # Need to convert an armored key to binary for use by gpgv
- $gpghome = tempdir(CLEANUP => 1);
- my $newkeyring = "$gpghome/trustedkeys.gpg";
- spawn(exec => [$havegpg, '--homedir', $gpghome,
- '--no-options', '-q', '--batch',
- '--no-default-keyring', '--output',
- $newkeyring, '--dearmor', $keyring],
- wait_child => 1);
- $keyring = $newkeyring
- }
- }
-
- $origcount = 0; # reset to 0 for each watch file
- unless (open WATCH, $watchfile) {
- uscan_warn "could not open $watchfile: $!\n";
- return 1;
- }
-
- while (<WATCH>) {
- next if /^\s*\#/;
- next if /^\s*$/;
- s/^\s*//;
-
- CHOMP:
- chomp;
- if (s/(?<!\\)\\$//) {
- if (eof(WATCH)) {
- uscan_warn "$watchfile ended with \\; skipping last line\n";
- $status=1;
- last;
- }
- if ($watch_version > 3) {
- # drop leading \s only if version 4
- $nextline = <WATCH>;
- $nextline =~ s/^\s*//;
- $_ .= $nextline;
- } else {
- $_ .= <WATCH>;
- }
- goto CHOMP;
- }
-
- if (! $watch_version) {
- if (/^version\s*=\s*(\d+)(\s|$)/) {
- $watch_version=$1;
- if ($watch_version < 2 or
- $watch_version > $CURRENT_WATCHFILE_VERSION) {
- uscan_warn "$watchfile version number is unrecognised; skipping watch file\n";
- last;
- }
- next;
- } else {
- uscan_warn "$watchfile is an obsolete version 1 watch file;\n please upgrade to a higher version\n (see uscan(1) for details).\n";
- $watch_version=1;
- }
- }
-
- # Are there any warnings from this part to give if we're using dehs?
- dehs_output if $dehs;
-
- # Handle shell \\ -> \
- s/\\\\/\\/g if $watch_version==1;
-
- # Handle @PACKAGE@ @ANY_VERSION@ @ARCHIVE_EXT@ substitutions
- my $any_version = '[-_]?(\d[\-+\.:\~\da-zA-Z]*)';
- my $archive_ext = '(?i)\.(?:tar\.xz|tar\.bz2|tar\.gz|zip)';
- my $signature_ext = $archive_ext . '\.(?:asc|pgp|gpg|sig|sign)';
- s/\@PACKAGE\@/$package/g;
- s/\@ANY_VERSION\@/$any_version/g;
- s/\@ARCHIVE_EXT\@/$archive_ext/g;
- s/\@SIGNATURE_EXT\@/$signature_ext/g;
-
- $status +=
- process_watchline($_, $watch_version, $dir, $package, $version,
- $watchfile);
- dehs_output if $dehs;
- }
-
- close WATCH or
- $status=1, uscan_warn "problems reading $watchfile: $!\n";
-
- return $status;
-}
-
+#######################################################################
+# {{{ code 6: utility functions (compression)
+#######################################################################
# Get legal values for compression
sub get_compression ($)
{
@@ -4385,100 +4636,15 @@ sub get_priority ($)
}
return $priority;
}
-
-# Message handling
-sub printwarn ($)
-{
- my $msg = $_[0];
- if ($dehs) {
- warn $msg;
- } else {
- print $msg;
- }
-}
-
-sub uscan_msg($)
-{
- my $msg = $_[0];
- printwarn "$progname: $msg";
-}
-
-sub uscan_verbose($)
-{
- my $msg = $_[0];
- if ($verbose > 0) {
- printwarn "$progname info: $msg";
- }
-}
-
-sub dehs_verbose ($)
+#######################################################################
+# }}} code 6: utility functions (compression)
+#######################################################################
+
+#######################################################################
+# {{{ code 7: utility functions (regex)
+#######################################################################
+sub quoted_regex_parse($)
{
- my $msg = $_[0];
- push @{$dehs_tags{'messages'}}, $msg;
- uscan_verbose($msg)
-}
-
-sub uscan_warn ($)
-{
- my $msg = $_[0];
- push @{$dehs_tags{'warnings'}}, $msg if $dehs;
- warn "$progname warn: $msg";
-}
-
-sub uscan_debug($)
-{
- my $msg = $_[0];
- warn "$progname debug: $msg" if $verbose > 1;
-}
-
-sub uscan_die ($)
-{
- my $msg = $_[0];
- if ($dehs) {
- %dehs_tags = ('errors' => "$msg");
- $dehs_end_output=1;
- dehs_output;
- }
- die "$progname die: $msg";
-}
-
-sub dehs_output ()
-{
- return unless $dehs;
-
- if (! $dehs_start_output) {
- print "<dehs>\n";
- $dehs_start_output=1;
- }
-
- for my $tag (qw(package debian-uversion debian-mangled-uversion
- upstream-version upstream-url
- status target target-path messages warnings errors)) {
- if (exists $dehs_tags{$tag}) {
- if (ref $dehs_tags{$tag} eq "ARRAY") {
- foreach my $entry (@{$dehs_tags{$tag}}) {
- $entry =~ s/</</g;
- $entry =~ s/>/>/g;
- $entry =~ s/&/&/g;
- print "<$tag>$entry</$tag>\n";
- }
- } else {
- $dehs_tags{$tag} =~ s/</</g;
- $dehs_tags{$tag} =~ s/>/>/g;
- $dehs_tags{$tag} =~ s/&/&/g;
- print "<$tag>$dehs_tags{$tag}</$tag>\n";
- }
- }
- }
- if ($dehs_end_output) {
- print "</dehs>\n";
- }
-
- # Don't repeat output
- %dehs_tags = ();
-}
-
-sub quoted_regex_parse($) {
my $pattern = shift;
my %closers = ('{', '}', '[', ']', '(', ')', '<', '>');
@@ -4558,19 +4724,8 @@ sub quoted_regex_parse($) {
return ($parsed_ok, $regexp, $replacement, $flags);
}
-sub fix_href
+sub safe_replace($$)
{
- my ($href) = @_;
-
- # Remove whitespace from URLs:
- # https://www.w3.org/TR/html5/links.html#links-created-by-a-and-area-elements
- $href =~ s/^\s+//;
- $href =~ s/\s+$//;
-
- return $href;
-}
-
-sub safe_replace($$) {
my ($in, $pat) = @_;
eval "uscan_debug \"safe_replace input=\\\"\$\$in\\\"\\n\"";
$pat =~ s/^\s*(.*?)\s*$/$1/;
@@ -4736,3 +4891,6 @@ sub safe_replace($$) {
return 1;
}
}
+#######################################################################
+# }}} code 7: utility functions (regex)
+#######################################################################
--
Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/collab-maint/devscripts.git
More information about the devscripts-devel
mailing list