summaryrefslogtreecommitdiffstats
path: root/lib/Devscripts/Uscan
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--lib/Devscripts/Uscan/CatchRedirections.pm27
-rw-r--r--lib/Devscripts/Uscan/Config.pm383
-rw-r--r--lib/Devscripts/Uscan/Downloader.pm168
-rw-r--r--lib/Devscripts/Uscan/FindFiles.pm256
-rw-r--r--lib/Devscripts/Uscan/Keyring.pm174
-rw-r--r--lib/Devscripts/Uscan/Output.pm99
-rw-r--r--lib/Devscripts/Uscan/Utils.pm468
-rw-r--r--lib/Devscripts/Uscan/WatchFile.pm408
-rw-r--r--lib/Devscripts/Uscan/WatchLine.pm1741
-rw-r--r--lib/Devscripts/Uscan/_xtp.pm83
-rw-r--r--lib/Devscripts/Uscan/ftp.pm278
-rw-r--r--lib/Devscripts/Uscan/git.pm235
-rw-r--r--lib/Devscripts/Uscan/http.pm434
13 files changed, 4754 insertions, 0 deletions
diff --git a/lib/Devscripts/Uscan/CatchRedirections.pm b/lib/Devscripts/Uscan/CatchRedirections.pm
new file mode 100644
index 0000000..28f99ca
--- /dev/null
+++ b/lib/Devscripts/Uscan/CatchRedirections.pm
@@ -0,0 +1,27 @@
+# dummy subclass used to store all the redirections for later use
+package Devscripts::Uscan::CatchRedirections;
+
+use base 'LWP::UserAgent';
+
+my @uscan_redirections;
+
+sub redirect_ok {
+ my $self = shift;
+ my ($request) = @_;
+ if ($self->SUPER::redirect_ok(@_)) {
+ push @uscan_redirections, $request->uri;
+ return 1;
+ }
+ return 0;
+}
+
+sub get_redirections {
+ return \@uscan_redirections;
+}
+
+sub clear_redirections {
+ undef @uscan_redirections;
+ return;
+}
+
+1;
diff --git a/lib/Devscripts/Uscan/Config.pm b/lib/Devscripts/Uscan/Config.pm
new file mode 100644
index 0000000..6589e05
--- /dev/null
+++ b/lib/Devscripts/Uscan/Config.pm
@@ -0,0 +1,383 @@
+
+=head1 NAME
+
+Devscripts::Uscan::Config - uscan configuration object
+
+=head1 SYNOPSIS
+
+ use Devscripts::Uscan::Config;
+ my $config = Devscripts::Uscan::Config->new->parse;
+
+=head1 DESCRIPTION
+
+Uscan configuration object. It can scan configuration files
+(B</etc/devscripts.conf> and B<~/.devscripts>) and command line arguments.
+
+=cut
+
+package Devscripts::Uscan::Config;
+
+use strict;
+
+use Devscripts::Uscan::Output;
+use Exporter 'import';
+use Moo;
+
+extends 'Devscripts::Config';
+
+our $CURRENT_WATCHFILE_VERSION = 4;
+
+use constant default_user_agent => "Debian uscan"
+ . ($main::uscan_version ? " $main::uscan_version" : '');
+
+our @EXPORT = (qw($CURRENT_WATCHFILE_VERSION));
+
+# I - ACCESSORS
+
+# Options + default values
+
+has bare => (is => 'rw');
+has check_dirname_level => (is => 'rw');
+has check_dirname_regex => (is => 'rw');
+has compression => (is => 'rw');
+has copyright_file => (is => 'rw');
+has destdir => (is => 'rw');
+has download => (is => 'rw');
+has download_current_version => (is => 'rw');
+has download_debversion => (is => 'rw');
+has download_version => (is => 'rw');
+has exclusion => (is => 'rw');
+has log => (is => 'rw');
+has orig => (is => 'rw');
+has package => (is => 'rw');
+has pasv => (is => 'rw');
+
+# repack to .tar.$zsuffix if 1
+has repack => (is => 'rw');
+has safe => (is => 'rw');
+has signature => (is => 'rw');
+has symlink => (is => 'rw');
+has timeout => (is => 'rw');
+has user_agent => (is => 'rw');
+has uversion => (is => 'rw');
+has watchfile => (is => 'rw');
+
+# II - Options
+
+use constant keys => [
+ # 2.1 - Simple parameters that can be set in ~/.devscripts and command line
+ [
+ 'check-dirname-level=s', 'DEVSCRIPTS_CHECK_DIRNAME_LEVEL',
+ qr/^[012]$/, 1
+ ],
+ [
+ 'check-dirname-regex=s', 'DEVSCRIPTS_CHECK_DIRNAME_REGEX',
+ undef, 'PACKAGE(-.+)?'
+ ],
+ ['dehs!', 'USCAN_DEHS_OUTPUT', sub { $dehs = $_[1]; 1 }],
+ [
+ 'destdir=s',
+ 'USCAN_DESTDIR',
+ sub {
+ if (-d $_[1]) {
+ $_[0]->destdir($_[1]) if (-d $_[1]);
+ return 1;
+ }
+ return (0,
+ "The directory to store downloaded files(\$destdir): $_[1]");
+ },
+ '..'
+ ],
+ ['exclusion!', 'USCAN_EXCLUSION', 'bool', 1],
+ ['timeout=i', 'USCAN_TIMEOUT', qr/^\d+$/, 20],
+ [
+ 'user-agent|useragent=s',
+ 'USCAN_USER_AGENT',
+ qr/\w/,
+ sub {
+ default_user_agent;
+ }
+ ],
+ ['repack', 'USCAN_REPACK', 'bool'],
+ # 2.2 - Simple command line args
+ ['bare', undef, 'bool', 0],
+ ['compression=s'],
+ ['copyright-file=s'],
+ ['download-current-version', undef, 'bool'],
+ ['download-version=s'],
+ ['download-debversion|dversion=s'],
+ ['log', undef, 'bool'],
+ ['package=s'],
+ ['uversion|upstream-version=s'],
+ ['watchfile=s'],
+ # 2.3 - More complex options
+
+ # "download" and its aliases
+ [
+ undef,
+ 'USCAN_DOWNLOAD',
+ sub {
+ return (1, 'Bad USCAN_DOWNLOAD value, skipping')
+ unless ($_[1] =~ /^(?:yes|(no))$/i);
+ $_[0]->download(0) if $1;
+ return 1;
+ }
+ ],
+ [
+ 'download|d+',
+ undef,
+ sub {
+ $_[1] =~ s/^yes$/1/i;
+ $_[1] =~ s/^no$/0/i;
+ return (0, "Wrong number of -d")
+ unless ($_[1] =~ /^[0123]$/);
+ $_[0]->download($_[1]);
+ return 1;
+ },
+ 1
+ ],
+ [
+ 'force-download',
+ undef,
+ sub {
+ $_[0]->download(2);
+ }
+ ],
+ ['no-download', undef, sub { $_[0]->download(0); return 1; }],
+ ['overwrite-download', undef, sub { $_[0]->download(3) }],
+
+ # "pasv"
+ [
+ 'pasv|passive',
+ 'USCAN_PASV',
+ sub {
+ return $_[0]->pasv('default')
+ unless ($_[1] =~ /^(yes|0|1|no)$/);
+ $_[0]->pasv({
+ yes => 1,
+ 1 => 1,
+ no => 0,
+ 0 => 0,
+ }->{$1});
+ return 1;
+ },
+ 0
+ ],
+
+ # "safe" and "symlink" and their aliases
+ ['safe|report', 'USCAN_SAFE', 'bool', 0],
+ [
+ 'report-status',
+ undef,
+ sub {
+ $_[0]->safe(1);
+ $verbose ||= 1;
+ }
+ ],
+ ['copy', undef, sub { $_[0]->symlink('copy') }],
+ ['rename', undef, sub { $_[0]->symlink('rename') if ($_[1]); 1; }],
+ [
+ 'symlink!',
+ 'USCAN_SYMLINK',
+ sub {
+ $_[0]->symlink(
+ $_[1] =~ /^(no|0|rename)$/ ? $1
+ : $_[1] =~ /^(yes|1|symlink)$/ ? 'symlink'
+ : 'no'
+ );
+ return 1;
+ },
+ 'symlink'
+ ],
+ # "signature" and its aliases
+ ['signature!', undef, 'bool', 1],
+ ['skipsignature|skip-signature', undef, sub { $_[0]->signature(-1) }],
+ # "verbose" and its aliases
+ ['debug', undef, sub { $verbose = 2 }],
+ ['no-verbose', undef, sub { $verbose = 0; return 1; }],
+ [
+ 'verbose|v!', 'USCAN_VERBOSE',
+ sub { $verbose = ($_[1] =~ /^(?:1|yes)$/i ? 1 : 0); return 1; }
+ ],
+ # Display version
+ [
+ 'version',
+ undef,
+ sub {
+ if ($_[1]) { $_[0]->version; exit 0 }
+ }
+ ]];
+
+use constant rules => [
+ sub {
+ my $self = shift;
+ if ($self->package) {
+ $self->download(0)
+ unless ($self->download > 1); # compatibility
+ return (0,
+"The --package option requires to set the --watchfile option, too."
+ ) unless defined $self->watchfile;
+ }
+ $self->download(0) if ($self->safe == 1 and $self->download == 1);
+ return 1;
+ },
+ # $signature: -1 = no downloading signature and no verifying signature,
+ # 0 = no downloading signature but verifying signature,
+ # 1 = downloading signature and verifying signature
+ sub {
+ my $self = shift;
+ $self->signature(-1)
+ if $self->download == 0; # Change default 1 -> -1
+ return 1;
+ },
+ sub {
+ if (defined $_[0]->watchfile and @ARGV) {
+ return (0, "Can't have directory arguments if using --watchfile");
+ }
+ return 1;
+ },
+];
+
+# help methods
+sub usage {
+ my ($self) = @_;
+ print <<"EOF";
+Usage: $progname [options] [dir ...]
+ Process watch files in all .../debian/ subdirs of those listed (or the
+ current directory if none listed) to check for upstream releases.
+Options:
+ --no-conf, --noconf
+ Don\'t read devscripts config files;
+ must be the first option given
+ --no-verbose Don\'t report verbose information.
+ --verbose, -v Report verbose information.
+ --debug, -vv Report verbose information including the downloaded
+ web pages as processed to STDERR for debugging.
+ --dehs Send DEHS style output (XML-type) to STDOUT, while
+ send all other uscan output to STDERR.
+ --no-dehs Use only traditional uscan output format (default)
+ --download, -d
+ Download the new upstream release (default)
+ --force-download, -dd
+ Download the new upstream release, even if up-to-date
+ (may not overwrite the local file)
+ --overwrite-download, -ddd
+ Download the new upstream release, even if up-to-date
+ (may overwrite the local file)
+ --no-download, --nodownload
+ Don\'t download and report information.
+ Previously downloaded tarballs may be used.
+ Change default to --skip-signature.
+ --signature Download signature and verify (default)
+ --no-signature Don\'t download signature but verify if already downloaded.
+ --skip-signature
+ Don\'t bother download signature nor verify it.
+ --safe, --report
+ avoid running unsafe scripts by skipping both the repacking
+ of the downloaded package and the updating of the new
+ source tree. Change default to --no-download and
+ --skip-signature.
+ --report-status (= --safe --verbose)
+ --download-version VERSION
+ Specify the version which the upstream release must
+ match in order to be considered, rather than using the
+ release with the highest version
+ --download-debversion VERSION
+ Specify the Debian package version to download the
+ corresponding upstream release version. The
+ dversionmangle and uversionmangle rules are
+ considered.
+ --download-current-version
+ Download the currently packaged version
+ --check-dirname-level N
+ Check parent directory name?
+ N=0 never check parent directory name
+ N=1 only when $progname changes directory (default)
+ N=2 always check parent directory name
+ --check-dirname-regex REGEX
+ What constitutes a matching directory name; REGEX is
+ a Perl regular expression; the string \`PACKAGE\' will
+ be replaced by the package name; see manpage for details
+ (default: 'PACKAGE(-.+)?')
+ --destdir Path of directory to which to download.
+ --package PACKAGE
+ Specify the package name rather than examining
+ debian/changelog; must use --upstream-version and
+ --watchfile with this option, no directory traversing
+ will be performed, no actions (even downloading) will be
+ carried out
+ --upstream-version VERSION
+ Specify the current upstream version in use rather than
+ parsing debian/changelog to determine this
+ --watchfile FILE
+ Specify the watch file rather than using debian/watch;
+ no directory traversing will be done in this case
+ --bare Disable all site specific special case codes to perform URL
+ redirections and page content alterations.
+ --no-exclusion Disable automatic exclusion of files mentioned in
+ debian/copyright field Files-Excluded and Files-Excluded-*
+ --pasv Use PASV mode for FTP connections
+ --no-pasv Don\'t use PASV mode for FTP connections (default)
+ --no-symlink Don\'t rename nor repack upstream tarball
+ --timeout N Specifies how much time, in seconds, we give remote
+ servers to respond (default 20 seconds)
+ --user-agent, --useragent
+ Override the default user agent string
+ --log Record md5sum changes of repackaging
+ --help Show this message
+ --version Show version information
+
+Options passed on to mk-origtargz:
+ --symlink Create a correctly named symlink to downloaded file (default)
+ --rename Rename instead of symlinking
+ --copy Copy instead of symlinking
+ --repack Repack downloaded archives to change compression
+ --compression [ gzip | bzip2 | lzma | xz ]
+ When the upstream sources are repacked, use compression COMP
+ for the resulting tarball (default: gzip)
+ --copyright-file FILE
+ Remove files matching the patterns found in FILE
+
+Default settings modified by devscripts configuration files:
+$self->{modified_conf_msg}
+EOF
+}
+
+sub version {
+ print <<"EOF";
+This is $progname, from the Debian devscripts package, version $main::uscan_version
+This code is copyright 1999-2006 by Julian Gilbey and 2018 by Xavier Guimard,
+all rights reserved.
+Original code by Christoph Lameter.
+This program comes with ABSOLUTELY NO WARRANTY.
+You are free to redistribute this code under the terms of the
+GNU General Public License, version 2 or later.
+EOF
+}
+
+1;
+__END__
+=head1 SEE ALSO
+
+L<uscan>, L<Devscripts::Config>
+
+=head1 AUTHOR
+
+B<uscan> was originally written by Christoph Lameter
+E<lt>clameter@debian.orgE<gt> (I believe), modified by Julian Gilbey
+E<lt>jdg@debian.orgE<gt>. HTTP support was added by Piotr Roszatycki
+E<lt>dexter@debian.orgE<gt>. B<uscan> was rewritten in Perl by Julian Gilbey.
+Xavier Guimard E<lt>yadd@debian.orgE<gt> rewrote uscan in object
+oriented Perl.
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2002-2006 by Julian Gilbey <jdg@debian.org>,
+2018 by Xavier Guimard <yadd@debian.org>
+
+This program is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or
+(at your option) any later version.
+
+=cut
diff --git a/lib/Devscripts/Uscan/Downloader.pm b/lib/Devscripts/Uscan/Downloader.pm
new file mode 100644
index 0000000..89f946b
--- /dev/null
+++ b/lib/Devscripts/Uscan/Downloader.pm
@@ -0,0 +1,168 @@
+package Devscripts::Uscan::Downloader;
+
+use strict;
+use Cwd qw/cwd abs_path/;
+use Devscripts::Uscan::CatchRedirections;
+use Devscripts::Uscan::Output;
+use Devscripts::Uscan::Utils;
+use Moo;
+
+our $haveSSL;
+
+has git_upstream => (is => 'rw');
+
+BEGIN {
+ eval { require LWP::UserAgent; };
+ if ($@) {
+ my $progname = basename($0);
+ if ($@ =~ /^Can\'t locate LWP\/UserAgent\.pm/) {
+ die "$progname: you must have the libwww-perl package installed\n"
+ . "to use this script";
+ } else {
+ die "$progname: problem loading the LWP::UserAgent module:\n $@\n"
+ . "Have you installed the libwww-perl package?";
+ }
+ }
+ eval { require LWP::Protocol::https; };
+ $haveSSL = $@ ? 0 : 1;
+}
+
+has agent =>
+ (is => 'rw', default => sub { "Debian uscan $main::uscan_version" });
+has timeout => (is => 'rw');
+has pasv => (
+ is => 'rw',
+ default => 'default',
+ trigger => sub {
+ my ($self, $nv) = @_;
+ if ($nv) {
+ uscan_verbose "Set passive mode: $self->{pasv}";
+ $ENV{'FTP_PASSIVE'} = $self->pasv;
+ } elsif ($ENV{'FTP_PASSIVE'}) {
+ uscan_verbose "Unset passive mode";
+ delete $ENV{'FTP_PASSIVE'};
+ }
+ });
+has destdir => (is => 'rw');
+
+# 0: no repo, 1: shallow clone, 2: full clone
+has gitrepo_state => (
+ is => 'rw',
+ default => sub { 0 });
+has user_agent => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+ my $user_agent
+ = Devscripts::Uscan::CatchRedirections->new(env_proxy => 1);
+ $user_agent->timeout($self->timeout);
+ $user_agent->agent($self->agent);
+
+ # Strip Referer header for Sourceforge to avoid SF sending back a
+ # "200 OK" with a <meta refresh=...> redirect
+ $user_agent->add_handler(
+ 'request_prepare' => sub {
+ my ($request, $ua, $h) = @_;
+ $request->remove_header('Referer');
+ },
+ m_hostname => 'sourceforge.net',
+ );
+ $self->{user_agent} = $user_agent;
+ });
+
+has ssl => (is => 'rw', default => sub { $haveSSL });
+
+sub download ($$$$$$$$) {
+ my ($self, $url, $fname, $optref, $base, $pkg_dir, $pkg, $mode) = @_;
+ my ($request, $response);
+ $mode ||= $optref->mode;
+ if ($mode eq 'http') {
+ if ($url =~ /^https/ and !$self->ssl) {
+ uscan_die "$progname: you must have the "
+ . "liblwp-protocol-https-perl package installed\n"
+ . "to use https URLs";
+ }
+
+ # substitute HTML entities
+ # Is anything else than "&amp;" required? I doubt it.
+ uscan_verbose "Requesting URL:\n $url";
+ my $headers = HTTP::Headers->new;
+ $headers->header('Accept' => '*/*');
+ $headers->header('Referer' => $base);
+ $request = HTTP::Request->new('GET', $url, $headers);
+ $response = $self->user_agent->request($request, $fname);
+ if (!$response->is_success) {
+ uscan_warn((defined $pkg_dir ? "In directory $pkg_dir, d" : "D")
+ . "ownloading\n $url failed: "
+ . $response->status_line);
+ return 0;
+ }
+ } elsif ($mode eq 'ftp') {
+ uscan_verbose "Requesting URL:\n $url";
+ $request = HTTP::Request->new('GET', "$url");
+ $response = $self->user_agent->request($request, $fname);
+ if (!$response->is_success) {
+ uscan_warn((defined $pkg_dir ? "In directory $pkg_dir, d" : "D")
+ . "ownloading\n $url failed: "
+ . $response->status_line);
+ return 0;
+ }
+ } else { # elsif ($$optref{'mode'} eq 'git')
+ my $destdir = $self->destdir;
+ my $curdir = cwd();
+ $fname =~ m%(.*)/$pkg-([^_/]*)\.tar\.(gz|xz|bz2|lzma)%;
+ my $dst = $1;
+ my $abs_dst = abs_path($dst);
+ my $ver = $2;
+ my $suffix = $3;
+ my $gitrepo_dir
+ = "$pkg-temporary.$$.git"; # same as outside of downloader
+ my ($gitrepo, $gitref) = split /[[:space:]]+/, $url, 2;
+
+ if ($self->git_upstream) {
+ uscan_exec_no_fail('git', 'archive', '--format=tar',
+ "--prefix=$pkg-$ver/", "--output=$abs_dst/$pkg-$ver.tar",
+ $gitref) == 0
+ or uscan_die("git archive failed");
+ } else {
+ if ($self->gitrepo_state == 0) {
+ if ($optref->gitmode eq 'shallow') {
+ my $tag = $gitref;
+ $tag =~ s|.*/||;
+ uscan_exec('git', 'clone', '--bare', '--depth=1', '-b',
+ $tag, $base, "$destdir/$gitrepo_dir");
+ $self->gitrepo_state(1);
+ } else {
+ uscan_exec('git', 'clone', '--bare', $base,
+ "$destdir/$gitrepo_dir");
+ $self->gitrepo_state(2);
+ }
+ }
+ uscan_exec_no_fail(
+ 'git', "--git-dir=$destdir/$gitrepo_dir",
+ 'archive', '--format=tar',
+ "--prefix=$pkg-$ver/", "--output=$abs_dst/$pkg-$ver.tar",
+ $gitref
+ ) == 0
+ or uscan_die("git archive failed");
+ }
+
+ chdir "$abs_dst" or uscan_die("Unable to chdir($abs_dst): $!");
+ if ($suffix eq 'gz') {
+ uscan_exec("gzip", "-n", "-9", "$pkg-$ver.tar");
+ } elsif ($suffix eq 'xz') {
+ uscan_exec("xz", "$pkg-$ver.tar");
+ } elsif ($suffix eq 'bz2') {
+ uscan_exec("bzip2", "$pkg-$ver.tar");
+ } elsif ($suffix eq 'lzma') {
+ uscan_exec("lzma", "$pkg-$ver.tar");
+ } else {
+ uscan_die "Unknown suffix file to repack: $suffix";
+ }
+ chdir "$curdir" or uscan_die("Unable to chdir($curdir): $!");
+ }
+ return 1;
+}
+
+1;
diff --git a/lib/Devscripts/Uscan/FindFiles.pm b/lib/Devscripts/Uscan/FindFiles.pm
new file mode 100644
index 0000000..20ce2a4
--- /dev/null
+++ b/lib/Devscripts/Uscan/FindFiles.pm
@@ -0,0 +1,256 @@
+
+=head1 NAME
+
+Devscripts::Uscan::FindFiles - watchfile finder
+
+=head1 SYNOPSIS
+
+ use Devscripts::Uscan::Config;
+ use Devscripts::Uscan::FindFiles;
+
+ # Get config
+ my $config = Devscripts::Uscan::Config->new->parse;
+
+ # Search watchfiles
+ my @wf = find_watch_files($config);
+
+=head1 DESCRIPTION
+
+This package exports B<find_watch_files()> function. This function search
+Debian watchfiles following configuration parameters.
+
+=head1 SEE ALSO
+
+L<uscan>, L<Devscripts::Uscan::WatchFile>, L<Devscripts::Uscan::Config>
+
+=head1 AUTHOR
+
+B<uscan> was originally written by Christoph Lameter
+E<lt>clameter@debian.orgE<gt> (I believe), modified by Julian Gilbey
+E<lt>jdg@debian.orgE<gt>. HTTP support was added by Piotr Roszatycki
+E<lt>dexter@debian.orgE<gt>. B<uscan> was rewritten in Perl by Julian Gilbey.
+Xavier Guimard E<lt>yadd@debian.orgE<gt> rewrote uscan in object
+oriented Perl.
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2002-2006 by Julian Gilbey <jdg@debian.org>,
+2018 by Xavier Guimard <yadd@debian.org>
+
+This program is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or
+(at your option) any later version.
+
+=cut
+
+package Devscripts::Uscan::FindFiles;
+
+use strict;
+use filetest 'access';
+use Cwd qw/cwd/;
+use Exporter 'import';
+use Devscripts::Uscan::Output;
+use Devscripts::Versort;
+use Dpkg::Changelog::Parse qw(changelog_parse);
+use File::Basename;
+
+our @EXPORT = ('find_watch_files');
+
+sub find_watch_files {
+ my ($config) = @_;
+ my $opwd = cwd();
+
+ # when --watchfile is used
+ if (defined $config->watchfile) {
+ uscan_verbose "Option --watchfile=$config->{watchfile} used";
+ my ($config) = (@_);
+
+ # no directory traversing then, and things are very simple
+ if (defined $config->package) {
+
+ # no need to even look for a changelog!
+ return (
+ ['.', $config->package, $config->uversion, $config->watchfile]
+ );
+ } else {
+ # Check for debian/changelog file
+ until (-r 'debian/changelog') {
+ chdir '..' or uscan_die "can't chdir ..: $!";
+ if (cwd() eq '/') {
+ uscan_die "Are you in the source code tree?\n"
+ . " Cannot find readable debian/changelog anywhere!";
+ }
+ }
+
+ my ($package, $debversion, $uversion)
+ = scan_changelog($config, $opwd, 1);
+
+ return ([cwd(), $package, $uversion, $config->watchfile]);
+ }
+ }
+
+ # when --watchfile is not used, scan watch files
+ push @ARGV, '.' if !@ARGV;
+ {
+ local $, = ',';
+ uscan_verbose "Scan watch files in @ARGV";
+ }
+
+ # Run find to find the directories. We will handle filenames with spaces
+ # correctly, which makes this code a little messier than it would be
+ # otherwise.
+ my @dirs;
+ open FIND, '-|', 'find', @ARGV, qw(-follow -type d -name debian -print)
+ or uscan_die "Couldn't exec find: $!";
+
+ while (<FIND>) {
+ chomp;
+ push @dirs, $_;
+ uscan_debug "Found $_";
+ }
+ close FIND;
+
+ uscan_die "No debian directories found" unless @dirs;
+
+ my @debdirs = ();
+
+ my $origdir = cwd;
+ for my $dir (@dirs) {
+ $dir =~ s%/debian$%%;
+
+ unless (chdir $origdir) {
+ uscan_warn "Couldn't chdir back to $origdir, skipping: $!";
+ next;
+ }
+ unless (chdir $dir) {
+ uscan_warn "Couldn't chdir $dir, skipping: $!";
+ next;
+ }
+
+ uscan_verbose "Check debian/watch and debian/changelog in $dir";
+
+ # Check for debian/watch file
+ if (-r 'debian/watch') {
+ unless (-r 'debian/changelog') {
+ uscan_warn
+ "Problems reading debian/changelog in $dir, skipping";
+ next;
+ }
+ my ($package, $debversion, $uversion)
+ = scan_changelog($config, $opwd);
+ next unless ($package);
+
+ uscan_verbose
+ "package=\"$package\" version=\"$uversion\" (no epoch/revision)";
+ push @debdirs, [$debversion, $dir, $package, $uversion];
+ }
+ }
+
+ uscan_warn "No watch file found" unless @debdirs;
+
+ # Was there a --upstream-version option?
+ if (defined $config->uversion) {
+ if (@debdirs == 1) {
+ $debdirs[0][3] = $config->uversion;
+ } else {
+ uscan_warn
+"ignoring --upstream-version as more than one debian/watch file found";
+ }
+ }
+
+ # Now sort the list of directories, so that we process the most recent
+ # directories first, as determined by the package version numbers
+ @debdirs = Devscripts::Versort::deb_versort(@debdirs);
+
+ # Now process the watch files in order. If a directory d has
+ # subdirectories d/sd1/debian and d/sd2/debian, which each contain watch
+ # files corresponding to the same package, then we only process the watch
+ # file in the package with the latest version number.
+ my %donepkgs;
+ my @results;
+ for my $debdir (@debdirs) {
+ shift @$debdir; # don't need the Debian version number any longer
+ my $dir = $$debdir[0];
+ my $parentdir = dirname($dir);
+ my $package = $$debdir[1];
+ my $version = $$debdir[2];
+
+ if (exists $donepkgs{$parentdir}{$package}) {
+ uscan_warn
+"Skipping $dir/debian/watch\n as this package has already been found";
+ next;
+ }
+
+ unless (chdir $origdir) {
+ uscan_warn "Couldn't chdir back to $origdir, skipping: $!";
+ next;
+ }
+ unless (chdir $dir) {
+ uscan_warn "Couldn't chdir $dir, skipping: $!";
+ next;
+ }
+
+ uscan_verbose
+"$dir/debian/changelog sets package=\"$package\" version=\"$version\"";
+ push @results, [$dir, $package, $version, "debian/watch", cwd];
+ }
+ unless (chdir $origdir) {
+ uscan_die "Couldn't chdir back to $origdir! $!";
+ }
+ return @results;
+}
+
+sub scan_changelog {
+ my ($config, $opwd, $die) = @_;
+ my $out
+ = $die
+ ? sub { uscan_die(@_) }
+ : sub { uscan_warn($_[0] . ', skipping') };
+
+ # Figure out package info we need
+ my $changelog = eval { changelog_parse(); };
+ if ($@) {
+ return $out->("Problems parsing debian/changelog:");
+ }
+
+ my ($package, $debversion, $uversion);
+ $package = $changelog->{Source};
+ return $out->("Problem determining the package name from debian/changelog")
+ unless defined $package;
+ $debversion = $changelog->{Version};
+ return $out->("Problem determining the version from debian/changelog")
+ unless defined $debversion;
+ uscan_verbose
+"package=\"$package\" version=\"$debversion\" (as seen in debian/changelog)";
+
+ # Check the directory is properly named for safety
+ if ($config->check_dirname_level == 2
+ or ($config->check_dirname_level == 1 and cwd() ne $opwd)) {
+ my $good_dirname;
+ my $re = $config->check_dirname_regex;
+ $re =~ s/PACKAGE/\Q$package\E/g;
+ if ($re =~ m%/%) {
+ $good_dirname = (cwd() =~ m%^$re$%);
+ } else {
+ $good_dirname = (basename(cwd()) =~ m%^$re$%);
+ }
+ return $out->("The directory name "
+ . basename(cwd())
+ . " doesn't match the requirement of\n"
+ . " --check_dirname_level=$config->{check_dirname_level} --check-dirname-regex=$re .\n"
+ . " Set --check-dirname-level=0 to disable this sanity check feature."
+ ) unless defined $good_dirname;
+ }
+
+ # Get current upstream version number
+ if (defined $config->uversion) {
+ $uversion = $config->uversion;
+ } else {
+ $uversion = $debversion;
+ $uversion =~ s/-[^-]+$//; # revision
+ $uversion =~ s/^\d+://; # epoch
+ }
+ return ($package, $debversion, $uversion);
+}
+1;
diff --git a/lib/Devscripts/Uscan/Keyring.pm b/lib/Devscripts/Uscan/Keyring.pm
new file mode 100644
index 0000000..4dff7a7
--- /dev/null
+++ b/lib/Devscripts/Uscan/Keyring.pm
@@ -0,0 +1,174 @@
+package Devscripts::Uscan::Keyring;
+
+use strict;
+use Devscripts::Uscan::Output;
+use Devscripts::Uscan::Utils;
+use Dpkg::IPC;
+use File::Copy qw/copy move/;
+use File::Which;
+use File::Path qw/make_path remove_tree/;
+use File::Temp qw/tempfile tempdir/;
+use List::Util qw/first/;
+
+sub new {
+ my ($class) = @_;
+ my $keyring;
+ my $havegpgv = first {
+ which $_
+ }
+ qw(gpgv2 gpgv);
+ my $havegpg = first {
+ which $_
+ }
+ qw(gpg2 gpg);
+ uscan_die("Please install gpgv or gpgv2.") unless defined $havegpgv;
+ uscan_die("Please install gnupg or gnupg2.") unless defined $havegpg;
+
+ # 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");
+
+ # Need to convert to an armored key
+ $keyring = "debian/upstream/signing-key.asc";
+ uscan_warn "Found deprecated binary keyring ($binkeyring). "
+ . "Please save it in armored format in $keyring. For example:\n"
+ . " gpg --output $keyring --enarmor $binkeyring";
+ 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");
+ move $binkeyring, "$binkeyring.backup";
+ uscan_verbose(
+ "Renamed upstream binary signing keyring: $binkeyring.backup");
+ }
+ }
+
+ # Need to convert an armored key to binary for use by gpgv
+ my $gpghome;
+ if (defined $keyring) {
+ uscan_verbose("Found upstream signing keyring: $keyring");
+ if ($keyring =~ m/\.asc$/) { # always true
+ $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;
+ }
+ }
+
+ # Return undef if not key found
+ else {
+ return undef;
+ }
+ my $self = bless {
+ keyring => $keyring,
+ gpghome => $gpghome,
+ gpgv => $havegpgv,
+ gpg => $havegpg,
+ }, $class;
+ return $self;
+}
+
+sub verify {
+ my ($self, $sigfile, $newfile) = @_;
+ uscan_verbose(
+ "Verifying OpenPGP self signature of $newfile and extract $sigfile");
+ unless (
+ uscan_exec_no_fail(
+ $self->{gpgv},
+ '--homedir' => $self->{gpghome},
+ '--keyring' => $self->{keyring},
+ '-o' => "$sigfile",
+ "$newfile"
+ ) >> 8 == 0
+ ) {
+ uscan_die("OpenPGP signature did not verify.");
+ }
+}
+
+sub verifyv {
+ my ($self, $sigfile, $base) = @_;
+ uscan_verbose("Verifying OpenPGP signature $sigfile for $base");
+ unless (
+ uscan_exec_no_fail(
+ $self->{gpgv},
+ '--homedir' => '/dev/null',
+ '--keyring' => $self->{keyring},
+ $sigfile, $base
+ ) >> 8 == 0
+ ) {
+ uscan_die("OpenPGP signature did not verify.");
+ }
+}
+
+sub verify_git {
+ my ($self, $gitdir, $tag, $git_upstream) = @_;
+ my $commit;
+ my @dir = $git_upstream ? () : ('--git-dir', "../$gitdir");
+ spawn(
+ exec => ['git', @dir, 'show-ref', $tag],
+ to_string => \$commit
+ );
+ uscan_die "git tag not found" unless ($commit);
+ $commit =~ s/\s.*$//;
+ chomp $commit;
+ my $file;
+ spawn(
+ exec => ['git', @dir, 'cat-file', '-p', $commit],
+ to_string => \$file
+ );
+ my $dir;
+ spawn(exec => ['mktemp', '-d'], to_string => \$dir);
+ chomp $dir;
+
+ unless ($file =~ /^(.*?\n)(\-+\s*BEGIN PGP SIGNATURE\s*\-+.*)$/s) {
+ uscan_die "Tag $tag is not signed";
+ }
+ open F, ">$dir/txt" or die $!;
+ open S, ">$dir/sig" or die $!;
+ print F $1;
+ print S $2;
+ close F;
+ close S;
+
+ unless (
+ uscan_exec_no_fail(
+ $self->{gpgv},
+ '--homedir' => $self->{gpghome},
+ '--keyring' => $self->{keyring},
+ "$dir/sig", "$dir/txt"
+ ) >> 8 == 0
+ ) {
+ uscan_die("OpenPGP signature did not verify.");
+ }
+ remove_tree($dir);
+}
+
+1;
diff --git a/lib/Devscripts/Uscan/Output.pm b/lib/Devscripts/Uscan/Output.pm
new file mode 100644
index 0000000..68c1739
--- /dev/null
+++ b/lib/Devscripts/Uscan/Output.pm
@@ -0,0 +1,99 @@
+package Devscripts::Uscan::Output;
+
+use strict;
+use Devscripts::Output;
+use Exporter 'import';
+use File::Basename;
+
+our @EXPORT = (
+ @Devscripts::Output::EXPORT, qw(
+ uscan_msg uscan_verbose dehs_verbose uscan_warn uscan_debug uscan_die
+ dehs_output $dehs $verbose $dehs_tags $dehs_start_output $dehs_end_output
+ $found
+ ));
+
+# ACCESSORS
+our ($dehs, $dehs_tags, $dehs_start_output, $dehs_end_output, $found)
+ = (0, {}, 0, 0);
+
+our $progname = basename($0);
+
+sub printwarn {
+ my ($msg, $w) = @_;
+ chomp $msg;
+ if ($w or $dehs) {
+ print STDERR "$msg\n";
+ } else {
+ print "$msg\n";
+ }
+}
+
+*uscan_msg = \&ds_msg;
+
+*uscan_verbose = \&ds_verbose;
+
+sub dehs_verbose ($) {
+ my $msg = $_[0];
+ push @{ $dehs_tags->{'messages'} }, "$msg\n";
+ uscan_verbose($msg);
+}
+
+sub uscan_warn ($) {
+ my $msg = $_[0];
+ push @{ $dehs_tags->{'warnings'} }, $msg if $dehs;
+ printwarn("$progname warn: $msg" . &Devscripts::Output::who_called, 1);
+}
+
+*uscan_debug = \&ds_debug;
+
+sub uscan_die ($) {
+ my $msg = $_[0];
+ if ($dehs) {
+ $dehs_tags = { 'errors' => "$msg" };
+ $dehs_end_output = 1;
+ dehs_output();
+ }
+ $msg = "$progname die: $msg" . &Devscripts::Output::who_called;
+ if ($Devscripts::Output::die_on_error) {
+ die $msg;
+ }
+ printwarn($msg, 1);
+}
+
+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/</&lt;/g;
+ $entry =~ s/>/&gt;/g;
+ $entry =~ s/&/&amp;/g;
+ print "<$tag>$entry</$tag>\n";
+ }
+ } else {
+ $dehs_tags->{$tag} =~ s/</&lt;/g;
+ $dehs_tags->{$tag} =~ s/>/&gt;/g;
+ $dehs_tags->{$tag} =~ s/&/&amp;/g;
+ print "<$tag>$dehs_tags->{$tag}</$tag>\n";
+ }
+ }
+ }
+ if ($dehs_end_output) {
+ print "</dehs>\n";
+ }
+
+ # Don't repeat output
+ $dehs_tags = {};
+}
+1;
diff --git a/lib/Devscripts/Uscan/Utils.pm b/lib/Devscripts/Uscan/Utils.pm
new file mode 100644
index 0000000..e65c776
--- /dev/null
+++ b/lib/Devscripts/Uscan/Utils.pm
@@ -0,0 +1,468 @@
+package Devscripts::Uscan::Utils;
+
+use strict;
+use Devscripts::Uscan::Output;
+use Devscripts::Utils;
+use Exporter 'import';
+
+our @EXPORT = (
+ qw(fix_href recursive_regex_dir newest_dir get_compression
+ get_suffix get_priority quoted_regex_parse safe_replace mangle
+ uscan_exec uscan_exec_no_fail)
+);
+
+#######################################################################
+# {{{ 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 recursive_regex_dir ($$$$$$) {
+
+ # If return '', parent code to cause return 1
+ my ($downloader, $base, $dirversionmangle, $watchfile, $lineptr,
+ $download_version)
+ = @_;
+
+ $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";
+ my $newest_dir = newest_dir($downloader, $site, $dir, $dirpattern,
+ $dirversionmangle, $watchfile, $lineptr, $download_version);
+ uscan_verbose "newest_dir => '$newest_dir'";
+ if ($newest_dir ne '') {
+ $dir .= "$newest_dir";
+ } else {
+ uscan_debug "No \$newest_dir";
+ return '';
+ }
+ } else {
+ $dir .= "$dirpattern";
+ }
+ }
+ return $site . $dir;
+}
+
+# very similar to code above
+sub newest_dir ($$$$$$$$) {
+
+ # return string $newdir as success
+ # return string '' if error, to cause grand parent code to return 1
+ my ($downloader, $site, $dir, $pattern, $dirversionmangle, $watchfile,
+ $lineptr, $download_version)
+ = @_;
+ my ($newdir);
+ uscan_verbose "Requesting URL:\n $site$dir";
+ if ($site =~ m%^http(s)?://%) {
+ require Devscripts::Uscan::http;
+ $newdir = Devscripts::Uscan::http::http_newdir($1, @_);
+ } elsif ($site =~ m%^ftp://%) {
+ require Devscripts::Uscan::ftp;
+ $newdir = Devscripts::Uscan::ftp::ftp_newdir(@_);
+ } else {
+ # Neither HTTP nor FTP site
+ uscan_warn "neither HTTP nor FTP site, impossible case for newdir().";
+ $newdir = '';
+ }
+ return $newdir;
+}
+#######################################################################
+# }}} code 5: utility functions (download)
+#######################################################################
+
+#######################################################################
+# {{{ code 6: utility functions (compression)
+#######################################################################
+# Get legal values for compression
+sub get_compression ($) {
+ my $compression = $_[0];
+ my $canonical_compression;
+
+ # be liberal in what you accept...
+ my %opt2comp = (
+ gz => 'gzip',
+ gzip => 'gzip',
+ bz2 => 'bzip2',
+ bzip2 => 'bzip2',
+ lzma => 'lzma',
+ xz => 'xz',
+ zip => 'zip',
+ );
+
+ # Normalize compression methods to the names used by Dpkg::Compression
+ if (exists $opt2comp{$compression}) {
+ $canonical_compression = $opt2comp{$compression};
+ } else {
+ uscan_die "$progname: invalid compression, $compression given.";
+ }
+ return $canonical_compression;
+}
+
+# Get legal values for compression suffix
+sub get_suffix ($) {
+ my $compression = $_[0];
+ my $canonical_suffix;
+
+ # be liberal in what you accept...
+ my %opt2suffix = (
+ gz => 'gz',
+ gzip => 'gz',
+ bz2 => 'bz2',
+ bzip2 => 'bz2',
+ lzma => 'lzma',
+ xz => 'xz',
+ zip => 'zip',
+ );
+
+ # Normalize compression methods to the names used by Dpkg::Compression
+ if (exists $opt2suffix{$compression}) {
+ $canonical_suffix = $opt2suffix{$compression};
+ } elsif ($compression eq 'default') {
+ require Devscripts::MkOrigtargz::Config;
+ return &Devscripts::MkOrigtargz::Config::default_compression;
+ } else {
+ uscan_die "$progname: invalid suffix, $compression given.";
+ }
+ return $canonical_suffix;
+}
+
+# Get compression priority
+sub get_priority ($) {
+ my $href = $_[0];
+ my $priority = 0;
+ if ($href =~ m/\.tar\.gz/i) {
+ $priority = 1;
+ }
+ if ($href =~ m/\.tar\.bz2/i) {
+ $priority = 2;
+ }
+ if ($href =~ m/\.tar\.lzma/i) {
+ $priority = 3;
+ }
+ if ($href =~ m/\.tar\.xz/i) {
+ $priority = 4;
+ }
+ return $priority;
+}
+#######################################################################
+# }}} code 6: utility functions (compression)
+#######################################################################
+
+#######################################################################
+# {{{ code 7: utility functions (regex)
+#######################################################################
+sub quoted_regex_parse($) {
+ my $pattern = shift;
+ my %closers = ('{', '}', '[', ']', '(', ')', '<', '>');
+
+ $pattern =~ /^(s|tr|y)(.)(.*)$/;
+ my ($sep, $rest) = ($2, $3 || '');
+ my $closer = $closers{$sep};
+
+ my $parsed_ok = 1;
+ my $regexp = '';
+ my $replacement = '';
+ my $flags = '';
+ my $open = 1;
+ my $last_was_escape = 0;
+ my $in_replacement = 0;
+
+ for my $char (split //, $rest) {
+ if ($char eq $sep and !$last_was_escape) {
+ $open++;
+ if ($open == 1) {
+ if ($in_replacement) {
+
+ # Separator after end of replacement
+ uscan_warn "Extra \"$sep\" after end of replacement.";
+ $parsed_ok = 0;
+ last;
+ } else {
+ $in_replacement = 1;
+ }
+ } else {
+ if ($open > 1) {
+ if ($in_replacement) {
+ $replacement .= $char;
+ } else {
+ $regexp .= $char;
+ }
+ }
+ }
+ } elsif ($char eq $closer and !$last_was_escape) {
+ $open--;
+ if ($open > 0) {
+ if ($in_replacement) {
+ $replacement .= $char;
+ } else {
+ $regexp .= $char;
+ }
+ } elsif ($open < 0) {
+ uscan_warn "Extra \"$closer\" after end of replacement.";
+ $parsed_ok = 0;
+ last;
+ }
+ } else {
+ if ($in_replacement) {
+ if ($open) {
+ $replacement .= $char;
+ } else {
+ $flags .= $char;
+ }
+ } else {
+ if ($open) {
+ $regexp .= $char;
+ } elsif ($char !~ m/\s/) {
+ uscan_warn
+ "Non-whitespace between <...> and <...> (or similars).";
+ $parsed_ok = 0;
+ last;
+ }
+
+ # skip if blanks between <...> and <...> (or similars)
+ }
+ }
+
+ # Don't treat \\ as an escape
+ $last_was_escape = ($char eq '\\' and !$last_was_escape);
+ }
+
+ unless ($in_replacement and $open == 0) {
+ uscan_warn "Empty replacement string.";
+ $parsed_ok = 0;
+ }
+
+ return ($parsed_ok, $regexp, $replacement, $flags);
+}
+
+sub safe_replace($$) {
+ my ($in, $pat) = @_;
+ eval "uscan_debug \"safe_replace input=\\\"\$\$in\\\"\\n\"";
+ $pat =~ s/^\s*(.*?)\s*$/$1/;
+
+ $pat =~ /^(s|tr|y)(.)/;
+ my ($op, $sep) = ($1, $2 || '');
+ my $esc = "\Q$sep\E";
+ my ($parsed_ok, $regexp, $replacement, $flags);
+
+ if ($sep eq '{' or $sep eq '(' or $sep eq '[' or $sep eq '<') {
+ ($parsed_ok, $regexp, $replacement, $flags) = quoted_regex_parse($pat);
+
+ unless ($parsed_ok) {
+ uscan_warn "stop mangling: rule=\"$pat\"\n"
+ . " mangling rule with <...>, (...), {...} failed.";
+ return 0;
+ }
+ } elsif ($pat
+ !~ /^(?:s|tr|y)$esc((?:\\.|[^\\$esc])*)$esc((?:\\.|[^\\$esc])*)$esc([a-z]*)$/
+ ) {
+ $sep = "/" if $sep eq '';
+ uscan_warn "stop mangling: rule=\"$pat\"\n"
+ . " rule doesn't match \"(s|tr|y)$sep.*$sep.*$sep\[a-z\]*\" (or similar).";
+ return 0;
+ } else {
+ ($regexp, $replacement, $flags) = ($1, $2, $3);
+ }
+
+ uscan_debug
+"safe_replace with regexp=\"$regexp\", replacement=\"$replacement\", and flags=\"$flags\"";
+ my $safeflags = $flags;
+ if ($op eq 'tr' or $op eq 'y') {
+ $safeflags =~ tr/cds//cd;
+ if ($safeflags ne $flags) {
+ uscan_warn "stop mangling: rule=\"$pat\"\n"
+ . " flags must consist of \"cds\" only.";
+ return 0;
+ }
+
+ $regexp =~ s/\\(.)/$1/g;
+ $replacement =~ s/\\(.)/$1/g;
+
+ $regexp =~ s/([^-])/'\\x' . unpack 'H*', $1/ge;
+ $replacement =~ s/([^-])/'\\x' . unpack 'H*', $1/ge;
+
+ eval "\$\$in =~ tr<$regexp><$replacement>$flags;";
+
+ if ($@) {
+ uscan_warn "stop mangling: rule=\"$pat\"\n"
+ . " mangling \"tr\" or \"y\" rule execution failed.";
+ return 0;
+ } else {
+ return 1;
+ }
+ } else {
+ $safeflags =~ tr/gix//cd;
+ if ($safeflags ne $flags) {
+ uscan_warn "stop mangling: rule=\"$pat\"\n"
+ . " flags must consist of \"gix\" only.";
+ return 0;
+ }
+
+ my $global = ($flags =~ s/g//);
+ $flags = "(?$flags)" if length $flags;
+
+ my $slashg;
+ if ($regexp =~ /(?<!\\)(\\\\)*\\G/) {
+ $slashg = 1;
+
+ # if it's not initial, it is too dangerous
+ if ($regexp =~ /^.*[^\\](\\\\)*\\G/) {
+ uscan_warn "stop mangling: rule=\"$pat\"\n"
+ . " dangerous use of \\G with regexp=\"$regexp\".";
+ return 0;
+ }
+ }
+
+ # Behave like Perl and treat e.g. "\." in replacement as "."
+ # We allow the case escape characters to remain and
+ # process them later
+ $replacement =~ s/(^|[^\\])\\([^luLUE])/$1$2/g;
+
+ # Unescape escaped separator characters
+ $replacement =~ s/\\\Q$sep\E/$sep/g;
+
+ # If bracketing quotes were used, also unescape the
+ # closing version
+ ### {{ ### (FOOL EDITOR for non-quoted kets)
+ $replacement =~ s/\\\Q}\E/}/g if $sep eq '{';
+ $replacement =~ s/\\\Q]\E/]/g if $sep eq '[';
+ $replacement =~ s/\\\Q)\E/)/g if $sep eq '(';
+ $replacement =~ s/\\\Q>\E/>/g if $sep eq '<';
+
+ # The replacement below will modify $replacement so keep
+ # a copy. We'll need to restore it to the current value if
+ # the global flag was set on the input pattern.
+ my $orig_replacement = $replacement;
+
+ my ($first, $last, $pos, $zerowidth, $matched, @captures) = (0, -1, 0);
+ while (1) {
+ eval {
+ # handle errors due to unsafe constructs in $regexp
+ no re 'eval';
+
+ # restore position
+ pos($$in) = $pos if $pos;
+
+ if ($zerowidth) {
+
+ # previous match was a zero-width match, simulate it to set
+ # the internal flag that avoids the infinite loop
+ $$in =~ /()/g;
+ }
+
+ # Need to use /g to make it use and save pos()
+ $matched = ($$in =~ /$flags$regexp/g);
+
+ if ($matched) {
+
+ # save position and size of the match
+ my $oldpos = $pos;
+ $pos = pos($$in);
+ ($first, $last) = ($-[0], $+[0]);
+
+ if ($slashg) {
+
+ # \G in the match, weird things can happen
+ $zerowidth = ($pos == $oldpos);
+
+ # For example, matching without a match
+ $matched = 0
+ if ( not defined $first
+ or not defined $last);
+ } else {
+ $zerowidth = ($last - $first == 0);
+ }
+ for my $i (0 .. $#-) {
+ $captures[$i] = substr $$in, $-[$i], $+[$i] - $-[$i];
+ }
+ }
+ };
+ if ($@) {
+ uscan_warn "stop mangling: rule=\"$pat\"\n"
+ . " mangling \"s\" rule execution failed.";
+ return 0;
+ }
+
+ # No match; leave the original string untouched but return
+ # success as there was nothing wrong with the pattern
+ return 1 unless $matched;
+
+ # Replace $X
+ $replacement
+ =~ s/[\$\\](\d)/defined $captures[$1] ? $captures[$1] : ''/ge;
+ $replacement
+ =~ s/\$\{(\d)\}/defined $captures[$1] ? $captures[$1] : ''/ge;
+ $replacement =~ s/\$&/$captures[0]/g;
+
+ # Make \l etc escapes work
+ $replacement =~ s/\\l(.)/lc $1/e;
+ $replacement =~ s/\\L(.*?)(\\E|\z)/lc $1/e;
+ $replacement =~ s/\\u(.)/uc $1/e;
+ $replacement =~ s/\\U(.*?)(\\E|\z)/uc $1/e;
+
+ # Actually do the replacement
+ substr $$in, $first, $last - $first, $replacement;
+
+ # Update position
+ $pos += length($replacement) - ($last - $first);
+
+ if ($global) {
+ $replacement = $orig_replacement;
+ } else {
+ last;
+ }
+ }
+
+ return 1;
+ }
+}
+
+# call this as
+# if mangle($watchfile, \$line, 'uversionmangle:',
+# \@{$options{'uversionmangle'}}, \$version) {
+# return 1;
+# }
+sub mangle($$$$$) {
+ my ($watchfile, $lineptr, $name, $rulesptr, $verptr) = @_;
+ foreach my $pat (@{$rulesptr}) {
+ if (!safe_replace($verptr, $pat)) {
+ uscan_warn "In $watchfile, potentially"
+ . " unsafe or malformed $name"
+ . " pattern:\n '$pat'"
+ . " found. Skipping watchline\n"
+ . " $$lineptr";
+ return 1;
+ }
+ uscan_debug "After $name $$verptr";
+ }
+ return 0;
+}
+
+*uscan_exec_no_fail = \&ds_exec_no_fail;
+
+*uscan_exec = \&ds_exec;
+
+#######################################################################
+# }}} code 7: utility functions (regex)
+#######################################################################
+
+1;
diff --git a/lib/Devscripts/Uscan/WatchFile.pm b/lib/Devscripts/Uscan/WatchFile.pm
new file mode 100644
index 0000000..a8b5508
--- /dev/null
+++ b/lib/Devscripts/Uscan/WatchFile.pm
@@ -0,0 +1,408 @@
+
+=head1 NAME
+
+Devscripts::Uscan::WatchFile - watchfile object for L<uscan>
+
+=head1 SYNOPSIS
+
+ use Devscripts::Uscan::Config;
+ use Devscripts::Uscan::WatchFile;
+
+ my $config = Devscripts::Uscan::Config->new({
+ # Uscan config parameters. Example:
+ destdir => '..',
+ });
+
+ # You can use Devscripts::Uscan::FindFiles to find watchfiles
+
+ my $wf = Devscripts::Uscan::WatchFile->new({
+ config => $config,
+ package => $package,
+ pkg_dir => $pkg_dir,
+ pkg_version => $version,
+ watchfile => $watchfile,
+ });
+ return $wf->status if ( $wf->status );
+
+ # Do the job
+ return $wf->process_lines;
+
+=head1 DESCRIPTION
+
+Uscan class to parse watchfiles.
+
+=head1 METHODS
+
+=head2 new() I<(Constructor)>
+
+Parse watch file and creates L<Devscripts::Uscan::WatchLine> objects for
+each line.
+
+=head3 Required parameters
+
+=over
+
+=item config: L<Devscripts::Uscan::Config> object
+
+=item package: Debian package name
+
+=item pkg_dir: Working directory
+
+=item pkg_version: Current Debian package version
+
+=back
+
+=head2 Main accessors
+
+=over
+
+=item watchlines: ref to the array that contains watchlines objects
+
+=item watch_version: format version of the watchfile
+
+=back
+
+=head2 process_lines()
+
+Method that launches Devscripts::Uscan::WatchLine::process() on each watchline.
+
+=head1 SEE ALSO
+
+L<uscan>, L<Devscripts::Uscan::WatchLine>, L<Devscripts::Uscan::Config>,
+L<Devscripts::Uscan::FindFiles>
+
+=head1 AUTHOR
+
+B<uscan> was originally written by Christoph Lameter
+E<lt>clameter@debian.orgE<gt> (I believe), modified by Julian Gilbey
+E<lt>jdg@debian.orgE<gt>. HTTP support was added by Piotr Roszatycki
+E<lt>dexter@debian.orgE<gt>. B<uscan> was rewritten in Perl by Julian Gilbey.
+Xavier Guimard E<lt>yadd@debian.orgE<gt> rewrote uscan in object
+oriented Perl.
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2002-2006 by Julian Gilbey <jdg@debian.org>,
+2018 by Xavier Guimard <yadd@debian.org>
+
+This program is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or
+(at your option) any later version.
+
+=cut
+
+package Devscripts::Uscan::WatchFile;
+
+use strict;
+use Devscripts::Uscan::Downloader;
+use Devscripts::Uscan::Output;
+use Devscripts::Uscan::WatchLine;
+use File::Copy qw/copy move/;
+use List::Util qw/first/;
+use Moo;
+
+use constant {
+ ANY_VERSION => '(?:[-_]?(\d[\-+\.:\~\da-zA-Z]*))',
+ ARCHIVE_EXT => '(?i)(?:\.(?:tar\.xz|tar\.bz2|tar\.gz|zip|tgz|tbz|txz))',
+ DEB_EXT => '(?:[\+~](debian|dfsg|ds|deb)(\.)?(\d+)?$)',
+};
+use constant SIGNATURE_EXT => ARCHIVE_EXT . '(?:\.(?:asc|pgp|gpg|sig|sign))';
+
+# Required new() parameters
+has config => (is => 'rw', required => 1);
+has package => (is => 'ro', required => 1); # Debian package
+has pkg_dir => (is => 'ro', required => 1);
+has pkg_version => (is => 'ro', required => 1);
+has bare => (
+ is => 'rw',
+ lazy => 1,
+ default => sub { $_[0]->config->bare });
+has download => (
+ is => 'rw',
+ lazy => 1,
+ default => sub { $_[0]->config->download });
+has downloader => (
+ is => 'ro',
+ lazy => 1,
+ default => sub {
+ Devscripts::Uscan::Downloader->new({
+ timeout => $_[0]->config->timeout,
+ agent => $_[0]->config->user_agent,
+ pasv => $_[0]->config->pasv,
+ destdir => $_[0]->config->destdir,
+ });
+ },
+);
+has signature => (
+ is => 'rw',
+ required => 1,
+ lazy => 1,
+ default => sub { $_[0]->config->signature });
+has watchfile => (is => 'ro', required => 1); # usually debian/watch
+
+# Internal attributes
+has group => (is => 'rw', default => sub { [] });
+has origcount => (is => 'rw');
+has origtars => (is => 'rw', default => sub { [] });
+has status => (is => 'rw', default => sub { 0 });
+has watch_version => (is => 'rw');
+has watchlines => (is => 'rw', default => sub { [] });
+
+# Values shared between lines
+has shared => (
+ is => 'rw',
+ lazy => 1,
+ default => \&new_shared,
+);
+
+sub new_shared {
+ return {
+ bare => $_[0]->bare,
+ components => [],
+ common_newversion => undef,
+ common_mangled_newversion => undef,
+ download => $_[0]->download,
+ download_version => undef,
+ origcount => undef,
+ origtars => [],
+ previous_download_available => undef,
+ previous_newversion => undef,
+ previous_newfile_base => undef,
+ previous_sigfile_base => undef,
+ signature => $_[0]->signature,
+ uscanlog => undef,
+ };
+}
+has keyring => (
+ is => 'ro',
+ default => sub { Devscripts::Uscan::Keyring->new });
+
+sub BUILD {
+ my ($self, $args) = @_;
+ my $watch_version = 0;
+ my $nextline;
+ $dehs_tags = {};
+
+ uscan_verbose "Process watch file at: $args->{watchfile}\n"
+ . " package = $args->{package}\n"
+ . " version = $args->{pkg_version}\n"
+ . " pkg_dir = $args->{pkg_dir}";
+
+ $self->origcount(0); # reset to 0 for each watch file
+ unless (open WATCH, $args->{watchfile}) {
+ uscan_warn "could not open $args->{watchfile}: $!";
+ return 1;
+ }
+
+ my $lineNumber = 0;
+ while (<WATCH>) {
+ next if /^\s*\#/;
+ next if /^\s*$/;
+ s/^\s*//;
+
+ CHOMP:
+
+ # Reassemble lines split using \
+ chomp;
+ if (s/(?<!\\)\\$//) {
+ if (eof(WATCH)) {
+ uscan_warn
+ "$args->{watchfile} ended with \\; skipping last line";
+ $self->status(1);
+ last;
+ }
+ if ($watch_version > 3) {
+
+ # drop leading \s only if version 4
+ $nextline = <WATCH>;
+ $nextline =~ s/^\s*//;
+ $_ .= $nextline;
+ } else {
+ $_ .= <WATCH>;
+ }
+ goto CHOMP;
+ }
+
+ # "version" must be the first field
+ if (!$watch_version) {
+
+ # Looking for "version" field.
+ if (/^version\s*=\s*(\d+)(\s|$)/) { # Found
+ $watch_version = $1;
+
+ # Note that version=1 watchfiles have no "version" field so
+ # authorizated values are >= 2 and <= CURRENT_WATCHFILE_VERSION
+ if ( $watch_version < 2
+ or $watch_version
+ > $Devscripts::Uscan::Config::CURRENT_WATCHFILE_VERSION) {
+ # "version" field found but has no authorizated value
+ uscan_warn
+"$args->{watchfile} version number is unrecognised; skipping watch file";
+ last;
+ }
+
+ # Next line
+ next;
+ }
+
+ # version=1 is deprecated
+ else {
+ uscan_warn
+ "$args->{watchfile} is an obsolete version 1 watch file;\n"
+ . " please upgrade to a higher version\n"
+ . " (see uscan(1) for details).";
+ $watch_version = 1;
+ }
+ }
+
+ # "version" is fixed, parsing lines now
+
+ # 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
+ s/\@PACKAGE\@/$args->{package}/g;
+ s/\@ANY_VERSION\@/ANY_VERSION/ge;
+ s/\@ARCHIVE_EXT\@/ARCHIVE_EXT/ge;
+ s/\@SIGNATURE_EXT\@/SIGNATURE_EXT/ge;
+ s/\@DEB_EXT\@/DEB_EXT/ge;
+
+ my $line = Devscripts::Uscan::WatchLine->new({
+ # Shared between lines
+ config => $self->config,
+ downloader => $self->downloader,
+ shared => $self->shared,
+ keyring => $self->keyring,
+
+ # Other parameters
+ line => $_,
+ pkg => $self->package,
+ pkg_dir => $self->pkg_dir,
+ pkg_version => $self->pkg_version,
+ watch_version => $watch_version,
+ watchfile => $self->watchfile,
+ });
+ push @{ $self->group }, $lineNumber
+ if ($line->type and $line->type eq 'group');
+ push @{ $self->watchlines }, $line;
+ $lineNumber++;
+ }
+
+ close WATCH
+ or $self->status(1),
+ uscan_warn "problems reading $$args->{watchfile}: $!";
+ $self->watch_version($watch_version);
+}
+
+sub process_lines {
+ my ($self) = shift;
+ return $self->process_group if (@{ $self->group });
+ foreach (@{ $self->watchlines }) {
+
+ # search newfile and newversion
+ my $res = $_->process;
+ $self->status($res) if ($res);
+ }
+ return $self->{status};
+}
+
+sub process_group {
+ my ($self) = @_;
+ # Build version
+ my @cur_versions = split /\+~/, $self->pkg_version;
+ my (@new_versions, @last_debian_mangled_uversions, @last_versions);
+ my $download = 0;
+ my $last_shared = $self->shared;
+ my $last_comp_version;
+ # Isolate component and following lines
+ foreach my $line (@{ $self->watchlines }) {
+ if ($line->type and $line->type eq 'group') {
+ $last_shared = $self->new_shared;
+ $last_comp_version = shift @cur_versions;
+ }
+ $line->shared($last_shared);
+ $line->pkg_version($last_comp_version || 0);
+ }
+ # Check if download is needed
+ foreach my $line (@{ $self->watchlines }) {
+ next unless ($line->type eq 'group');
+ # Stop on error
+ if ( $line->parse
+ or $line->search
+ or $line->get_upstream_url
+ or $line->get_newfile_base
+ or $line->cmp_versions) {
+ $self->{status} += $line->status;
+ return $self->{status};
+ }
+ $download = $line->shared->{download}
+ if ($line->shared->{download} > $download);
+ }
+ foreach my $line (@{ $self->watchlines }) {
+ # Set same $download for all
+ $line->shared->{download} = $download;
+ # Non "group" lines where not initialized
+ unless ($line->type eq 'group') {
+ if ( $line->parse
+ or $line->search
+ or $line->get_upstream_url
+ or $line->get_newfile_base
+ or $line->cmp_versions) {
+ $self->{status} += $line->status;
+ return $self->{status};
+ }
+ }
+ if ($line->download_file_and_sig) {
+ $self->{status} += $line->status;
+ return $self->{status};
+ }
+ if ($line->mkorigtargz) {
+ $self->{status} += $line->status;
+ return $self->{status};
+ }
+ if ($line->type eq 'group') {
+ push @new_versions, $line->shared->{common_mangled_newversion}
+ || $line->shared->{common_newversion}
+ || ();
+ push @last_versions, $line->parse_result->{lastversion};
+ push @last_debian_mangled_uversions,
+ $line->parse_result->{mangled_lastversion};
+ }
+ }
+ my $new_version = join '+~', @new_versions;
+ $dehs_tags->{'upstream-version'} = $new_version;
+ $dehs_tags->{'debian-uversion'} = join('+~', @last_versions)
+ if (grep { $_ } @last_versions);
+ $dehs_tags->{'debian-mangled-uversion'} = join '+~',
+ @last_debian_mangled_uversions
+ if (grep { $_ } @last_debian_mangled_uversions);
+ my $mangled_ver
+ = Dpkg::Version->new("1:" . $dehs_tags->{'debian-uversion'} . "-0",
+ check => 0);
+ my $upstream_ver = Dpkg::Version->new("1:$new_version-0", check => 0);
+ if ($mangled_ver == $upstream_ver) {
+ $dehs_tags->{'status'} = "up to date";
+ } elsif ($mangled_ver > $upstream_ver) {
+ $dehs_tags->{'status'} = "only older package available";
+ } else {
+ $dehs_tags->{'status'} = "newer package available";
+ }
+ foreach my $line (@{ $self->watchlines }) {
+ my $path = $line->destfile or next;
+ my $ver = $line->shared->{common_mangled_newversion};
+ $path =~ s/\Q$ver\E/$new_version/;
+ print STDERR "mv $line->{destfile} to $path\n";
+ rename $line->{destfile}, $path;
+ if ($line->signature_available) {
+ rename "$line->{destfile}.asc", "$path.asc";
+ rename "$line->{destfile}.sig", "$path.sig";
+ }
+ }
+ return 0;
+}
+
+1;
diff --git a/lib/Devscripts/Uscan/WatchLine.pm b/lib/Devscripts/Uscan/WatchLine.pm
new file mode 100644
index 0000000..d70ef8d
--- /dev/null
+++ b/lib/Devscripts/Uscan/WatchLine.pm
@@ -0,0 +1,1741 @@
+
+=pod
+
+=head1 NAME
+
+Devscripts::Uscan::WatchLine - watch line object for L<uscan>
+
+=head1 DESCRIPTION
+
+Uscan class to parse watchfiles.
+
+=head1 MAIN METHODS
+
+=cut
+
+package Devscripts::Uscan::WatchLine;
+
+use strict;
+use Cwd qw/abs_path/;
+use Devscripts::Uscan::Keyring;
+use Devscripts::Uscan::Output;
+use Devscripts::Uscan::Utils;
+use Dpkg::IPC;
+use Dpkg::Version;
+use File::Basename;
+use File::Copy;
+use File::Spec::Functions qw/catfile/;
+use HTTP::Headers;
+use Moo;
+use Text::ParseWords;
+
+#################
+### ACCESSORS ###
+#################
+
+=head2 new() I<(Constructor)>
+
+=head3 Required parameters
+
+=over
+
+=item B<shared>: ref to hash containing line options shared between lines. See
+L<Devscripts::Uscan::WatchFile> code to see required keys.
+
+=item B<keyring>: L<Devscripts::Uscan::Keyring> object
+
+=item B<config>: L<Devscripts::Uscan::Config> object
+
+=item B<downloader>: L<Devscripts::Uscan::Downloader> object
+
+=item B<line>: search line (assembled in one line)
+
+=item B<pkg>: Debian package name
+
+=item B<pkg_dir>: Debian package source directory
+
+=item B<pkg_version>: Debian package version
+
+=item B<watchfile>: Current watchfile
+
+=item B<watch_version>: Version of current watchfile
+
+=back
+
+=cut
+
+foreach (
+
+ # Shared attributes stored in WatchFile object (ref to WatchFile value)
+ 'shared', 'keyring', 'config',
+
+ # Other
+ 'downloader', # Devscripts::Uscan::Downloader object
+ 'line', # watch line string (concatenated line over the tailing \ )
+ 'pkg', # source package name found in debian/changelog
+ 'pkg_dir', # usually .
+ 'pkg_version', # last source package version
+ # found in debian/changelog
+ 'watchfile', # usually debian/watch
+ 'watch_version', # usually 4 (or 3)
+) {
+ has $_ => (is => 'rw', required => 1);
+}
+
+has repack => (
+ is => 'rw',
+ lazy => 1,
+ default => sub { $_[0]->config->{repack} },
+);
+
+has safe => (
+ is => 'rw',
+ lazy => 1,
+ default => sub { $_[0]->config->{safe} },
+);
+
+has symlink => (
+ is => 'rw',
+ lazy => 1,
+ default => sub { $_[0]->config->{symlink} },
+);
+
+has versionmode => (
+ is => 'rw',
+ lazy => 1,
+ default => sub { 'newer' },
+);
+
+has destfile => (is => 'rw');
+has sigfile => (is => 'rw');
+
+# 2 - Line options read/write attributes
+
+foreach (qw(
+ component hrefdecode repacksuffix unzipopt searchmode
+ dirversionmangle downloadurlmangle dversionmangle filenamemangle pagemangle
+ oversionmangle oversionmanglepagemangle pgpsigurlmangle uversionmangle
+ versionmangle
+ )
+) {
+ has $_ => (
+ is => 'rw',
+ (/mangle/ ? (default => sub { [] }) : ()));
+}
+
+has compression => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ $_[0]->config->compression
+ ? get_compression($_[0]->config->compression)
+ : undef;
+ },
+);
+has versionless => (is => 'rw');
+
+# 4 - Internal attributes
+has style => (is => 'rw', default => sub { 'new' });
+has status => (is => 'rw', default => sub { 0 });
+foreach (
+ qw(badversion
+ signature_available must_download)
+) {
+ has $_ => (is => 'rw', default => sub { 0 });
+}
+foreach (qw(mangled_version)) {
+ has $_ => (is => 'rw');
+}
+foreach (qw(sites basedirs patterns)) {
+ has $_ => (is => 'rw', default => sub { [] });
+}
+
+# 5 - Results
+foreach (qw(parse_result search_result)) {
+ has $_ => (is => 'rw', default => sub { {} });
+}
+foreach (qw(force_repack type upstream_url newfile_base)) {
+ has $_ => (is => 'rw');
+}
+
+# 3.1 - Attributes initialized with default value, modified by line content
+has date => (
+ is => 'rw',
+ default => sub { '%Y%m%d' },
+);
+has decompress => (
+ is => 'rw',
+ default => sub { 0 },
+);
+has gitmode => (
+ is => 'rw',
+ default => sub { 'shallow' },
+);
+has mode => (
+ is => 'rw',
+ default => sub { 'LWP' },
+);
+has pgpmode => (
+ is => 'rw',
+ default => sub { 'default' },
+);
+has pretty => (
+ is => 'rw',
+ default => sub { '0.0~git%cd.%h' },
+);
+
+# 3.2 - Self build attributes
+
+has gitrepo_dir => ( # Working repository used only within uscan.
+ is => 'ro',
+ lazy => 1,
+ default => sub {
+ $_[0]->{pkg} . "-temporary.$$.git";
+ });
+has headers => (
+ is => 'ro',
+ default => sub {
+ my $h = HTTP::Headers->new;
+ $h->header(
+ 'X-uscan-features' => 'enhanced-matching',
+ 'Accept' => '*/*'
+ );
+ return $h;
+ },
+);
+
+my $minversion = '';
+
+###############
+# Main method #
+###############
+
+=head2 process()
+
+Launches all needed methods in this order: parse(), search(),
+get_upstream_url(), get_newfile_base(), cmp_versions(),
+download_file_and_sig(), mkorigtargz(), clean()
+
+If one method returns a non 0 value, it stops and return this error code.
+
+=cut
+
+sub process {
+ my ($self) = @_;
+
+ # - parse line
+ $self->parse
+
+ # - search newfile and newversion
+ or $self->search
+
+ # - determine upstream_url
+ or $self->get_upstream_url
+
+ # - determine newfile_base
+ or $self->get_newfile_base
+
+ # - compare versions
+ or $self->cmp_versions
+
+ # - download
+ or $self->download_file_and_sig
+
+ # - make orig.tar.gz
+ or $self->mkorigtargz
+
+ # - clean (used by git)
+ or $self->clean;
+ return $self->status;
+}
+
+#########
+# STEPS #
+#########
+
+=head2 Steps
+
+=cut
+
+# I - parse
+
+=head3 parse()
+
+Parse the line and return 0 if nothing bad happen. It populates
+C<$self-E<gt>parse_result> accessor with a hash that contains the
+following keys:
+
+=over
+
+=item base
+=item filepattern
+=item lastversion
+=item action
+=item site
+=item basedir
+=item mangled_lastversion
+=item pattern
+
+=back
+
+=cut
+
+# watch_version=1: Lines have up to 5 parameters which are:
+#
+# $1 = Remote site
+# $2 = Directory on site
+# $3 = Pattern to match, with (...) around version number part
+# $4 = Last version we have (or 'debian' for the current Debian version)
+# $5 = Actions to take on successful retrieval
+#
+# watch_version=2:
+#
+# For ftp sites:
+# ftp://site.name/dir/path/pattern-(.+)\.tar\.gz [version [action]]
+#
+# For http sites:
+# http://site.name/dir/path/pattern-(.+)\.tar\.gz [version [action]]
+#
+# watch_version=3 and 4: See details in POD.
+#
+# For ftp sites:
+# ftp://site.name/dir/path pattern-(.+)\.tar\.gz [version [action]]
+#
+# For http sites:
+# http://site.name/dir/path pattern-(.+)\.tar\.gz [version [action]]
+#
+# For git sites:
+# http://site.name/dir/path/project.git refs/tags/v([\d\.]+) [version [action]]
+# or
+# http://site.name/dir/path/project.git HEAD [version [action]]
+#
+# watch_version=3 and 4: See POD for details.
+#
+# Lines can be prefixed with opts=<opts> but can be folded for readability.
+#
+# Then the patterns matched will be checked to find the one with the
+# greatest version number (as determined by the (...) group), using the
+# Debian version number comparison algorithm described below.
+
+sub BUILD {
+ my ($self, $args) = @_;
+ if ($self->watch_version > 3) {
+ my $line = $self->line;
+ if ($line =~ s/^opt(?:ion)?s\s*=\s*//) {
+ unless ($line =~ s/^".*?"(?:\s+|$)//) {
+ $line =~ s/^[^"\s]\S*(?:\s+|$)//;
+ }
+ }
+ my ($base, $filepattern, $lastversion, $action) = split /\s+/, $line,
+ 4;
+ $self->type($lastversion);
+ }
+ return $self;
+}
+
+sub parse {
+ my ($self) = @_;
+ uscan_debug "parse line $self->{line}";
+
+ # Need to clear remembered redirection URLs so we don't try to build URLs
+ # from previous watch files or watch lines
+ $self->downloader->user_agent->clear_redirections;
+
+ my $watchfile = $self->watchfile;
+ my ($action, $base, $basedir, $filepattern, $lastversion, $pattern, $site);
+ $dehs_tags->{package} = $self->pkg;
+
+ # Start parsing the watch line
+ if ($self->watch_version == 1) {
+ my ($dir);
+ ($site, $dir, $filepattern, $lastversion, $action) = split ' ',
+ $self->line, 5;
+ if ( !$lastversion
+ or $site =~ /\(.*\)/
+ or $dir =~ /\(.*\)/) {
+ uscan_warn <<EOF;
+there appears to be a version 2 format line in
+the version 1 watch file $watchfile;
+Have you forgotten a 'version=2' line at the start, perhaps?
+Skipping the line: $self->{line}
+EOF
+ return $self->status(1);
+ }
+ if ($site !~ m%\w+://%) {
+ $site = "ftp://$site";
+ if ($filepattern !~ /\(.*\)/) {
+
+ # watch_version=1 and old style watch file;
+ # pattern uses ? and * shell wildcards; everything from the
+ # first to last of these metachars is the pattern to match on
+ $filepattern =~ s/(\?|\*)/($1/;
+ $filepattern =~ s/(\?|\*)([^\?\*]*)$/$1)$2/;
+ $filepattern =~ s/\./\\./g;
+ $filepattern =~ s/\?/./g;
+ $filepattern =~ s/\*/.*/g;
+ $self->style('old');
+ uscan_warn
+ "Using very old style of filename pattern in $watchfile\n"
+ . " (this might lead to incorrect results): $3";
+ }
+ }
+
+ # Merge site and dir
+ $base = "$site/$dir/";
+ $base =~ s%(?<!:)//%/%g;
+ $base =~ m%^(\w+://[^/]+)%;
+ $site = $1;
+ $pattern = $filepattern;
+
+ # Check $filepattern is OK
+ if ($filepattern !~ /\(.*\)/) {
+ uscan_warn "Filename pattern missing version delimiters ()\n"
+ . " in $watchfile, skipping:\n $self->{line}";
+ return $self->status(1);
+ }
+ } else {
+ # version 2/3/4 watch file
+ if ($self->{line} =~ s/^opt(?:ion)?s\s*=\s*//) {
+ my $opts;
+ if ($self->{line} =~ s/^"(.*?)"(?:\s+|$)//) {
+ $opts = $1;
+ } elsif ($self->{line} =~ s/^([^"\s]\S*)(?:\s+|$)//) {
+ $opts = $1;
+ } else {
+ uscan_warn
+"malformed opts=... in watch file, skipping line:\n$self->{line}";
+ return $self->status(1);
+ }
+
+ # $opts string extracted from the argument of opts=
+ uscan_verbose "opts: $opts";
+
+ # $self->line watch line string without opts=... part
+ uscan_verbose "line: $self->{line}";
+
+ # user-agent strings has ,;: in it so special handling
+ if ( $opts =~ /^\s*user-agent\s*=\s*(.+?)\s*$/
+ or $opts =~ /^\s*useragent\s*=\s*(.+?)\s*$/) {
+ my $user_agent_string = $1;
+ $user_agent_string = $self->config->user_agent
+ if $self->config->user_agent ne
+ &Devscripts::Uscan::Config::default_user_agent;
+ $self->downloader->user_agent->agent($user_agent_string);
+ uscan_verbose "User-agent: $user_agent_string";
+ $opts = '';
+ }
+ my @opts = split /,/, $opts;
+ foreach my $opt (@opts) {
+ next unless ($opt =~ /\S/);
+ uscan_verbose "Parsing $opt";
+ if ($opt =~ /^\s*pasv\s*$/ or $opt =~ /^\s*passive\s*$/) {
+ $self->downloader->pasv(1);
+ } elsif ($opt =~ /^\s*active\s*$/
+ or $opt =~ /^\s*nopasv\s*$/
+ or $opt =~ /^s*nopassive\s*$/) {
+ $self->downloader->pasv(0);
+ }
+
+ # Line option "compression" is ignored if "--compression"
+ # was set in command-line
+ elsif ($opt =~ /^\s*compression\s*=\s*(.+?)\s*$/
+ and not $self->compression) {
+ $self->compression(get_compression($1));
+ } elsif ($opt =~ /^\s*bare\s*$/) {
+
+ # persistent $bare
+ ${ $self->shared->{bare} } = 1;
+ }
+
+ # Boolean line parameter
+ #
+ # $ regexp-assemble <<EOF
+ # decompress
+ # repack
+ # EOF
+ elsif ($opt =~ /^\s*(decompress|repack)\s*$/) {
+ $self->$1(1);
+ }
+
+ # Line parameter with a value
+ #
+ # $ regexp-assemble <<EOF
+ # component
+ # date
+ # gitmode
+ # hrefdecode
+ # mode
+ # pgpmode
+ # pretty
+ # repacksuffix
+ # searchmode
+ # unzipopt
+ # EOF
+ elsif ($opt
+ =~ /^\s*((?:(?:(?:search|git)?m|hrefdec)od|dat)e|(?:componen|unzipop)t|p(?:gpmode|retty)|repacksuffix)\s*=\s*(.+?)\s*$/
+ ) {
+ $self->$1($2);
+ } elsif ($opt =~ /^\s*versionmangle\s*=\s*(.+?)\s*$/) {
+ $self->uversionmangle([split /;/, $1]);
+ $self->dversionmangle([split /;/, $1]);
+ } elsif ($opt =~ /^\s*pgpsigurlmangle\s*=\s*(.+?)\s*$/) {
+ $self->pgpsigurlmangle([split /;/, $1]);
+ $self->pgpmode('mangle');
+ } elsif ($opt =~ /^\s*dversionmangle\s*=\s*(.+?)\s*$/) {
+
+ $self->dversionmangle([
+ map {
+
+ # If dversionmangle is "auto", replace it by
+ # DEB_EXT removal
+ $_ eq 'auto'
+ ? ('s/'
+ . &Devscripts::Uscan::WatchFile::DEB_EXT
+ . '//')
+ : ($_)
+ } split /;/,
+ $1
+ ]);
+ }
+
+ # Handle other *mangle:
+ #
+ # $ regexp-assemble <<EOF
+ # pagemangle
+ # dirversionmangle
+ # uversionmangle
+ # downloadurlmangle
+ # filenamemangle
+ # oversionmangle
+ # EOF
+ elsif ($opt
+ =~ /^\s*((?:d(?:ownloadurl|irversion)|(?:filenam|pag)e|[ou]version)mangle)\s*=\s*(.+?)\s*$/
+ ) {
+ $self->$1([split /;/, $2]);
+ } else {
+ uscan_warn "unrecognized option $opt";
+ }
+ }
+
+ # $self->line watch line string when no opts=...
+ uscan_verbose "line: $self->{line}";
+ }
+
+ if ($self->line eq '') {
+ uscan_verbose "watch line only with opts=\"...\" and no URL";
+ return $self->status(1);
+ }
+
+ # 4 parameter watch line
+ ($base, $filepattern, $lastversion, $action) = split /\s+/,
+ $self->line, 4;
+
+ # 3 parameter watch line (override)
+ if ($base =~ s%/([^/]*\([^/]*\)[^/]*)$%/%) {
+
+ # Last component of $base has a pair of parentheses, so no
+ # separate filepattern field; we remove the filepattern from the
+ # end of $base and rescan the rest of the line
+ $filepattern = $1;
+ (undef, $lastversion, $action) = split /\s+/, $self->line, 3;
+ }
+
+ # Always define "" if not defined
+ $lastversion //= '';
+ $action //= '';
+ if ($self->mode eq 'LWP') {
+ if ($base =~ m%^https?://%) {
+ $self->mode('http');
+ } elsif ($base =~ m%^ftp://%) {
+ $self->mode('ftp');
+ } else {
+ uscan_warn "unknown protocol for LWP: $base";
+ return $self->status(1);
+ }
+ }
+
+ # compression is persistent
+ $self->compression('default') unless ($self->compression);
+
+ # Set $lastversion to the numeric last version
+ # Update $self->versionmode (its default "newer")
+ if (!length($lastversion) or $lastversion =~ /^(group|debian)$/) {
+ if (!defined $self->pkg_version) {
+ uscan_warn "Unable to determine the current version\n"
+ . " in $watchfile, skipping:\n $self->{line}";
+ return $self->status(1);
+ }
+ $lastversion = $self->pkg_version;
+ } elsif ($lastversion eq 'ignore') {
+ $self->versionmode('ignore');
+ $lastversion = $minversion;
+ } elsif ($lastversion eq 'same') {
+ $self->versionmode('same');
+ $lastversion = $minversion;
+ } elsif ($lastversion =~ m/^prev/) {
+ $self->versionmode('previous');
+
+ # set $lastversion = $previous_newversion later
+ }
+
+ # Check $filepattern has ( ...)
+ if ($filepattern !~ /\([^?].*\)/) {
+ if ($self->mode eq 'git' and $filepattern eq 'HEAD') {
+ $self->versionless(1);
+ } elsif ($self->mode eq 'git'
+ and $filepattern =~ m&^heads/&) {
+ $self->versionless(1);
+ } elsif ($self->mode eq 'http'
+ and @{ $self->filenamemangle }) {
+ $self->versionless(1);
+ } else {
+ uscan_warn
+ "Tag pattern missing version delimiters () in $watchfile"
+ . ", skipping:\n $self->{line}";
+ return $self->status(1);
+ }
+ }
+
+ # Check validity of options
+ if ($self->mode eq 'ftp'
+ and @{ $self->downloadurlmangle }) {
+ uscan_warn "downloadurlmangle option invalid for ftp sites,\n"
+ . " ignoring downloadurlmangle in $watchfile:\n"
+ . " $self->{line}";
+ return $self->status(1);
+ }
+
+ # Limit use of opts="repacksuffix" to the single upstream package
+ if ($self->repacksuffix and @{ $self->shared->{components} }) {
+ uscan_warn
+"repacksuffix is not compatible with the multiple upstream tarballs;\n"
+ . " use oversionmangle";
+ return $self->status(1);
+ }
+
+ # Allow 2 char shorthands for opts="pgpmode=..." and check
+ if ($self->pgpmode =~ m/^au/) {
+ $self->pgpmode('auto');
+ if (@{ $self->pgpsigurlmangle }) {
+ uscan_warn "Ignore pgpsigurlmangle because pgpmode=auto";
+ $self->pgpsigurlmangle([]);
+ }
+ } elsif ($self->pgpmode =~ m/^ma/) {
+ $self->pgpmode('mangle');
+ if (not @{ $self->pgpsigurlmangle }) {
+ uscan_warn "Missing pgpsigurlmangle. Setting pgpmode=default";
+ $self->pgpmode('default');
+ }
+ } elsif ($self->pgpmode =~ m/^no/) {
+ $self->pgpmode('none');
+ } elsif ($self->pgpmode =~ m/^ne/) {
+ $self->pgpmode('next');
+ } elsif ($self->pgpmode =~ m/^pr/) {
+ $self->pgpmode('previous');
+ $self->versionmode('previous'); # no other value allowed
+ # set $lastversion = $previous_newversion later
+ } elsif ($self->pgpmode =~ m/^se/) {
+ $self->pgpmode('self');
+ } elsif ($self->pgpmode =~ m/^git/) {
+ $self->pgpmode('gittag');
+ } else {
+ $self->pgpmode('default');
+ }
+
+ # If PGP used, check required programs and generate files
+ if (@{ $self->pgpsigurlmangle }) {
+ my $pgpsigurlmanglestring = join(";", @{ $self->pgpsigurlmangle });
+ uscan_debug "\$self->{'pgpmode'}=$self->{'pgpmode'}, "
+ . "\$self->{'pgpsigurlmangle'}=$pgpsigurlmanglestring";
+ } else {
+ uscan_debug "\$self->{'pgpmode'}=$self->{'pgpmode'}, "
+ . "\$self->{'pgpsigurlmangle'}=undef";
+ }
+
+ # Check component for duplication and set $orig to the proper
+ # extension string
+ if ($self->pgpmode ne 'previous') {
+ if ($self->component) {
+ if (grep { $_ eq $self->component }
+ @{ $self->shared->{components} }) {
+ uscan_warn "duplicate component name: $self->{component}";
+ return $self->status(1);
+ }
+ push @{ $self->shared->{components} }, $self->component;
+ } else {
+ $self->shared->{origcount}++;
+ if ($self->shared->{origcount} > 1) {
+ uscan_warn "more than one main upstream tarballs listed.";
+
+ # reset variables
+ @{ $self->shared->{components} } = ();
+ $self->{shared}->{common_newversion} = undef;
+ $self->{shared}->{common_mangled_newversion} = undef;
+ $self->{shared}->{previous_newversion} = undef;
+ $self->{shared}->{previous_newfile_base} = undef;
+ $self->{shared}->{previous_sigfile_base} = undef;
+ $self->{shared}->{previous_download_available} = undef;
+ $self->{shared}->{uscanlog} = undef;
+ }
+ }
+ }
+
+ # Allow 2 char shorthands for opts="gitmode=..." and check
+ if ($self->gitmode =~ m/^sh/) {
+ $self->gitmode('shallow');
+ } elsif ($self->gitmode =~ m/^fu/) {
+ $self->gitmode('full');
+ } else {
+ uscan_warn
+ "Override strange manual gitmode '$self->gitmode --> 'shallow'";
+ $self->gitmode('shallow');
+ }
+
+ # Handle sf.net addresses specially
+ if (!$self->shared->{bare} and $base =~ m%^https?://sf\.net/%) {
+ uscan_verbose "sf.net redirection to qa.debian.org/watch/sf.php";
+ $base =~ s%^https?://sf\.net/%https://qa.debian.org/watch/sf.php/%;
+ $filepattern .= '(?:\?.*)?';
+ }
+
+ # Handle pypi.python.org addresses specially
+ if ( !$self->shared->{bare}
+ and $base =~ m%^https?://pypi\.python\.org/packages/source/%) {
+ uscan_verbose "pypi.python.org redirection to pypi.debian.net";
+ $base
+ =~ s%^https?://pypi\.python\.org/packages/source/./%https://pypi.debian.net/%;
+ }
+
+ # Handle pkg-ruby-extras gemwatch addresses specially
+ if ($base
+ =~ m%^https?://pkg-ruby-extras\.alioth\.debian\.org/cgi-bin/gemwatch%
+ ) {
+ uscan_warn
+"redirecting DEPRECATED pkg-ruby-extras.alioth.debian.org/cgi-bin/gemwatch"
+ . " to gemwatch.debian.net";
+ $base
+ =~ s%^https?://pkg-ruby-extras\.alioth\.debian\.org/cgi-bin/gemwatch%https://gemwatch.debian.net%;
+ }
+
+ }
+
+ # End parsing the watch line for all version=1/2/3/4
+ # all options('...') variables have been set
+
+ # Override the last version with --download-debversion
+ if ($self->config->download_debversion) {
+ $lastversion = $self->config->download_debversion;
+ $lastversion =~ s/-[^-]+$//; # revision
+ $lastversion =~ s/^\d+://; # epoch
+ uscan_verbose
+"specified --download-debversion to set the last version: $lastversion";
+ } elsif ($self->versionmode eq 'previous') {
+ $lastversion = $self->shared->{previous_newversion};
+ # $lastversion is set only if something was downloaded before
+ if ($lastversion) {
+ uscan_verbose "Previous version downloaded: $lastversion";
+ } else {
+ uscan_verbose "Previous version not set, skipping";
+ }
+ } else {
+ uscan_verbose
+"Last orig.tar.* tarball version (from debian/changelog): $lastversion";
+ }
+
+ # And mangle it if requested
+ my $mangled_lastversion = $lastversion;
+ if (
+ mangle(
+ $watchfile, \$self->line,
+ 'dversionmangle:', \@{ $self->dversionmangle },
+ \$mangled_lastversion
+ )
+ ) {
+ return $self->status(1);
+ }
+
+ # Set $download_version etc. if already known
+ if ($self->config->download_version) {
+ $self->shared->{download_version} = $self->config->download_version;
+ $self->shared->{download} = 2
+ if $self->shared->{download} == 1; # Change default 1 -> 2
+ $self->badversion(1);
+ uscan_verbose "Download the --download-version specified version: "
+ . "$self->{shared}->{download_version}";
+ } elsif ($self->config->download_debversion) {
+ $self->shared->{download_version} = $mangled_lastversion;
+ $self->shared->{download} = 2
+ if $self->shared->{download} == 1; # Change default 1 -> 2
+ $self->badversion(1);
+ uscan_verbose "Download the --download-debversion specified version "
+ . "(dversionmangled): $self->{shared}->{download_version}";
+ } elsif ($self->config->download_current_version) {
+ $self->shared->{download_version} = $mangled_lastversion;
+ $self->shared->{download} = 2
+ if $self->shared->{download} == 1; # Change default 1 -> 2
+ $self->badversion(1);
+ uscan_verbose
+ "Download the --download-current-version specified version: "
+ . "$self->{shared}->{download_version}";
+ } elsif ($self->versionmode eq 'same') {
+ unless (defined $self->shared->{common_newversion}) {
+ uscan_warn
+"Unable to set versionmode=prev for the line without opts=pgpmode=prev\n"
+ . " in $watchfile, skipping:\n"
+ . " $self->{line}";
+ return $self->status(1);
+ }
+ $self->shared->{download_version} = $self->shared->{common_newversion};
+ $self->shared->{download} = 2
+ if $self->shared->{download} == 1; # Change default 1 -> 2
+ $self->badversion(1);
+ uscan_verbose "Download secondary tarball with the matching version: "
+ . "$self->{shared}->{download_version}";
+ } elsif ($self->versionmode eq 'previous') {
+ unless ($self->pgpmode eq 'previous'
+ and defined $self->shared->{previous_newversion}) {
+ if ($self->shared->{download}) {
+ uscan_warn
+"Unable to set versionmode=prev for the line without opts=pgpmode=prev\n"
+ . " in $watchfile, skipping:\n $self->{line}";
+ } else {
+ uscan_warn "Nothing was downloaded before, skipping pgp check";
+ uscan_verbose " line " . $self->line;
+ }
+ return $self->status(1);
+ }
+ $self->shared->{download_version}
+ = $self->shared->{previous_newversion};
+ $self->shared->{download} = 2
+ if $self->shared->{download} == 1; # Change default 1 -> 2
+ $self->badversion(1);
+ uscan_verbose
+ "Download the signature file with the previous tarball's version:"
+ . " $self->{shared}->{download_version}";
+ } else {
+ # $options{'versionmode'} should be debian or ignore
+ if (defined $self->shared->{download_version}) {
+ uscan_die
+ "\$download_version defined after dversionmangle ... strange";
+ } else {
+ uscan_verbose "Last orig.tar.* tarball version (dversionmangled):"
+ . " $mangled_lastversion";
+ }
+ }
+
+ if ($self->watch_version != 1) {
+ if ($self->mode eq 'http' or $self->mode eq 'ftp') {
+ if ($base =~ m%^(\w+://[^/]+)%) {
+ $site = $1;
+ } else {
+ uscan_warn "Can't determine protocol and site in\n"
+ . " $watchfile, skipping:\n"
+ . " $self->{line}";
+ return $self->status(1);
+ }
+
+ # Find the path with the greatest version number matching the regex
+ $base
+ = recursive_regex_dir($self->downloader, $base,
+ $self->dirversionmangle, $watchfile, \$self->line,
+ $self->shared->{download_version});
+ if ($base eq '') {
+ return $self->status(1);
+ }
+
+ # We're going to make the pattern
+ # (?:(?:http://site.name)?/dir/path/)?base_pattern
+ # It's fine even for ftp sites
+ $basedir = $base;
+ $basedir =~ s%^\w+://[^/]+/%/%;
+ $pattern
+ = "(?:(?:$site)?" . quotemeta($basedir) . ")?$filepattern";
+ } else {
+ # git tag match is simple
+ $site = $base; # dummy
+ $basedir = ''; # dummy
+ $pattern = $filepattern;
+ }
+ }
+
+ push @{ $self->sites }, $site;
+ push @{ $self->basedirs }, $basedir;
+ push @{ $self->patterns }, $pattern;
+
+ my $match = '';
+
+# Start Checking $site and look for $filepattern which is newer than $lastversion
+ uscan_debug "watch file has:\n"
+ . " \$base = $base\n"
+ . " \$filepattern = $filepattern\n"
+ . " \$lastversion = $lastversion\n"
+ . " \$action = $action\n"
+ . " mode = $self->{mode}\n"
+ . " pgpmode = $self->{pgpmode}\n"
+ . " versionmode = $self->{versionmode}\n"
+ . " \$site = $site\n"
+ . " \$basedir = $basedir";
+
+ $self->parse_result({
+ base => $base,
+ filepattern => $filepattern,
+ lastversion => $lastversion,
+ action => $action,
+ site => $site,
+ basedir => $basedir,
+ mangled_lastversion => $mangled_lastversion,
+ pattern => $pattern,
+ });
+
+# What is the most recent file, based on the filenames?
+# 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)
+ return $self->status;
+}
+
+# II - search
+
+=head3 search()
+
+Search new file link and new version on the remote site using either:
+
+=over
+
+=item L<Devscripts::Uscan::http>::http_search()
+=item L<Devscripts::Uscan::ftp>::ftp_search()
+=item L<Devscripts::Uscan::git>::git_search()
+
+=back
+
+It populates B<$self-E<gt>search_result> hash ref with the following keys:
+
+=over
+
+=item B<newversion>: URL/tag pointing to the file to be downloaded
+=item B<newfile>: version number to be used for the downloaded file
+
+=back
+
+=cut
+
+sub search {
+ my ($self) = @_;
+ uscan_debug "line: search()";
+ my ($newversion, $newfile) = $self->_do('search');
+ unless ($newversion and $newfile) {
+ return $self->status(1);
+ }
+ $self->status and return $self->status;
+ uscan_verbose "Looking at \$base = $self->{parse_result}->{base} with\n"
+ . " \$filepattern = $self->{parse_result}->{filepattern} found\n"
+ . " \$newfile = $newfile\n"
+ . " \$newversion = $newversion which is newer than\n"
+ . " \$lastversion = $self->{parse_result}->{lastversion}";
+ $self->search_result({
+ newversion => $newversion,
+ newfile => $newfile,
+ });
+
+ # 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
+ # use the new.
+
+ if ($self->style eq 'old') {
+
+ # Old-style heuristics
+ if ($newversion =~ /^\D*(\d+\.(?:\d+\.)*\d+)\D*$/) {
+ $self->search_result->{newversion} = $1;
+ } else {
+ uscan_warn <<"EOF";
+$progname warning: In $self->{watchfile}, couldn\'t determine a
+ pure numeric version number from the file name for watch line
+ $self->{line}
+ and file name $newfile
+ Please use a new style watch file instead!
+EOF
+ $self->status(1);
+ }
+ }
+ return $self->status;
+}
+
+# III - get_upstream_url
+
+=head3 get_upstream_url()
+
+Transform newfile/newversion into upstream url using either:
+
+=over
+
+=item L<Devscripts::Uscan::http>::http_upstream_url()
+=item L<Devscripts::Uscan::ftp>::ftp_upstream_url()
+=item L<Devscripts::Uscan::git>::git_upstream_url()
+
+=back
+
+Result is stored in B<$self-E<gt>upstream_url> accessor.
+
+=cut
+
+sub get_upstream_url {
+ my ($self) = @_;
+ uscan_debug "line: get_upstream_url()";
+ if ($self->parse_result->{site} =~ m%^https?://%
+ and not $self->mode eq 'git') {
+ $self->mode('http');
+ } elsif (not $self->mode) {
+ $self->mode('ftp');
+ }
+ $self->upstream_url($self->_do('upstream_url'));
+ $self->status and return $self->status;
+ uscan_verbose "Upstream URL(+tag) to download is identified as"
+ . " $self->{upstream_url}";
+ return $self->status;
+}
+
+# IV - get_newfile_base
+
+=head3 get_newfile_base()
+
+Calculates the filename (filenamemangled) for downloaded file using either:
+
+=over
+
+=item L<Devscripts::Uscan::http>::http_newfile_base()
+=item L<Devscripts::Uscan::ftp>::ftp_newfile_base()
+=item L<Devscripts::Uscan::git>::git_newfile_base()
+
+=back
+
+Result is stored in B<$self-E<gt>newfile_base> accessor.
+
+=cut
+
+sub get_newfile_base {
+ my ($self) = @_;
+ uscan_debug "line: get_newfile_base()";
+ $self->newfile_base($self->_do('newfile_base'));
+ return $self->status if ($self->status);
+ uscan_verbose
+ "Filename (filenamemangled) for downloaded file: $self->{newfile_base}";
+ return $self->status;
+}
+
+# V - cmp_versions
+
+=head3 cmp_versions()
+
+Compare available and local versions.
+
+=cut
+
+sub cmp_versions {
+ my ($self) = @_;
+ uscan_debug "line: cmp_versions()";
+ my $mangled_lastversion = $self->parse_result->{mangled_lastversion};
+ unless (defined $self->shared->{common_newversion}) {
+ $self->shared->{common_newversion}
+ = $self->search_result->{newversion};
+ }
+
+ $dehs_tags->{'debian-uversion'} //= $self->parse_result->{lastversion};
+ $dehs_tags->{'debian-mangled-uversion'} //= $mangled_lastversion;
+ $dehs_tags->{'upstream-version'} //= $self->search_result->{newversion};
+ $dehs_tags->{'upstream-url'} //= $self->upstream_url;
+
+ my $mangled_ver
+ = Dpkg::Version->new("1:${mangled_lastversion}-0", check => 0);
+ my $upstream_ver
+ = Dpkg::Version->new("1:$self->{search_result}->{newversion}-0",
+ check => 0);
+ my $compver;
+ if ($mangled_ver == $upstream_ver) {
+ $compver = 'same';
+ } elsif ($mangled_ver > $upstream_ver) {
+ $compver = 'older';
+ } else {
+ $compver = 'newer';
+ }
+
+ # Version dependent $download adjustment
+ if (defined $self->shared->{download_version}) {
+
+ # Pretend to find a newer upstream version to exit without error
+ uscan_msg "Newest version of $self->{pkg} on remote site is "
+ . "$self->{search_result}->{newversion}, "
+ . "specified download version is $self->{shared}->{download_version}";
+ $found++ unless ($self->versionmode =~ /(?:same|ignore)/);
+ } elsif ($self->versionmode eq 'newer') {
+ if ($compver eq 'newer') {
+ uscan_msg "Newest version of $self->{pkg} on remote site is "
+ . "$self->{search_result}->{newversion}, "
+ . "local version is $self->{parse_result}->{lastversion}\n"
+ . (
+ $mangled_lastversion eq $self->parse_result->{lastversion}
+ ? ""
+ : " (mangled local version is $mangled_lastversion)\n"
+ );
+
+ # There's a newer upstream version available, which may already
+ # be on our system or may not be
+ uscan_msg " => Newer package available from\n"
+ . " $self->{upstream_url}";
+ $dehs_tags->{'status'} //= "newer package available";
+ $main::found++;
+ } elsif ($compver eq 'same') {
+ uscan_verbose "Newest version of $self->{pkg} on remote site is "
+ . $self->search_result->{newversion}
+ . ", local version is $self->{parse_result}->{lastversion}\n"
+ . (
+ $mangled_lastversion eq $self->parse_result->{lastversion}
+ ? ""
+ : " (mangled local version is $mangled_lastversion)\n"
+ );
+ uscan_verbose " => Package is up to date for from\n"
+ . " $self->{upstream_url}";
+ $dehs_tags->{'status'} //= "up to date";
+ if ($self->shared->{download} > 1) {
+
+ # 2=force-download or 3=overwrite-download
+ uscan_verbose " => Forcing download as requested";
+ $main::found++;
+ } else {
+ # 0=no-download or 1=download
+ $self->shared->{download} = 0;
+ }
+ } else { # $compver eq 'old'
+ uscan_verbose "Newest version of $self->{pkg} on remote site is "
+ . $self->search_result->{newversion}
+ . ", local version is $self->{parse_result}->{lastversion}\n"
+ . (
+ $mangled_lastversion eq $self->parse_result->{lastversion}
+ ? ""
+ : " (mangled local version is $mangled_lastversion)\n"
+ );
+ uscan_verbose " => Only older package available from\n"
+ . " $self->{upstream_url}";
+ $dehs_tags->{'status'} //= "only older package available";
+ if ($self->shared->{download} > 1) {
+ uscan_verbose " => Forcing download as requested";
+ $main::found++;
+ } else {
+ $self->shared->{download} = 0;
+ }
+ }
+ } elsif ($self->versionmode eq 'ignore') {
+ uscan_msg "Newest version of $self->{pkg} on remote site is "
+ . $self->search_result->{newversion}
+ . ", ignore local version";
+ $dehs_tags->{'status'} //= "package available";
+ } else { # same/previous -- secondary-tarball or signature-file
+ uscan_die "strange ... <version> stanza = same/previous "
+ . "should have defined \$download_version";
+ }
+ return 0;
+}
+
+# VI - download_file_and_sig
+
+=head3 download_file_and_sig()
+
+Download file and, if available and needed, signature files.
+
+=cut
+
+sub download_file_and_sig {
+ my ($self) = @_;
+ uscan_debug "line: download_file_and_sig()";
+ my $skip_git_vrfy;
+
+ # If we're not downloading or performing signature verification, we can
+ # stop here
+ if (!$self->shared->{download} || $self->shared->{signature} == -1) {
+ return 0;
+ }
+
+ # 6.1 download tarball
+ my $download_available = 0;
+ $self->signature_available(0);
+ my $sigfile;
+ my $sigfile_base = $self->newfile_base;
+ if ($self->pgpmode ne 'previous') {
+
+ # try download package
+ if ($self->shared->{download} == 3
+ and -e "$self->{config}->{destdir}/$self->{newfile_base}") {
+ uscan_verbose
+"Downloading and overwriting existing file: $self->{newfile_base}";
+ $download_available = $self->downloader->download(
+ $self->upstream_url,
+ "$self->{config}->{destdir}/$self->{newfile_base}",
+ $self,
+ $self->parse_result->{base},
+ $self->pkg_dir,
+ $self->pkg,
+ $self->mode
+ );
+ if ($download_available) {
+ dehs_verbose
+ "Successfully downloaded package: $self->{newfile_base}\n";
+ } else {
+ dehs_verbose
+"Failed to download upstream package: $self->{newfile_base}\n";
+ }
+ } elsif (-e "$self->{config}->{destdir}/$self->{newfile_base}") {
+ $download_available = 1;
+ dehs_verbose
+ "Not downloading, using existing file: $self->{newfile_base}\n";
+ $skip_git_vrfy = 1;
+ } elsif ($self->shared->{download} > 0) {
+ uscan_verbose
+ "Downloading upstream package: $self->{newfile_base}";
+ $download_available = $self->downloader->download(
+ $self->upstream_url,
+ "$self->{config}->{destdir}/$self->{newfile_base}",
+ $self,
+ $self->parse_result->{base},
+ $self->pkg_dir,
+ $self->pkg,
+ $self->mode,
+ );
+ if ($download_available) {
+ dehs_verbose
+ "Successfully downloaded package: $self->{newfile_base}\n";
+ } else {
+ dehs_verbose
+"Failed to download upstream package: $self->{newfile_base}\n";
+ }
+ } else { # $download = 0,
+ $download_available = 0;
+ dehs_verbose
+ "Not downloading upstream package: $self->{newfile_base}\n";
+ }
+ }
+ if ($self->pgpmode eq 'self') {
+ $sigfile_base =~ s/^(.*?)\.[^\.]+$/$1/; # drop .gpg, .asc, ...
+ if ($self->shared->{signature} == -1) {
+ uscan_warn("SKIP Checking OpenPGP signature (by request).\n");
+ $download_available
+ = -1; # can't proceed with self-signature archive
+ $self->signature_available(0);
+ } elsif (!$self->keyring) {
+ uscan_die("FAIL Checking OpenPGP signature (no keyring).\n");
+ } elsif ($download_available == 0) {
+ uscan_warn
+"FAIL Checking OpenPGP signature (no signed upstream tarball downloaded).";
+ return $self->status(1);
+ } else {
+ $self->keyring->verify(
+ "$self->{config}->{destdir}/$sigfile_base",
+ "$self->{config}->{destdir}/$self->{newfile_base}"
+ );
+
+# XXX FIXME XXX extract signature as detached signature to $self->{config}->{destdir}/$sigfile
+ $sigfile = $self->{newfile_base}; # XXX FIXME XXX place holder
+ $self->{newfile_base} = $sigfile_base;
+ $self->signature_available(3);
+ }
+ }
+ if ($self->pgpmode ne 'previous') {
+
+ # Decompress archive if requested and applicable
+ if ($download_available == 1 and $self->{'decompress'}) {
+ my $suffix_gz = $sigfile_base;
+ $suffix_gz =~ s/.*?(\.gz|\.xz|\.bz2|\.lzma)?$/$1/;
+ if ($suffix_gz eq '.gz') {
+ if (-x '/bin/gunzip') {
+ uscan_exec('/bin/gunzip', "--keep",
+ "$self->{config}->{destdir}/$sigfile_base");
+ $sigfile_base =~ s/(.*?)\.gz/$1/;
+ } else {
+ uscan_warn("Please install gzip.\n");
+ return $self->status(1);
+ }
+ } elsif ($suffix_gz eq '.xz') {
+ if (-x '/usr/bin/unxz') {
+ uscan_exec('/usr/bin/unxz', "--keep",
+ "$self->{config}->{destdir}/$sigfile_base");
+ $sigfile_base =~ s/(.*?)\.xz/$1/;
+ } else {
+ uscan_warn("Please install xz-utils.\n");
+ return $self->status(1);
+ }
+ } elsif ($suffix_gz eq '.bz2') {
+ if (-x '/bin/bunzip2') {
+ uscan_exec('/bin/bunzip2', "--keep",
+ "$self->{config}->{destdir}/$sigfile_base");
+ $sigfile_base =~ s/(.*?)\.bz2/$1/;
+ } else {
+ uscan_warn("Please install bzip2.\n");
+ return $self->status(1);
+ }
+ } elsif ($suffix_gz eq '.lzma') {
+ if (-x '/usr/bin/unlzma') {
+ uscan_exec('/usr/bin/unlzma', "--keep",
+ "$self->{config}->{destdir}/$sigfile_base");
+ $sigfile_base =~ s/(.*?)\.lzma/$1/;
+ } else {
+ uscan_warn "Please install xz-utils or lzma.";
+ return $self->status(1);
+ }
+ } else {
+ uscan_die "Unknown type file to decompress: $sigfile_base";
+ }
+ }
+ }
+
+ # 6.2 download signature
+ my $pgpsig_url;
+ my $suffix_sig;
+ if (($self->pgpmode eq 'default' or $self->pgpmode eq 'auto')
+ and $self->shared->{signature} == 1) {
+ uscan_verbose
+"Start checking for common possible upstream OpenPGP signature files";
+ foreach $suffix_sig (qw(asc gpg pgp sig sign)) {
+ my $sigrequest = HTTP::Request->new(
+ 'HEAD' => "$self->{upstream_url}.$suffix_sig");
+ my $sigresponse
+ = $self->downloader->user_agent->request($sigrequest);
+ if ($sigresponse->is_success()) {
+ if ($self->pgpmode eq 'default') {
+ uscan_warn "Possible OpenPGP signature found at:\n"
+ . " $self->{upstream_url}.$suffix_sig\n"
+ . " * Add opts=pgpsigurlmangle=s/\$/.$suffix_sig/ or "
+ . "opts=pgpmode=auto to debian/watch\n"
+ . " * Add debian/upstream/signing-key.asc.\n"
+ . " See uscan(1) for more details";
+ $self->pgpmode('none');
+ } else { # auto
+ $self->pgpmode('mangle');
+ $self->pgpsigurlmangle(['s/$/.' . $suffix_sig . '/',]);
+ }
+ last;
+ }
+ }
+ uscan_verbose
+ "End checking for common possible upstream OpenPGP signature files";
+ $self->signature_available(0);
+ }
+ if ($self->pgpmode eq 'mangle') {
+ $pgpsig_url = $self->upstream_url;
+ if (
+ mangle(
+ $self->watchfile, \$self->line,
+ 'pgpsigurlmangle:', \@{ $self->pgpsigurlmangle },
+ \$pgpsig_url
+ )
+ ) {
+ return $self->status(1);
+ }
+ if (!$suffix_sig) {
+ $suffix_sig = $pgpsig_url;
+ $suffix_sig =~ s/^.*\.//;
+ if ($suffix_sig and $suffix_sig !~ m/^[a-zA-Z]+$/)
+ { # strange suffix
+ $suffix_sig = "pgp";
+ }
+ uscan_debug "Add $suffix_sig suffix based on $pgpsig_url.";
+ }
+ $sigfile = "$sigfile_base.$suffix_sig";
+ if ($self->shared->{signature} == 1) {
+ uscan_verbose "Downloading OpenPGP signature from\n"
+ . " $pgpsig_url (pgpsigurlmangled)\n as $sigfile";
+ $self->signature_available(
+ $self->downloader->download(
+ $pgpsig_url, "$self->{config}->{destdir}/$sigfile",
+ $self, $self->parse_result->{base},
+ $self->pkg_dir, $self->pkg,
+ $self->mode
+ ));
+ } else { # -1, 0
+ uscan_verbose "Not downloading OpenPGP signature from\n"
+ . " $pgpsig_url (pgpsigurlmangled)\n as $sigfile";
+ $self->signature_available(
+ (-e "$self->{config}->{destdir}/$sigfile") ? 1 : 0);
+ }
+ } elsif ($self->pgpmode eq 'previous') {
+ $pgpsig_url = $self->upstream_url;
+ $sigfile = $self->newfile_base;
+ if ($self->shared->{signature} == 1) {
+ uscan_verbose "Downloading OpenPGP signature from\n"
+ . " $pgpsig_url (pgpmode=previous)\n as $sigfile";
+ $self->signature_available(
+ $self->downloader->download(
+ $pgpsig_url, "$self->{config}->{destdir}/$sigfile",
+ $self, $self->parse_result->{base},
+ $self->pkg_dir, $self->pkg,
+ $self->mode
+ ));
+ } else { # -1, 0
+ uscan_verbose "Not downloading OpenPGP signature from\n"
+ . " $pgpsig_url (pgpmode=previous)\n as $sigfile";
+ $self->signature_available(
+ (-e "$self->{config}->{destdir}/$sigfile") ? 1 : 0);
+ }
+ $download_available = $self->shared->{previous_download_available};
+ $self->{newfile_base} = $self->shared->{previous_newfile_base};
+ $sigfile_base = $self->shared->{previous_sigfile_base};
+ uscan_verbose
+ "Use $self->{newfile_base} as upstream package (pgpmode=previous)";
+ }
+ $self->sigfile("$self->{config}->{destdir}/$sigfile") if ($sigfile);
+
+ # 6.3 verify signature
+ #
+ # 6.3.1 pgpmode
+ if ($self->pgpmode eq 'mangle' or $self->pgpmode eq 'previous') {
+ if ($self->shared->{signature} == -1) {
+ uscan_verbose("SKIP Checking OpenPGP signature (by request).\n");
+ } elsif (!$self->keyring) {
+ uscan_die("FAIL Checking OpenPGP signature (no keyring).\n");
+ } elsif ($download_available == 0) {
+ uscan_warn
+"FAIL Checking OpenPGP signature (no upstream tarball downloaded).";
+ return $self->status(1);
+ } elsif ($self->signature_available == 0) {
+ uscan_die(
+"FAIL Checking OpenPGP signature (no signature file downloaded).\n"
+ );
+ } else {
+ if ($self->shared->{signature} == 0) {
+ uscan_verbose "Use the existing file: $sigfile";
+ }
+ $self->keyring->verifyv(
+ "$self->{config}->{destdir}/$sigfile",
+ "$self->{config}->{destdir}/$sigfile_base"
+ );
+ }
+ $self->shared->{previous_newfile_base} = undef;
+ $self->shared->{previous_sigfile_base} = undef;
+ $self->shared->{previous_newversion} = undef;
+ $self->shared->{previous_download_available} = undef;
+ } elsif ($self->pgpmode eq 'none' or $self->pgpmode eq 'default') {
+ uscan_verbose "Missing OpenPGP signature.";
+ $self->shared->{previous_newfile_base} = undef;
+ $self->shared->{previous_sigfile_base} = undef;
+ $self->shared->{previous_newversion} = undef;
+ $self->shared->{previous_download_available} = undef;
+ } elsif ($self->pgpmode eq 'next') {
+ uscan_verbose
+ "Defer checking OpenPGP signature to the next watch line";
+ $self->shared->{previous_newfile_base} = $self->newfile_base;
+ $self->shared->{previous_sigfile_base} = $sigfile_base;
+ $self->shared->{previous_newversion}
+ = $self->search_result->{newversion};
+ $self->shared->{previous_download_available} = $download_available;
+ uscan_verbose "previous_newfile_base = $self->{newfile_base}";
+ uscan_verbose "previous_sigfile_base = $sigfile_base";
+ uscan_verbose
+ "previous_newversion = $self->{search_result}->{newversion}";
+ uscan_verbose "previous_download_available = $download_available";
+ } elsif ($self->pgpmode eq 'self') {
+ $self->shared->{previous_newfile_base} = undef;
+ $self->shared->{previous_sigfile_base} = undef;
+ $self->shared->{previous_newversion} = undef;
+ $self->shared->{previous_download_available} = undef;
+ } elsif ($self->pgpmode eq 'auto') {
+ uscan_verbose "Don't check OpenPGP signature";
+ } elsif ($self->pgpmode eq 'gittag') {
+ if ($skip_git_vrfy) {
+ uscan_warn "File already downloaded, skipping gpg verification";
+ } elsif (!$self->keyring) {
+ uscan_warn "No keyring file, skipping gpg verification";
+ return $self->status(1);
+ } else {
+ my ($gitrepo, $gitref) = split /[[:space:]]+/, $self->upstream_url;
+ $self->keyring->verify_git($self->pkg . "-temporary.$$.git",
+ $gitref, $self->downloader->git_upstream);
+ }
+ } else {
+ uscan_warn "strange ... unknown pgpmode = $self->{pgpmode}";
+ return $self->status(1);
+ }
+ my $mangled_newversion = $self->search_result->{newversion};
+ if (
+ mangle(
+ $self->watchfile, \$self->line,
+ 'oversionmangle:', \@{ $self->oversionmangle },
+ \$mangled_newversion
+ )
+ ) {
+ return $self->status(1);
+ }
+
+ if (!$self->shared->{common_mangled_newversion}) {
+
+ # $mangled_newversion = version used for the new orig.tar.gz (a.k.a oversion)
+ uscan_verbose
+"New orig.tar.* tarball version (oversionmangled): $mangled_newversion";
+
+ # MUT package always use the same $common_mangled_newversion
+ # MUT disables repacksuffix so it is safe to have this before mk-origtargz
+ $self->shared->{common_mangled_newversion} = $mangled_newversion;
+ }
+ if ($self->pgpmode eq 'next') {
+ uscan_verbose "Read the next watch line (pgpmode=next)";
+ return 0;
+ }
+ if ($self->safe) {
+ uscan_verbose "SKIP generation of orig.tar.* "
+ . "and running of script/uupdate (--safe)";
+ return 0;
+ }
+ if ($download_available == 0) {
+ uscan_warn "No upstream tarball downloaded."
+ . " No further processing with mk_origtargz ...";
+ return $self->status(1);
+ }
+ if ($download_available == -1) {
+ uscan_warn "No upstream tarball unpacked from self signature file."
+ . " No further processing with mk_origtargz ...";
+ return $self->status(1);
+ }
+ if ($self->signature_available == 1 and $self->decompress) {
+ $self->signature_available(2);
+ }
+ $self->search_result->{sigfile} = $sigfile;
+ $self->must_download(1);
+ return $self->status;
+}
+
+# VII - mkorigtargz
+
+=head3 mkorigtargz()
+
+Call L<mk_origtargz> to build source tarball.
+
+=cut
+
+sub mkorigtargz {
+ my ($self) = @_;
+ uscan_debug "line: mkorigtargz()";
+ return 0 unless ($self->must_download);
+ my $mk_origtargz_out;
+ my $path = "$self->{config}->{destdir}/$self->{newfile_base}";
+ my $target = $self->newfile_base;
+ unless ($self->symlink eq "no") {
+ require Devscripts::MkOrigtargz;
+ @ARGV = ();
+ push @ARGV, "--package", $self->pkg;
+ push @ARGV, "--version", $self->shared->{common_mangled_newversion};
+ push @ARGV, '--repack-suffix', $self->repacksuffix
+ if $self->repacksuffix;
+ push @ARGV, "--rename" if $self->symlink eq "rename";
+ push @ARGV, "--copy" if $self->symlink eq "copy";
+ push @ARGV, "--signature", $self->signature_available
+ if ($self->signature_available != 0);
+ push @ARGV, "--signature-file",
+ "$self->{config}->{destdir}/$self->{search_result}->{sigfile}"
+ if ($self->signature_available != 0);
+ push @ARGV, "--repack" if $self->repack;
+ push @ARGV, "--force-repack" if $self->force_repack;
+ push @ARGV, "--component", $self->component
+ if $self->component;
+ push @ARGV, "--compression", $self->compression;
+ push @ARGV, "--directory", $self->config->destdir;
+ push @ARGV, "--copyright-file", "debian/copyright"
+ if ($self->config->exclusion && -e "debian/copyright");
+ push @ARGV, "--copyright-file", $self->config->copyright_file
+ if ($self->config->exclusion && $self->config->copyright_file);
+ push @ARGV, "--unzipopt", $self->unzipopt
+ if $self->unzipopt;
+ push @ARGV, $path;
+ my $tmp = $Devscripts::Output::die_on_error;
+
+ uscan_verbose "Launch mk-origtargz with options:\n "
+ . join(" ", @ARGV);
+ my $mk = Devscripts::MkOrigtargz->new;
+ $mk->do;
+ uscan_die "mk-origtargz failed" if ($mk->status);
+
+ $path = $mk->destfile_nice;
+ $target = basename($path);
+ $self->shared->{common_mangled_newversion} = $1
+ if $target =~ m/[^_]+_(.+)\.orig(?:-.+)?\.tar\.(?:gz|bz2|lzma|xz)$/;
+ uscan_verbose "New orig.tar.* tarball version (after mk-origtargz): "
+ . "$self->{shared}->{common_mangled_newversion}";
+ }
+ push @{ $self->shared->{origtars} }, $target;
+
+ if ($self->config->log) {
+
+ # Check pkg-ver.tar.gz and pkg_ver.orig.tar.gz
+ if (!$self->shared->{uscanlog}) {
+ $self->shared->{uscanlog}
+ = "$self->{config}->{destdir}/$self->{pkg}_$self->{shared}->{common_mangled_newversion}.uscan.log";
+ if (-e "$self->{shared}->{uscanlog}.old") {
+ unlink "$self->{shared}->{uscanlog}.old"
+ or uscan_die "Can\'t remove old backup log "
+ . "$self->{shared}->{uscanlog}.old: $!";
+ uscan_warn "Old backup uscan log found. "
+ . "Remove: $self->{shared}->{uscanlog}.old";
+ }
+ if (-e $self->shared->uscanlog) {
+ move($self->shared->uscanlog,
+ "$self->{shared}->{uscanlog}.old");
+ uscan_warn "Old uscan log found. "
+ . "Moved to: $self->{shared}->{uscanlog}.old";
+ }
+ open(USCANLOG, ">> $self->{shared}->{uscanlog}")
+ or uscan_die "$progname: could not open "
+ . "$self->{shared}->{uscanlog} for append: $!";
+ print USCANLOG "# uscan log\n";
+ } else {
+ open(USCANLOG, ">> $self->{shared}->{uscanlog}")
+ or uscan_die "$progname: could not open "
+ . "$self->{shared}->{uscanlog} for append: $!";
+ }
+ if ($self->symlink ne "rename") {
+ my $umd5sum = Digest::MD5->new;
+ my $omd5sum = Digest::MD5->new;
+ open(my $ufh, '<',
+ "$self->{config}->{destdir}/$self->{newfile_base}")
+ or uscan_die "Can't open '"
+ . "$self->{config}->{destdir}/$self->{newfile_base}" . "': $!";
+ open(my $ofh, '<', "$self->{config}->{destdir}/${target}")
+ or uscan_die
+ "Can't open '$self->{config}->{destdir}/${target}': $!";
+ $umd5sum->addfile($ufh);
+ $omd5sum->addfile($ofh);
+ close($ufh);
+ close($ofh);
+ my $umd5hex = $umd5sum->hexdigest;
+ my $omd5hex = $omd5sum->hexdigest;
+
+ if ($umd5hex eq $omd5hex) {
+ print USCANLOG
+ "# == $self->{newfile_base}\t-->\t${target}\t(same)\n";
+ } else {
+ print USCANLOG
+ "# !! $self->{newfile_base}\t-->\t${target}\t(changed)\n";
+ }
+ print USCANLOG "$umd5hex $self->{newfile_base}\n";
+ print USCANLOG "$omd5hex ${target}\n";
+ }
+ close USCANLOG
+ or uscan_die
+ "$progname: could not close $self->{shared}->{uscanlog} $!";
+ }
+
+ dehs_verbose "$mk_origtargz_out\n" if $mk_origtargz_out;
+ $dehs_tags->{target} = $target;
+ $dehs_tags->{'target-path'} = $path;
+
+#######################################################################
+ # code 3.10: call uupdate
+#######################################################################
+ # Do whatever the user wishes to do
+ if ($self->parse_result->{action}) {
+ my @cmd = shellwords($self->parse_result->{action});
+
+ # script invocation changed in $watch_version=4
+ if ($self->watch_version > 3) {
+ if ($cmd[0] eq "uupdate") {
+ push @cmd, "-f";
+ if ($verbose) {
+ push @cmd, "--verbose";
+ }
+ if ($self->badversion) {
+ push @cmd, "-b";
+ }
+ }
+ push @cmd, "--upstream-version",
+ $self->shared->{common_mangled_newversion};
+ if (abs_path($self->{config}->{destdir}) ne abs_path("..")) {
+ foreach my $origtar (@{ $self->shared->{origtars} }) {
+ copy(catfile($self->{config}->{destdir}, $origtar),
+ catfile("..", $origtar));
+ }
+ }
+ } elsif ($self->watch_version > 1) {
+
+ # Any symlink requests are already handled by uscan
+ if ($cmd[0] eq "uupdate") {
+ push @cmd, "--no-symlink";
+ if ($verbose) {
+ push @cmd, "--verbose";
+ }
+ if ($self->badversion) {
+ push @cmd, "-b";
+ }
+ }
+ push @cmd, "--upstream-version",
+ $self->shared->{common_mangled_newversion}, $path;
+ } else {
+ push @cmd, $path, $self->shared->{common_mangled_newversion};
+ }
+ my $actioncmd = join(" ", @cmd);
+ my $actioncmdmsg;
+ spawn(exec => \@cmd, wait_child => 1, to_string => \$actioncmdmsg);
+ local $, = ' ';
+ dehs_verbose "Executing user specified script:\n @cmd\n"
+ . $actioncmdmsg;
+ }
+ $self->destfile($path);
+
+ return 0;
+}
+
+# VIII - clean
+
+=head3 clean()
+
+Clean temporary files using either:
+
+=over
+
+=item L<Devscripts::Uscan::http>::http_clean()
+=item L<Devscripts::Uscan::ftp>::ftp_clean()
+=item L<Devscripts::Uscan::git>::git_clean()
+
+=back
+
+=cut
+
+sub clean {
+ my ($self) = @_;
+ $self->_do('clean');
+}
+
+# Internal sub to call sub modules (git, http,...)
+sub _do {
+ my ($self, $sub) = @_;
+ my $mode = $self->mode;
+ $mode =~ s/git-dumb/git/;
+ $sub = $mode . "_$sub";
+ with("Devscripts::Uscan::$mode") unless ($self->can($sub));
+ if ($@) {
+ uscan_warn "Unknown '$mode' mode set in $self->{watchfile} ($@)";
+ $self->status(1);
+ }
+ return $self->$sub;
+}
+
+1;
+
+=head1 SEE ALSO
+
+L<uscan>, L<Devscripts::Uscan::WatchFile>, L<Devscripts::Uscan::Config>
+
+=head1 AUTHOR
+
+B<uscan> was originally written by Christoph Lameter
+E<lt>clameter@debian.orgE<gt> (I believe), modified by Julian Gilbey
+E<lt>jdg@debian.orgE<gt>. HTTP support was added by Piotr Roszatycki
+E<lt>dexter@debian.orgE<gt>. B<uscan> was rewritten in Perl by Julian Gilbey.
+Xavier Guimard E<lt>yadd@debian.orgE<gt> rewrote uscan in object
+oriented Perl.
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2002-2006 by Julian Gilbey <jdg@debian.org>,
+2018 by Xavier Guimard <yadd@debian.org>
+
+This program is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or
+(at your option) any later version.
+
+=cut
diff --git a/lib/Devscripts/Uscan/_xtp.pm b/lib/Devscripts/Uscan/_xtp.pm
new file mode 100644
index 0000000..4e6d74b
--- /dev/null
+++ b/lib/Devscripts/Uscan/_xtp.pm
@@ -0,0 +1,83 @@
+# Common sub shared between http and ftp
+package Devscripts::Uscan::_xtp;
+
+use strict;
+use File::Basename;
+use Exporter 'import';
+use Devscripts::Uscan::Output;
+use Devscripts::Uscan::Utils;
+
+our @EXPORT = ('partial_version');
+
+sub _xtp_newfile_base {
+ my ($self) = @_;
+ my $newfile_base;
+ if (@{ $self->filenamemangle }) {
+
+ # HTTP or FTP site (with filenamemangle)
+ if ($self->versionless) {
+ $newfile_base = $self->upstream_url;
+ } else {
+ $newfile_base = $self->search_result->{newfile};
+ }
+ uscan_verbose "Matching target for filenamemangle: $newfile_base";
+ if (
+ mangle(
+ $self->watchfile, \$self->line,
+ 'filenamemangle:', \@{ $self->filenamemangle },
+ \$newfile_base
+ )
+ ) {
+ $self->status(1);
+ return undef;
+ }
+ unless ($self->search_result->{newversion}) {
+
+ # uversionmanglesd version is '', make best effort to set it
+ $newfile_base
+ =~ m/^.+?[-_]?(\d[\-+\.:\~\da-zA-Z]*)(?:\.tar\.(gz|bz2|xz)|\.zip)$/i;
+ $self->search_result->{newversion} = $1;
+ unless ($self->search_result->{newversion}) {
+ uscan_warn
+"Fix filenamemangle to produce a filename with the correct version";
+ $self->status(1);
+ return undef;
+ }
+ uscan_verbose
+"Newest upstream tarball version from the filenamemangled filename: $self->{search_result}->{newversion}";
+ }
+ } else {
+ # HTTP or FTP site (without filenamemangle)
+ $newfile_base = basename($self->search_result->{newfile});
+ if ($self->mode eq 'http') {
+
+ # Remove HTTP header trash
+ $newfile_base =~ s/[\?#].*$//; # PiPy
+ # just in case this leaves us with nothing
+ if ($newfile_base eq '') {
+ uscan_warn
+"No good upstream filename found after removing tailing ?... and #....\n Use filenamemangle to fix this.";
+ $self->status(1);
+ return undef;
+ }
+ }
+ }
+ return $newfile_base;
+}
+
+sub partial_version {
+ my ($download_version) = @_;
+ my ($d1, $d2, $d3);
+ if (defined $download_version) {
+ uscan_verbose "download version requested: $download_version";
+ if ($download_version
+ =~ m/^([-~\+\w]+)(\.[-~\+\w]+)?(\.[-~\+\w]+)?(\.[-~\+\w]+)?$/) {
+ $d1 = "$1" if defined $1;
+ $d2 = "$1$2" if defined $2;
+ $d3 = "$1$2$3" if defined $3;
+ }
+ }
+ return ($d1, $d2, $d3);
+}
+
+1;
diff --git a/lib/Devscripts/Uscan/ftp.pm b/lib/Devscripts/Uscan/ftp.pm
new file mode 100644
index 0000000..e903f50
--- /dev/null
+++ b/lib/Devscripts/Uscan/ftp.pm
@@ -0,0 +1,278 @@
+package Devscripts::Uscan::ftp;
+
+use strict;
+use Cwd qw/abs_path/;
+use Devscripts::Uscan::Output;
+use Devscripts::Uscan::Utils;
+use Devscripts::Uscan::_xtp;
+use Moo::Role;
+
+#######################################################################
+# search $newfile $newversion (ftp mode)
+#######################################################################
+sub ftp_search {
+ my ($self) = @_;
+
+ # FTP site
+ uscan_verbose "Requesting URL:\n $self->{parse_result}->{base}";
+ my $request = HTTP::Request->new('GET', $self->parse_result->{base});
+ my $response = $self->downloader->user_agent->request($request);
+ if (!$response->is_success) {
+ uscan_warn
+"In watch file $self->{watchfile}, reading FTP directory\n $self->{parse_result}->{base} failed: "
+ . $response->status_line . "";
+ return undef;
+ }
+
+ my $content = $response->content;
+ uscan_debug
+ "received content:\n$content\n[End of received content] by FTP";
+
+ # FTP directory listings either look like:
+ # info info ... info filename [ -> linkname]
+ # or they're HTMLised (if they've been through an HTTP proxy)
+ # so we may have to look for <a href="filename"> type patterns
+ uscan_verbose "matching pattern $self->{parse_result}->{pattern}";
+ my (@files);
+
+ # We separate out HTMLised listings from standard listings, so
+ # that we can target our search correctly
+ if ($content =~ /<\s*a\s+[^>]*href/i) {
+ uscan_verbose "HTMLized FTP listing by the HTTP proxy";
+ while ($content
+ =~ m/(?:<\s*a\s+[^>]*href\s*=\s*\")((?-i)$self->{parse_result}->{pattern})\"/gi
+ ) {
+ my $file = fix_href($1);
+ my $mangled_version
+ = join(".", $file =~ m/^$self->{parse_result}->{pattern}$/);
+ if (
+ mangle(
+ $self->watchfile, \$self->line,
+ 'uversionmangle:', \@{ $self->uversionmangle },
+ \$mangled_version
+ )
+ ) {
+ return undef;
+ }
+ my $match = '';
+ if (defined $self->shared->{download_version}) {
+ if ($mangled_version eq $self->shared->{download_version}) {
+ $match = "matched with the download version";
+ }
+ }
+ my $priority = $mangled_version . '-' . get_priority($file);
+ push @files, [$priority, $mangled_version, $file, $match];
+ }
+ } else {
+ uscan_verbose "Standard FTP listing.";
+
+ # they all look like:
+ # info info ... info filename [ -> linkname]
+ for my $ln (split(/\n/, $content)) {
+ $ln =~ s/^d.*$//; # FTP listing of directory, '' skipped
+ $ln =~ s/\s+->\s+\S+$//; # FTP listing for link destination
+ $ln =~ s/^.*\s(\S+)$/$1/; # filename only
+ if ($ln and $ln =~ m/^($self->{parse_result}->{filepattern})$/) {
+ my $file = $1;
+ my $mangled_version = join(".",
+ $file =~ m/^$self->{parse_result}->{filepattern}$/);
+ if (
+ mangle(
+ $self->watchfile, \$self->line,
+ 'uversionmangle:', \@{ $self->uversionmangle },
+ \$mangled_version
+ )
+ ) {
+ return undef;
+ }
+ my $match = '';
+ if (defined $self->shared->{download_version}) {
+ if ($mangled_version eq $self->shared->{download_version})
+ {
+ $match = "matched with the download version";
+ }
+ }
+ my $priority = $mangled_version . '-' . get_priority($file);
+ push @files, [$priority, $mangled_version, $file, $match];
+ }
+ }
+ }
+ if (@files) {
+ @files = Devscripts::Versort::versort(@files);
+ my $msg
+ = "Found the following matching files on the web page (newest first):\n";
+ foreach my $file (@files) {
+ $msg .= " $$file[2] ($$file[1]) index=$$file[0] $$file[3]\n";
+ }
+ uscan_verbose $msg;
+ }
+ my ($newversion, $newfile);
+ if (defined $self->shared->{download_version}) {
+
+ # extract ones which has $match in the above loop defined
+ my @vfiles = grep { $$_[3] } @files;
+ if (@vfiles) {
+ (undef, $newversion, $newfile, undef) = @{ $vfiles[0] };
+ } else {
+ uscan_warn
+"In $self->{watchfile} no matching files for version $self->{shared}->{download_version}"
+ . " in watch line\n $self->{line}";
+ return undef;
+ }
+ } else {
+ if (@files) {
+ (undef, $newversion, $newfile, undef) = @{ $files[0] };
+ } else {
+ uscan_warn
+"In $self->{watchfile} no matching files for watch line\n $self->{line}";
+ return undef;
+ }
+ }
+ return ($newversion, $newfile);
+}
+
+sub ftp_upstream_url {
+ my ($self) = @_;
+ return $self->parse_result->{base} . $self->search_result->{newfile};
+}
+
+*ftp_newfile_base = \&Devscripts::Uscan::_xtp::_xtp_newfile_base;
+
+sub ftp_newdir {
+ my ($downloader, $site, $dir, $pattern, $dirversionmangle, $watchfile,
+ $lineptr, $download_version)
+ = @_;
+
+ my ($request, $response, $newdir);
+ my ($download_version_short1, $download_version_short2,
+ $download_version_short3)
+ = partial_version($download_version);
+ my $base = $site . $dir;
+ $request = HTTP::Request->new('GET', $base);
+ $response = $downloader->user_agent->request($request);
+ if (!$response->is_success) {
+ uscan_warn
+ "In watch file $watchfile, reading webpage\n $base failed: "
+ . $response->status_line;
+ return '';
+ }
+
+ my $content = $response->content;
+ uscan_debug
+ "received content:\n$content\n[End of received content] by FTP";
+
+ # FTP directory listings either look like:
+ # info info ... info filename [ -> linkname]
+ # or they're HTMLised (if they've been through an HTTP proxy)
+ # so we may have to look for <a href="filename"> type patterns
+ uscan_verbose "matching pattern $pattern";
+ my (@dirs);
+ my $match = '';
+
+ # We separate out HTMLised listings from standard listings, so
+ # that we can target our search correctly
+ if ($content =~ /<\s*a\s+[^>]*href/i) {
+ uscan_verbose "HTMLized FTP listing by the HTTP proxy";
+ while (
+ $content =~ m/(?:<\s*a\s+[^>]*href\s*=\s*\")((?-i)$pattern)\"/gi) {
+ my $dir = $1;
+ uscan_verbose "Matching target for dirversionmangle: $dir";
+ my $mangled_version = join(".", $dir =~ m/^$pattern$/);
+ if (
+ mangle(
+ $watchfile, $lineptr,
+ 'dirversionmangle:', \@{$dirversionmangle},
+ \$mangled_version
+ )
+ ) {
+ return 1;
+ }
+ $match = '';
+ if (defined $download_version
+ and $mangled_version eq $download_version) {
+ $match = "matched with the download version";
+ }
+ if (defined $download_version_short3
+ and $mangled_version eq $download_version_short3) {
+ $match = "matched with the download version (partial 3)";
+ }
+ if (defined $download_version_short2
+ and $mangled_version eq $download_version_short2) {
+ $match = "matched with the download version (partial 2)";
+ }
+ if (defined $download_version_short1
+ and $mangled_version eq $download_version_short1) {
+ $match = "matched with the download version (partial 1)";
+ }
+ push @dirs, [$mangled_version, $dir, $match];
+ }
+ } else {
+ # they all look like:
+ # info info ... info filename [ -> linkname]
+ uscan_verbose "Standard FTP listing.";
+ foreach my $ln (split(/\n/, $content)) {
+ $ln =~ s/^-.*$//; # FTP listing of file, '' skipped
+ $ln =~ s/\s+->\s+\S+$//; # FTP listing for link destination
+ $ln =~ s/^.*\s(\S+)$/$1/; # filename only
+ if ($ln =~ m/^($pattern)(\s+->\s+\S+)?$/) {
+ my $dir = $1;
+ uscan_verbose "Matching target for dirversionmangle: $dir";
+ my $mangled_version = join(".", $dir =~ m/^$pattern$/);
+ if (
+ mangle(
+ $watchfile, $lineptr,
+ 'dirversionmangle:', \@{$dirversionmangle},
+ \$mangled_version
+ )
+ ) {
+ return 1;
+ }
+ $match = '';
+ if (defined $download_version
+ and $mangled_version eq $download_version) {
+ $match = "matched with the download version";
+ }
+ if (defined $download_version_short3
+ and $mangled_version eq $download_version_short3) {
+ $match = "matched with the download version (partial 3)";
+ }
+ if (defined $download_version_short2
+ and $mangled_version eq $download_version_short2) {
+ $match = "matched with the download version (partial 2)";
+ }
+ if (defined $download_version_short1
+ and $mangled_version eq $download_version_short1) {
+ $match = "matched with the download version (partial 1)";
+ }
+ push @dirs, [$mangled_version, $dir, $match];
+ }
+ }
+ }
+
+ # extract ones which has $match in the above loop defined
+ my @vdirs = grep { $$_[2] } @dirs;
+ if (@vdirs) {
+ @vdirs = Devscripts::Versort::upstream_versort(@vdirs);
+ $newdir = $vdirs[0][1];
+ }
+ if (@dirs) {
+ @dirs = Devscripts::Versort::upstream_versort(@dirs);
+ my $msg
+ = "Found the following matching FTP directories (newest first):\n";
+ foreach my $dir (@dirs) {
+ $msg .= " $$dir[1] ($$dir[0]) $$dir[2]\n";
+ }
+ uscan_verbose $msg;
+ $newdir //= $dirs[0][1];
+ } else {
+ uscan_warn
+ "In $watchfile no matching dirs for pattern\n $base$pattern";
+ $newdir = '';
+ }
+ return $newdir;
+}
+
+# Nothing to clean here
+sub ftp_clean { 0 }
+
+1;
diff --git a/lib/Devscripts/Uscan/git.pm b/lib/Devscripts/Uscan/git.pm
new file mode 100644
index 0000000..926e5f6
--- /dev/null
+++ b/lib/Devscripts/Uscan/git.pm
@@ -0,0 +1,235 @@
+package Devscripts::Uscan::git;
+
+use strict;
+use Cwd qw/abs_path/;
+use Devscripts::Uscan::Output;
+use Devscripts::Uscan::Utils;
+use Dpkg::IPC;
+use File::Path 'remove_tree';
+use Moo::Role;
+
+######################################################
+# search $newfile $newversion (git mode/versionless)
+######################################################
+sub git_search {
+ my ($self) = @_;
+ my ($newfile, $newversion);
+ if ($self->versionless) {
+ $newfile = $self->parse_result->{filepattern}; # HEAD or heads/<branch>
+ if ($self->pretty eq 'describe') {
+ $self->gitmode('full');
+ }
+ if ( $self->gitmode eq 'shallow'
+ and $self->parse_result->{filepattern} eq 'HEAD') {
+ uscan_exec(
+ 'git',
+ 'clone',
+ '--bare',
+ '--depth=1',
+ $self->parse_result->{base},
+ "$self->{downloader}->{destdir}/" . $self->gitrepo_dir
+ );
+ $self->downloader->gitrepo_state(1);
+ } elsif ($self->gitmode eq 'shallow'
+ and $self->parse_result->{filepattern} ne 'HEAD')
+ { # heads/<branch>
+ $newfile =~ s&^heads/&&; # Set to <branch>
+ uscan_exec(
+ 'git',
+ 'clone',
+ '--bare',
+ '--depth=1',
+ '-b',
+ "$newfile",
+ $self->parse_result->{base},
+ "$self->{downloader}->{destdir}/" . $self->gitrepo_dir
+ );
+ $self->downloader->gitrepo_state(1);
+ } else {
+ uscan_exec(
+ 'git', 'clone', '--bare',
+ $self->parse_result->{base},
+ "$self->{downloader}->{destdir}/" . $self->gitrepo_dir
+ );
+ $self->downloader->gitrepo_state(2);
+ }
+ if ($self->pretty eq 'describe') {
+
+ # use unannotated tags to be on safe side
+ spawn(
+ exec => [
+ 'git',
+"--git-dir=$self->{downloader}->{destdir}/$self->{gitrepo_dir}",
+ 'describe',
+ '--tags'
+ ],
+ wait_child => 1,
+ to_string => \$newversion
+ );
+ $newversion =~ s/-/./g;
+ chomp($newversion);
+ if (
+ mangle(
+ $self->watchfile, \$self->line,
+ 'uversionmangle:', \@{ $self->uversionmangle },
+ \$newversion
+ )
+ ) {
+ return undef;
+ }
+ } else {
+ my $tmp = $ENV{TZ};
+ $ENV{TZ} = 'UTC';
+ spawn(
+ exec => [
+ 'git',
+"--git-dir=$self->{downloader}->{destdir}/$self->{gitrepo_dir}",
+ 'log',
+ '-1',
+ "--date=format-local:$self->{date}",
+ "--pretty=$self->{pretty}"
+ ],
+ wait_child => 1,
+ to_string => \$newversion
+ );
+ $ENV{TZ} = $tmp;
+ chomp($newversion);
+ }
+ }
+ ################################################
+ # search $newfile $newversion (git mode w/tag)
+ ################################################
+ elsif ($self->mode eq 'git') {
+ my @args = ('ls-remote', $self->parse_result->{base});
+ # Try to use local upstream branch if available
+ if (-d '.git') {
+ my $out;
+ eval {
+ spawn(
+ exec => ['git', 'remote', '--verbose', 'show'],
+ wait_child => 1,
+ to_string => \$out
+ );
+ };
+ # Check if git repo found in debian/watch exists in
+ # `git remote show` output
+ if ($out and $out =~ /^(\S+)\s+\Q$self->{parse_result}->{base}\E/m)
+ {
+ $self->downloader->git_upstream($1);
+ uscan_warn
+ "Using $self->{downloader}->{git_upstream} remote origin";
+ # Found, launch a "fetch" to be up to date
+ spawn(
+ exec => ['git', 'fetch', $self->downloader->git_upstream],
+ wait_child => 1
+ );
+ @args = ('show-ref');
+ }
+ }
+ {
+ local $, = ' ';
+ uscan_verbose "Execute: git @args $self->{parse_result}->{base}";
+ }
+ open(REFS, "-|", 'git', @args)
+ || uscan_die "$progname: you must have the git package installed";
+ my @refs;
+ my $ref;
+ my $version;
+ while (<REFS>) {
+ chomp;
+ uscan_debug "$_";
+ if (m&^\S+\s+([^\^\{\}]+)$&) {
+ $ref = $1; # ref w/o ^{}
+ foreach my $_pattern (@{ $self->patterns }) {
+ $version = join(".",
+ map { $_ if defined($_) } $ref =~ m&^$_pattern$&);
+ if (
+ mangle(
+ $self->watchfile, \$self->line,
+ 'uversionmangle:', \@{ $self->uversionmangle },
+ \$version
+ )
+ ) {
+ return undef;
+ }
+ push @refs, [$version, $ref];
+ }
+ }
+ }
+ if (@refs) {
+ @refs = Devscripts::Versort::upstream_versort(@refs);
+ my $msg = "Found the following matching refs:\n";
+ foreach my $ref (@refs) {
+ $msg .= " $$ref[1] ($$ref[0])\n";
+ }
+ uscan_verbose "$msg";
+ if ($self->shared->{download_version}) {
+
+# extract ones which has $version in the above loop matched with $download_version
+ my @vrefs
+ = grep { $$_[0] eq $self->shared->{download_version} } @refs;
+ if (@vrefs) {
+ ($newversion, $newfile) = @{ $vrefs[0] };
+ } else {
+ uscan_warn
+ "$progname warning: In $self->{watchfile} no matching"
+ . " refs for version "
+ . $self->shared->{download_version}
+ . " in watch line\n "
+ . $self->{line};
+ return undef;
+ }
+
+ } else {
+ ($newversion, $newfile) = @{ $refs[0] };
+ }
+ } else {
+ uscan_warn "$progname warning: In $self->{watchfile},\n"
+ . " no matching refs for watch line\n"
+ . " $self->{line}";
+ return undef;
+ }
+ }
+ return ($newversion, $newfile);
+}
+
+sub git_upstream_url {
+ my ($self) = @_;
+ my $upstream_url
+ = $self->parse_result->{base} . ' ' . $self->search_result->{newfile};
+ return $upstream_url;
+}
+
+sub git_newfile_base {
+ my ($self) = @_;
+ my $zsuffix = get_suffix($self->compression);
+ my $newfile_base
+ = "$self->{pkg}-$self->{search_result}->{newversion}.tar.$zsuffix";
+ return $newfile_base;
+}
+
+sub git_clean {
+ my ($self) = @_;
+
+ # If git cloned repo exists and not --debug ($verbose=2) -> remove it
+ if ( $self->downloader->gitrepo_state > 0
+ and $verbose < 2
+ and !$self->downloader->git_upstream) {
+ my $err;
+ uscan_verbose "Removing git repo ($self->{downloader}->{destdir}/"
+ . $self->gitrepo_dir . ")";
+ remove_tree "$self->{downloader}->{destdir}/" . $self->gitrepo_dir,
+ { error => \$err };
+ if (@$err) {
+ local $, = "\n\t";
+ uscan_warn "Errors during git repo clean:\n\t@$err";
+ }
+ $self->downloader->gitrepo_state(0);
+ } else {
+ uscan_debug "Keep git repo ($self->{downloader}->{destdir}/"
+ . $self->gitrepo_dir . ")";
+ }
+ return 0;
+}
+
+1;
diff --git a/lib/Devscripts/Uscan/http.pm b/lib/Devscripts/Uscan/http.pm
new file mode 100644
index 0000000..95fc08a
--- /dev/null
+++ b/lib/Devscripts/Uscan/http.pm
@@ -0,0 +1,434 @@
+package Devscripts::Uscan::http;
+
+use strict;
+use Cwd qw/abs_path/;
+use Devscripts::Uscan::Output;
+use Devscripts::Uscan::Utils;
+use Devscripts::Uscan::_xtp;
+use Moo::Role;
+
+*http_newfile_base = \&Devscripts::Uscan::_xtp::_xtp_newfile_base;
+
+##################################
+# search $newversion (http mode)
+##################################
+sub http_search {
+ my ($self) = @_;
+
+ # $content: web page to be scraped to find the URLs to be downloaded
+ if (defined($1) and $self->downloader->ssl) {
+ uscan_die
+"you must have the liblwp-protocol-https-perl package installed\nto use https URLs";
+ }
+ uscan_verbose "Requesting URL:\n $self->{parse_result}->{base}";
+ my $request = HTTP::Request->new('GET', $self->parse_result->{base});
+ my $response = $self->downloader->user_agent->request($request);
+ if (!$response->is_success) {
+ uscan_warn
+"In watchfile $self->{watchfile}, reading webpage\n $self->{parse_result}->{base} failed: "
+ . $response->status_line;
+ return undef;
+ }
+
+ my @redirections = @{ $self->downloader->user_agent->get_redirections };
+
+ uscan_verbose "redirections: @redirections" if @redirections;
+
+ foreach my $_redir (@redirections) {
+ my $base_dir = $_redir;
+
+ $base_dir =~ s%^\w+://[^/]+/%/%;
+ if ($_redir =~ m%^(\w+://[^/]+)%) {
+ my $base_site = $1;
+
+ push @{ $self->patterns },
+ "(?:(?:$base_site)?"
+ . quotemeta($base_dir)
+ . ")?$self->{parse_result}->{filepattern}";
+ push @{ $self->sites }, $base_site;
+ push @{ $self->basedirs }, $base_dir;
+
+ # remove the filename, if any
+ my $base_dir_orig = $base_dir;
+ $base_dir =~ s%/[^/]*$%/%;
+ if ($base_dir ne $base_dir_orig) {
+ push @{ $self->patterns },
+ "(?:(?:$base_site)?"
+ . quotemeta($base_dir)
+ . ")?$self->{parse_result}->{filepattern}";
+ push @{ $self->sites }, $base_site;
+ push @{ $self->basedirs }, $base_dir;
+ }
+ }
+ }
+
+ my $content = $response->decoded_content;
+ uscan_debug
+ "received content:\n$content\n[End of received content] by HTTP";
+
+ my @hrefs;
+ if (!$self->searchmode or $self->searchmode eq 'html') {
+ @hrefs = $self->html_search($content);
+ } elsif ($self->searchmode eq 'plain') {
+ @hrefs = $self->plain_search($content);
+ } else {
+ uscan_warn 'Unknown searchmode "' . $self->searchmode . '", skipping';
+ return undef;
+ }
+
+ if (@hrefs) {
+ @hrefs = Devscripts::Versort::versort(@hrefs);
+ my $msg
+ = "Found the following matching hrefs on the web page (newest first):\n";
+ foreach my $href (@hrefs) {
+ $msg .= " $$href[2] ($$href[1]) index=$$href[0] $$href[3]\n";
+ }
+ uscan_verbose $msg;
+ }
+ my ($newversion, $newfile);
+ if (defined $self->shared->{download_version}) {
+
+ # extract ones which has $match in the above loop defined
+ my @vhrefs = grep { $$_[3] } @hrefs;
+ if (@vhrefs) {
+ (undef, $newversion, $newfile, undef) = @{ $vhrefs[0] };
+ } else {
+ uscan_warn
+"In $self->{watchfile} no matching hrefs for version $self->{shared}->{download_version}"
+ . " in watch line\n $self->{line}";
+ return undef;
+ }
+ } else {
+ if (@hrefs) {
+ (undef, $newversion, $newfile, undef) = @{ $hrefs[0] };
+ } else {
+ uscan_warn
+"In $self->{watchfile} no matching files for watch line\n $self->{line}";
+ return undef;
+ }
+ }
+ return ($newversion, $newfile);
+}
+
+#######################################################################
+# determine $upstream_url (http mode)
+#######################################################################
+# http is complicated due to absolute/relative URL issue
+sub http_upstream_url {
+ my ($self) = @_;
+ my $upstream_url;
+ my $newfile = $self->search_result->{newfile};
+ if ($newfile =~ m%^\w+://%) {
+ $upstream_url = $newfile;
+ } elsif ($newfile =~ m%^//%) {
+ $upstream_url = $self->parse_result->{site};
+ $upstream_url =~ s/^(https?:).*/$1/;
+ $upstream_url .= $newfile;
+ } elsif ($newfile =~ m%^/%) {
+
+ # absolute filename
+ # Were there any redirections? If so try using those first
+ if ($#{ $self->patterns } > 0) {
+
+ # replace $site here with the one we were redirected to
+ foreach my $index (0 .. $#{ $self->patterns }) {
+ if ("$self->{sites}->[$index]$newfile"
+ =~ m&^$self->{patterns}->[$index]$&) {
+ $upstream_url = "$self->{sites}->[$index]$newfile";
+ last;
+ }
+ }
+ if (!defined($upstream_url)) {
+ uscan_verbose
+ "Unable to determine upstream url from redirections,\n"
+ . "defaulting to using site specified in watch file";
+ $upstream_url = "$self->{sites}->[0]$newfile";
+ }
+ } else {
+ $upstream_url = "$self->{sites}->[0]$newfile";
+ }
+ } else {
+ # relative filename, we hope
+ # Were there any redirections? If so try using those first
+ if ($#{ $self->patterns } > 0) {
+
+ # replace $site here with the one we were redirected to
+ foreach my $index (0 .. $#{ $self->patterns }) {
+
+ # skip unless the basedir looks like a directory
+ next unless $self->{basedirs}->[$index] =~ m%/$%;
+ my $nf = "$self->{basedirs}->[$index]$newfile";
+ if ("$self->{sites}->[$index]$nf"
+ =~ m&^$self->{patterns}->[$index]$&) {
+ $upstream_url = "$self->{sites}->[$index]$nf";
+ last;
+ }
+ }
+ if (!defined($upstream_url)) {
+ uscan_verbose
+ "Unable to determine upstream url from redirections,\n"
+ . "defaulting to using site specified in watch file";
+ $upstream_url = "$self->{parse_result}->{urlbase}$newfile";
+ }
+ } else {
+ $upstream_url = "$self->{parse_result}->{urlbase}$newfile";
+ }
+ }
+
+ # mangle if necessary
+ $upstream_url =~ s/&amp;/&/g;
+ uscan_verbose "Matching target for downloadurlmangle: $upstream_url";
+ if (@{ $self->downloadurlmangle }) {
+ if (
+ mangle(
+ $self->watchfile, \$self->line,
+ 'downloadurlmangle:', \@{ $self->downloadurlmangle },
+ \$upstream_url
+ )
+ ) {
+ $self->status(1);
+ return undef;
+ }
+ }
+ return $upstream_url;
+}
+
+sub http_newdir {
+ my (
+ $https, $downloader, $site,
+ $dir, $pattern, $dirversionmangle,
+ $watchfile, $lineptr, $download_version
+ ) = @_;
+
+ my ($request, $response, $newdir);
+ my ($download_version_short1, $download_version_short2,
+ $download_version_short3)
+ = partial_version($download_version);
+ my $base = $site . $dir;
+
+ if (defined($https) and !$downloader->ssl) {
+ uscan_die
+"$progname: you must have the liblwp-protocol-https-perl package installed\n"
+ . "to use https URLs";
+ }
+ $request = HTTP::Request->new('GET', $base);
+ $response = $downloader->user_agent->request($request);
+ if (!$response->is_success) {
+ uscan_warn
+ "In watch file $watchfile, reading webpage\n $base failed: "
+ . $response->status_line;
+ return '';
+ }
+
+ my $content = $response->content;
+ uscan_debug
+ "received content:\n$content\n[End of received content] by HTTP";
+
+ clean_content(\$content);
+
+ my $dirpattern = "(?:(?:$site)?" . quotemeta($dir) . ")?$pattern";
+
+ uscan_verbose "Matching pattern:\n $dirpattern";
+ my @hrefs;
+ my $match = '';
+ while ($content =~ m/<\s*a\s+[^>]*href\s*=\s*([\"\'])(.*?)\1/gi) {
+ my $href = fix_href($2);
+ uscan_verbose "Matching target for dirversionmangle: $href";
+ if ($href =~ m&^$dirpattern/?$&) {
+ my $mangled_version
+ = join(".", map { $_ // '' } $href =~ m&^$dirpattern/?$&);
+ if (
+ mangle(
+ $watchfile, $lineptr,
+ 'dirversionmangle:', \@{$dirversionmangle},
+ \$mangled_version
+ )
+ ) {
+ return 1;
+ }
+ $match = '';
+ if (defined $download_version
+ and $mangled_version eq $download_version) {
+ $match = "matched with the download version";
+ }
+ if (defined $download_version_short3
+ and $mangled_version eq $download_version_short3) {
+ $match = "matched with the download version (partial 3)";
+ }
+ if (defined $download_version_short2
+ and $mangled_version eq $download_version_short2) {
+ $match = "matched with the download version (partial 2)";
+ }
+ if (defined $download_version_short1
+ and $mangled_version eq $download_version_short1) {
+ $match = "matched with the download version (partial 1)";
+ }
+ push @hrefs, [$mangled_version, $href, $match];
+ }
+ }
+
+ # extract ones which has $match in the above loop defined
+ my @vhrefs = grep { $$_[2] } @hrefs;
+ if (@vhrefs) {
+ @vhrefs = Devscripts::Versort::upstream_versort(@vhrefs);
+ $newdir = $vhrefs[0][1];
+ }
+ if (@hrefs) {
+ @hrefs = Devscripts::Versort::upstream_versort(@hrefs);
+ my $msg = "Found the following matching directories (newest first):\n";
+ foreach my $href (@hrefs) {
+ $msg .= " $$href[1] ($$href[0]) $$href[2]\n";
+ }
+ uscan_verbose $msg;
+ $newdir //= $hrefs[0][1];
+ } else {
+ uscan_warn
+"In $watchfile,\n no matching hrefs for pattern\n $site$dir$pattern";
+ return '';
+ }
+
+ # just give the final directory component
+ $newdir =~ s%/$%%;
+ $newdir =~ s%^.*/%%;
+ return ($newdir);
+}
+
+# Nothing to clean here
+sub http_clean { 0 }
+
+sub clean_content {
+ my ($content) = @_;
+
+ # We need this horrid stuff to handle href=foo type
+ # links. OK, bad HTML, but we have to handle it nonetheless.
+ # It's bug #89749.
+ $$content =~ s/href\s*=\s*(?=[^\"\'])([^\s>]+)/href="$1"/ig;
+
+ # Strip comments
+ $$content =~ s/<!-- .*?-->//sg;
+ return $content;
+}
+
+sub html_search {
+ my ($self, $content) = @_;
+
+ # pagenmangle: should not abuse this slow operation
+ if (
+ mangle(
+ $self->watchfile, \$self->line,
+ 'pagemangle:\n', [@{ $self->pagemangle }],
+ \$content
+ )
+ ) {
+ return undef;
+ }
+ if ( !$self->shared->{bare}
+ and $content =~ m%^<[?]xml%i
+ and $content =~ m%xmlns="http://s3.amazonaws.com/doc/2006-03-01/"%
+ and $content !~ m%<Key><a\s+href%) {
+ # this is an S3 bucket listing. Insert an 'a href' tag
+ # into the content for each 'Key', so that it looks like html (LP: #798293)
+ uscan_warn
+"*** Amazon AWS special case code is deprecated***\nUse opts=pagemangle rule, instead";
+ $content =~ s%<Key>([^<]*)</Key>%<Key><a href="$1">$1</a></Key>%g;
+ uscan_debug
+"processed content:\n$content\n[End of processed content] by Amazon AWS special case code";
+ }
+ clean_content(\$content);
+
+ # Is there a base URL given?
+ if ($content =~ /<\s*base\s+[^>]*href\s*=\s*([\"\'])(.*?)\1/i) {
+
+ # Ensure it ends with /
+ $self->parse_result->{urlbase} = "$2/";
+ $self->parse_result->{urlbase} =~ s%//$%/%;
+ } else {
+ # May have to strip a base filename
+ ($self->parse_result->{urlbase} = $self->parse_result->{base})
+ =~ s%/[^/]*$%/%;
+ }
+ uscan_debug
+"processed content:\n$content\n[End of processed content] by fix bad HTML code";
+
+# search hrefs in web page to obtain a list of uversionmangled version and matching download URL
+ {
+ local $, = ',';
+ uscan_verbose "Matching pattern:\n @{$self->{patterns}}";
+ }
+ my @hrefs;
+ while ($content =~ m/<\s*a\s+[^>]*(?<=\s)href\s*=\s*([\"\'])(.*?)\1/sgi) {
+ my $href = $2;
+ $href = fix_href($href);
+ if (defined $self->hrefdecode) {
+ if ($self->hrefdecode eq 'percent-encoding') {
+ uscan_debug "... Decoding from href: $href";
+ $href =~ s/%([A-Fa-f\d]{2})/chr hex $1/eg;
+ } else {
+ uscan_warn "Illegal value for hrefdecode: "
+ . "$self->{hrefdecode}";
+ return undef;
+ }
+ }
+ uscan_debug "Checking href $href";
+ foreach my $_pattern (@{ $self->patterns }) {
+ if ($href =~ /^$_pattern$/) {
+ push @hrefs, $self->parse_href($href, $_pattern, $1);
+ }
+ }
+ }
+ return @hrefs;
+}
+
+sub plain_search {
+ my ($self, $content) = @_;
+ my @hrefs;
+ foreach my $_pattern (@{ $self->patterns }) {
+ while ($content =~ s/.*?($_pattern)//) {
+ push @hrefs, $self->parse_href($1, $_pattern, $2);
+ }
+ }
+ return @hrefs;
+}
+
+sub parse_href {
+ my ($self, $href, $_pattern, $match) = @_;
+ my $mangled_version;
+ if ($self->watch_version == 2) {
+
+ # watch_version 2 only recognised one group; the code
+ # below will break version 2 watch files with a construction
+ # such as file-([\d\.]+(-\d+)?) (bug #327258)
+ $mangled_version = $match;
+ } else {
+ # need the map { ... } here to handle cases of (...)?
+ # which may match but then return undef values
+ if ($self->versionless) {
+
+ # exception, otherwise $mangled_version = 1
+ $mangled_version = '';
+ } else {
+ $mangled_version
+ = join(".", map { $_ if defined($_) } $href =~ m&^$_pattern$&);
+ }
+
+ if (
+ mangle(
+ $self->watchfile, \$self->line,
+ 'uversionmangle:', \@{ $self->uversionmangle },
+ \$mangled_version
+ )
+ ) {
+ return ();
+ }
+ }
+ $match = '';
+ if (defined $self->shared->{download_version}) {
+ if ($mangled_version eq $self->shared->{download_version}) {
+ $match = "matched with the download version";
+ }
+ }
+ my $priority = $mangled_version . '-' . get_priority($href);
+ return [$priority, $mangled_version, $href, $match];
+}
+
+1;
generated by cgit v1.2.3 (git 2.39.1) at 2024-12-23 17:58:47 +0000