diff options
author | Daniel Baumann <daniel.baumann@progress-linux.org> | 2024-04-07 15:53:52 +0000 |
---|---|---|
committer | Daniel Baumann <daniel.baumann@progress-linux.org> | 2024-04-07 15:53:52 +0000 |
commit | efe47381c599b07e4c7bbdb2e91e8090a541c887 (patch) | |
tree | 05cf57183f5a23394eca11b00f97a74a5dfdf79d /lib/Devscripts/Uscan/ftp.pm | |
parent | Initial commit. (diff) | |
download | devscripts-upstream/2.23.4+deb12u1.tar.xz devscripts-upstream/2.23.4+deb12u1.zip |
Adding upstream version 2.23.4+deb12u1.upstream/2.23.4+deb12u1upstream
Signed-off-by: Daniel Baumann <daniel.baumann@progress-linux.org>
Diffstat (limited to '')
-rw-r--r-- | lib/Devscripts/Uscan/ftp.pm | 280 |
1 files changed, 280 insertions, 0 deletions
diff --git a/lib/Devscripts/Uscan/ftp.pm b/lib/Devscripts/Uscan/ftp.pm new file mode 100644 index 0000000..5a24d8a --- /dev/null +++ b/lib/Devscripts/Uscan/ftp.pm @@ -0,0 +1,280 @@ +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_extra_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} + and not $self->versionmode eq 'ignore') { + 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 ($line, $site, $dir, $pattern, $dirversionmangle, $watchfile, + $lineptr, $download_version) + = @_; + my $downloader = $line->downloader; + + 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_extra_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; |