517 lines
16 KiB
Perl
517 lines
16 KiB
Perl
|
|
=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 Dpkg::Version;
|
|
use File::Copy qw/copy move/;
|
|
use List::Util qw/first/;
|
|
use Moo;
|
|
|
|
use constant {
|
|
ANY_VERSION => '(?:[-_]?[Vv]?(\d[\-+\.:\~\da-zA-Z]*))',
|
|
ARCHIVE_EXT =>
|
|
'(?i)(?:\.(?:tar\.xz|tar\.bz2|tar\.gz|tar\.zstd?|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,
|
|
headers => $_[0]->config->http_header,
|
|
});
|
|
},
|
|
);
|
|
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 {
|
|
$watch_version = 1;
|
|
}
|
|
}
|
|
if ($watch_version < 3) {
|
|
uscan_warn
|
|
"$args->{watchfile} is an obsolete version $watch_version watch file;\n"
|
|
. " please upgrade to a higher version\n"
|
|
. " (see uscan(1) for details).";
|
|
}
|
|
|
|
# "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 =~ /^(?:group|checksum)$/);
|
|
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) = @_;
|
|
my $saveDconfig = $self->config->download_version;
|
|
# Build version
|
|
my @cur_versions = split /\+~/, $self->pkg_version;
|
|
my $checksum = 0;
|
|
my $newChecksum = 0;
|
|
if ( $cur_versions[$#cur_versions]
|
|
and $cur_versions[$#cur_versions] =~ s/^cs//) {
|
|
$checksum = pop @cur_versions;
|
|
}
|
|
my (@new_versions, @last_debian_mangled_uversions, @last_versions);
|
|
my $download = 0;
|
|
my $last_shared = $self->shared;
|
|
my $last_comp_version;
|
|
my @dversion;
|
|
my @ck_versions;
|
|
# Isolate component and following lines
|
|
if (my $v = $self->config->download_version) {
|
|
@dversion = map { s/\+.*$//; /^cs/ ? () : $_ } split /\+~/, $v;
|
|
}
|
|
foreach my $line (@{ $self->watchlines }) {
|
|
if ( $line->type and $line->type eq 'group'
|
|
or $line->type eq 'checksum') {
|
|
$last_shared = $self->new_shared;
|
|
$last_comp_version = shift @cur_versions if $line->type eq 'group';
|
|
}
|
|
if ($line->type and $line->type eq 'group') {
|
|
$line->{groupDversion} = shift @dversion;
|
|
}
|
|
$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' or $line->type eq 'checksum');
|
|
# Stop on error
|
|
$self->config->download_version($line->{groupDversion})
|
|
if $line->{groupDversion};
|
|
$self->config->download_version(undef) if $line->type eq 'checksum';
|
|
if ( $line->parse
|
|
or $line->search
|
|
or $line->get_upstream_url
|
|
or $line->get_newfile_base
|
|
or ($line->type eq 'group' and $line->cmp_versions)
|
|
or ($line->ctype and $line->cmp_versions)) {
|
|
$self->{status} += $line->status;
|
|
return $self->{status};
|
|
}
|
|
$download = $line->shared->{download}
|
|
if $line->shared->{download} > $download
|
|
and ($line->type eq 'group' or $line->ctype);
|
|
}
|
|
foreach my $line (@{ $self->watchlines }) {
|
|
next unless $line->type eq 'checksum';
|
|
$newChecksum
|
|
= $self->sum($newChecksum, $line->search_result->{newversion});
|
|
push @ck_versions, $line->search_result->{newversion};
|
|
}
|
|
foreach my $line (@{ $self->watchlines }) {
|
|
next unless ($line->type eq 'checksum');
|
|
$line->parse_result->{mangled_lastversion} = $checksum;
|
|
my $tmp = $line->search_result->{newversion};
|
|
$line->search_result->{newversion} = $newChecksum;
|
|
unless ($line->ctype) {
|
|
if ($line->cmp_versions) {
|
|
$self->{status} += $line->status;
|
|
return $self->{status};
|
|
}
|
|
$download = $line->shared->{download}
|
|
if $line->shared->{download} > $download;
|
|
}
|
|
$line->search_result->{newversion} = $tmp;
|
|
if ($line->component) {
|
|
pop @{ $dehs_tags->{'component-upstream-version'} };
|
|
push @{ $dehs_tags->{'component-upstream-version'} }, $tmp;
|
|
}
|
|
}
|
|
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' or $line->type eq 'checksum') {
|
|
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;
|
|
if ($newChecksum) {
|
|
$new_version .= "+~cs$newChecksum";
|
|
}
|
|
if ($checksum) {
|
|
push @last_versions, "cs$newChecksum";
|
|
push @last_debian_mangled_uversions, "cs$checksum";
|
|
}
|
|
$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-mangled-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/;
|
|
uscan_warn "rename $line->{destfile} to $path\n";
|
|
rename $line->{destfile}, $path;
|
|
if ($dehs_tags->{"target-path"} eq $line->{destfile}) {
|
|
$dehs_tags->{"target-path"} = $path;
|
|
$dehs_tags->{target} =~ s/\Q$ver\E/$new_version/;
|
|
} else {
|
|
for (
|
|
my $i = 0 ;
|
|
$i < @{ $dehs_tags->{"component-target-path"} } ;
|
|
$i++
|
|
) {
|
|
if ($dehs_tags->{"component-target-path"}->[$i] eq
|
|
$line->{destfile}) {
|
|
$dehs_tags->{"component-target-path"}->[$i] = $path;
|
|
$dehs_tags->{"component-target"}->[$i]
|
|
=~ s/\Q$ver\E/$new_version/
|
|
or die $ver;
|
|
}
|
|
}
|
|
}
|
|
if ($line->signature_available) {
|
|
rename "$line->{destfile}.asc", "$path.asc";
|
|
rename "$line->{destfile}.sig", "$path.sig";
|
|
}
|
|
}
|
|
if (@ck_versions) {
|
|
my $v = join '+~', @ck_versions;
|
|
if ($dehs) {
|
|
$dehs_tags->{'decoded-checksum'} = $v;
|
|
} else {
|
|
uscan_verbose 'Checksum ref: ' . join('+~', @ck_versions) . "\n";
|
|
}
|
|
}
|
|
return 0;
|
|
}
|
|
|
|
sub sum {
|
|
my ($self, @versions) = @_;
|
|
my (@res, @str);
|
|
foreach my $v (@versions) {
|
|
my @tmp = grep { $_ ne '.' } version_split_digits($v);
|
|
for (my $i = 0 ; $i < @tmp ; $i++) {
|
|
$str[$i] //= '';
|
|
$res[$i] //= 0;
|
|
if ($tmp[$i] =~ /^\d+$/) {
|
|
$res[$i] += $tmp[$i];
|
|
} else {
|
|
uscan_die
|
|
"Checksum supports only digits in versions, $tmp[$i] is not accepted";
|
|
}
|
|
}
|
|
}
|
|
for (my $i = 0 ; $i < @res ; $i++) {
|
|
my $tmp = shift @str;
|
|
$res[$i] .= $tmp if $tmp ne '';
|
|
}
|
|
push @res, @str;
|
|
return join '.', @res;
|
|
}
|
|
|
|
1;
|