diff options
Diffstat (limited to '')
| -rw-r--r-- | lib/Devscripts/Uscan/Downloader.pm | 303 |
1 files changed, 303 insertions, 0 deletions
diff --git a/lib/Devscripts/Uscan/Downloader.pm b/lib/Devscripts/Uscan/Downloader.pm new file mode 100644 index 0000000..292884f --- /dev/null +++ b/lib/Devscripts/Uscan/Downloader.pm @@ -0,0 +1,303 @@ +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 Dpkg::IPC; +use File::DirList; +use File::Find; +use File::Temp qw/tempdir/; +use File::Touch; +use Moo; +use URI; + +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 git_export_all => ( + 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 }); + +has headers => ( + is => 'ro', + default => sub { {} }); + +sub download ($$$$$$$$) { + my ( + $self, $url, $fname, $optref, $base, + $pkg_dir, $pkg, $mode, $gitrepo_dir + ) = @_; + 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 "&" required? I doubt it. + uscan_verbose "Requesting URL:\n $url"; + my $headers = HTTP::Headers->new; + $headers->header('Accept' => '*/*'); + $headers->header('Referer' => $base); + my $uri_o = URI->new($url); + foreach my $k (keys %{ $self->headers }) { + if ($k =~ /^(.*?)@(.*)$/) { + my $baseUrl = $1; + my $hdr = $2; + if ($url =~ m#^\Q$baseUrl\E(?:/.*)?$#) { + $headers->header($hdr => $self->headers->{$k}); + uscan_verbose "Set per-host custom header $hdr for $url"; + } else { + uscan_debug "$url does not start with $1"; + } + } else { + uscan_warn "Malformed http-header: $k"; + } + } + $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|zstd?)%; + my $dst = $1; + my $abs_dst = abs_path($dst); + my $ver = $2; + my $suffix = $3; + my ($gitrepo, $gitref) = split /[[:space:]]+/, $url, 2; + my $clean = sub { + uscan_exec_no_fail('rm', '-fr', $gitrepo_dir); + }; + my $clean_and_die = sub { + $clean->(); + uscan_die @_; + }; + + if ($mode eq 'svn') { + my $tempdir = tempdir(CLEANUP => 1); + my $old_umask = umask(oct('022')); + uscan_exec('svn', 'export', $url, "$tempdir/$pkg-$ver"); + umask($old_umask); + find({ + wanted => sub { + return if !-d $File::Find::name; + my ($newest) = grep { $_ ne '.' && $_ ne '..' } + map { $_->[13] } @{ File::DirList::list($_, 'M') }; + return if !$newest; + my $touch + = File::Touch->new(reference => $_ . '/' . $newest); + $touch->touch($_); + }, + bydepth => 1, + no_chdir => 1, + }, + "$tempdir/$pkg-$ver" + ); + uscan_exec( + 'tar', '-C', + $tempdir, '--sort=name', + '--owner=root', '--group=root', + '-cvf', "$abs_dst/$pkg-$ver.tar", + "$pkg-$ver" + ); + } elsif ($self->git_upstream) { + my ($infodir, $attr_file, $attr_bkp); + if ($self->git_export_all) { + # override any export-subst and export-ignore attributes + spawn( + exec => [qw|git rev-parse --git-path info/|], + to_string => \$infodir, + ); + chomp $infodir; + mkdir $infodir unless -e $infodir; + spawn( + exec => [qw|git rev-parse --git-path info/attributes|], + to_string => \$attr_file, + ); + chomp $attr_file; + spawn( + exec => + [qw|git rev-parse --git-path info/attributes-uscan|], + to_string => \$attr_bkp, + ); + chomp $attr_bkp; + rename $attr_file, $attr_bkp if -e $attr_file; + my $attr_fh; + + unless (open($attr_fh, '>', $attr_file)) { + rename $attr_bkp, $attr_file if -e $attr_bkp; + uscan_die("could not open $attr_file for writing"); + } + print $attr_fh "* -export-subst\n* -export-ignore\n"; + close $attr_fh; + } + + uscan_exec_no_fail('git', 'archive', '--format=tar', + "--prefix=$pkg-$ver/", "--output=$abs_dst/$pkg-$ver.tar", + $gitref) == 0 + or $clean_and_die->("git archive failed"); + + if ($self->git_export_all) { + # restore attributes + if (-e $attr_bkp) { + rename $attr_bkp, $attr_file; + } else { + unlink $attr_file; + } + } + } else { + if ($self->gitrepo_state == 0) { + if ($optref->gitmode eq 'shallow') { + my $tag = $gitref; + $tag =~ s#^refs/(?:tags|heads)/##; + 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); + } + } + if ($self->git_export_all) { + # override any export-subst and export-ignore attributes + my ($infodir, $attr_file); + spawn( + exec => [ + 'git', "--git-dir=$destdir/$gitrepo_dir", + 'rev-parse', '--git-path', 'info/' + ], + to_string => \$infodir, + ); + chomp $infodir; + mkdir $infodir unless -e $infodir; + spawn( + exec => [ + 'git', "--git-dir=$destdir/$gitrepo_dir", + 'rev-parse', '--git-path', + 'info/attributes' + ], + to_string => \$attr_file, + ); + chomp $attr_file; + my $attr_fh; + $clean_and_die->("could not open $attr_file for writing") + unless open($attr_fh, '>', $attr_file); + print $attr_fh "* -export-subst\n* -export-ignore\n"; + close $attr_fh; + } + + 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 $clean_and_die->("git archive failed"); + } + + chdir "$abs_dst" or $clean_and_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"); + #} elsif ($suffix =~ /^zstd?$/) { + # uscan_exec("zstd", "$pkg-$ver.tar"); + } else { + $clean_and_die->("Unknown suffix file to repack: $suffix"); + } + chdir "$curdir" or $clean_and_die->("Unable to chdir($curdir): $!"); + $clean->(); + } + return 1; +} + +1; |