mirror of
git://git.sv.gnu.org/autoconf
synced 2024-11-21 01:01:48 +08:00
Rewrite fetch.sh in Perl.
Using HTTP::Tiny to talk to the network, instead of wget, means that we can make just one TCP connection to git.savannah.gnu.org to do the whole job, which is quite a bit faster. It should also be more robust against weird characters in filenames / URLs and stuff. The script has a higher requirement for Perl than is the standard in autoconf -- 5.14 (first version with HTTP::Tiny), with IO::Socket::SSL installed -- but that’s ok, I hope, because it’s maintainer-only and not installed. fetch.sh was the sole user of move-if-change, and the Perl script does that job itself, but I left move-if-change in build-aux and on the fetch list anyway, in case we discover another use for it in the future. * build-aux/fetch.sh: Replace with... * build-aux/fetch.pl: ... reimplementation in Perl. * cfg.mk (fetch): Update to match.
This commit is contained in:
Zack Weinberg
parent
b560f0a657
commit
93270f112e
243
build-aux/fetch.pl
Executable file
243
build-aux/fetch.pl
Executable file
@ -0,0 +1,243 @@
|
||||
#! /usr/bin/perl
|
||||
# Copyright (C) 2020 Free Software Foundation, Inc.
|
||||
|
||||
# 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, or (at your option)
|
||||
# any later version.
|
||||
|
||||
# This program is distributed in the hope that it will be useful,
|
||||
# but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
# GNU General Public License for more details.
|
||||
|
||||
# You should have received a copy of the GNU General Public License
|
||||
# along with this program. If not, see <https://www.gnu.org/licenses/>.
|
||||
|
||||
use 5.014; # first version with HTTP::Tiny
|
||||
use strict;
|
||||
use utf8;
|
||||
use feature 'unicode_strings';
|
||||
use warnings FATAL => 'all';
|
||||
|
||||
use Fcntl qw (S_IMODE);
|
||||
use File::Spec;
|
||||
use File::stat;
|
||||
use File::Temp qw (tempfile);
|
||||
use Getopt::Long;
|
||||
use HTTP::Tiny;
|
||||
|
||||
our @gnulib_files = qw(
|
||||
build-aux/announce-gen
|
||||
build-aux/config.guess
|
||||
build-aux/config.sub
|
||||
build-aux/gendocs.sh
|
||||
build-aux/git-version-gen
|
||||
build-aux/gitlog-to-changelog
|
||||
build-aux/gnupload
|
||||
build-aux/install-sh
|
||||
build-aux/mdate-sh
|
||||
build-aux/move-if-change
|
||||
build-aux/texinfo.tex
|
||||
build-aux/update-copyright
|
||||
build-aux/useless-if-before-free
|
||||
build-aux/vc-list-files
|
||||
doc/fdl.texi
|
||||
doc/gendocs_template
|
||||
doc/gnu-oids.texi
|
||||
doc/make-stds.texi
|
||||
doc/standards.texi
|
||||
m4/autobuild.m4
|
||||
top/GNUmakefile
|
||||
top/maint.mk
|
||||
);
|
||||
|
||||
our @automake_files = qw(
|
||||
lib/Automake/Channels.pm
|
||||
lib/Automake/Configure_ac.pm
|
||||
lib/Automake/FileUtils.pm
|
||||
lib/Automake/Getopt.pm
|
||||
lib/Automake/XFile.pm
|
||||
);
|
||||
|
||||
|
||||
# Shorthands for catpath and splitpath.
|
||||
# File::Spec::Functions was only added in 5.30, which is much too new.
|
||||
sub catpath
|
||||
{
|
||||
return File::Spec->catpath (@_);
|
||||
}
|
||||
|
||||
sub splitpath
|
||||
{
|
||||
return File::Spec->splitpath (@_);
|
||||
}
|
||||
|
||||
|
||||
# urlquote($s)
|
||||
# Returns $s, %-quoted appropriately for interpolation into the
|
||||
# path or query component of a URL. Assumes that non-ASCII characters
|
||||
# should be encoded in UTF-8 before quoting.
|
||||
sub urlquote($)
|
||||
{
|
||||
my ($s) = @_;
|
||||
|
||||
utf8::encode($s);
|
||||
use bytes;
|
||||
$s =~ s!
|
||||
[^./0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ_abcdefghijklmnopqrstuvwxyz~-]
|
||||
!
|
||||
sprintf("%%%02X", ord($&))
|
||||
!egx;
|
||||
return $s;
|
||||
}
|
||||
|
||||
|
||||
# savannah_url($repo, $filename)
|
||||
# Returns the URL from which the contents of $filename within $repo
|
||||
# can be retrieved, assuming $repo is the name of a savannah.gnu.org
|
||||
# Git repository.
|
||||
sub savannah_url($$)
|
||||
{
|
||||
my ($repo, $filename) = @_;
|
||||
|
||||
my $gitweb_base = 'https://git.savannah.gnu.org/gitweb/?p=';
|
||||
my $gitweb_op = '.git;a=blob_plain;hb=HEAD;f=';
|
||||
|
||||
return $gitweb_base . urlquote ($repo) . $gitweb_op . urlquote ($filename);
|
||||
}
|
||||
|
||||
|
||||
# slurp ($filename)
|
||||
# Read the contents of $filename into a scalar and return them.
|
||||
sub slurp ($)
|
||||
{
|
||||
my ($filename) = @_;
|
||||
local $/; # engage slurp mode
|
||||
open my $fh, '<', $filename
|
||||
or die "$filename: $!\n";
|
||||
return scalar <$fh>;
|
||||
}
|
||||
|
||||
|
||||
# replace_if_change ($file, $newcontents, $quiet)
|
||||
# If $newcontents is different from the contents of $file,
|
||||
# atomically replace $file's contents with $newcontents.
|
||||
# This function assumes POSIX semantics for rename over an existing
|
||||
# file (i.e. atomic replacement, not an error).
|
||||
sub replace_if_change ($$$)
|
||||
{
|
||||
my ($file, $newcontents, $quiet) = @_;
|
||||
my $oldcontents = slurp $file;
|
||||
|
||||
if ($oldcontents eq $newcontents)
|
||||
{
|
||||
print STDERR "$file is unchanged\n" unless $quiet;
|
||||
return;
|
||||
}
|
||||
|
||||
my ($vol, $subdir, $base) = splitpath $file;
|
||||
my ($tmp_fh, $tmp_name) = tempfile (DIR => catpath ($vol, $subdir));
|
||||
|
||||
{
|
||||
local $\;
|
||||
local $,;
|
||||
print $tmp_fh $newcontents;
|
||||
}
|
||||
close $tmp_fh
|
||||
or die "$0: writing to $tmp_name: $!\n";
|
||||
|
||||
# Preserve the permissions of the original file.
|
||||
my $st = stat $file;
|
||||
chmod (S_IMODE ($st->mode), $tmp_name)
|
||||
or die "$0: setting permissions on $tmp_name: $!\n";
|
||||
|
||||
rename $tmp_name, $file
|
||||
or die "$0: rename($tmp_name, $file): $!\n";
|
||||
|
||||
print STDERR "$file updated\n" unless $quiet;
|
||||
}
|
||||
|
||||
|
||||
# fetch ($path, $repo, $topdestdir, $edit, $quiet, $client)
|
||||
# Retrieve $path from repository $repo, writing it to $topdestdir/$path.
|
||||
# As a special case, if the dirname of $path is "top/", then write it
|
||||
# to $topdestdir/$(basename $file) instead.
|
||||
# If $edit is true, perform s/\bAutomake::/Autom4te::/g on the file's
|
||||
# contents.
|
||||
# If $quiet is true, don't print progress reports.
|
||||
# $client must be a HTTP::Tiny instance.
|
||||
sub fetch ($$$$$$)
|
||||
{
|
||||
my ($path, $repo, $topdestdir, $edit, $quiet, $client) = @_;
|
||||
my ($vol, $subdir, $file) = splitpath ($path);
|
||||
my $destpath = ($subdir eq 'top/')
|
||||
? catpath($topdestdir, $file)
|
||||
: catpath($topdestdir, $path);
|
||||
|
||||
$destpath =~ s!/Automake/!/Autom4te/!g if $edit;
|
||||
|
||||
my $uri = savannah_url ($repo, $path);
|
||||
print STDERR "fetch $path <- $uri ...\n" unless $quiet;
|
||||
|
||||
my $resp = $client->get ($uri);
|
||||
|
||||
die "$uri: $resp->{status} $resp->{reason}\n"
|
||||
unless $resp->{success};
|
||||
|
||||
my $content = $resp->{content};
|
||||
$content =~ s/\bAutomake::/Autom4te::/g if $edit;
|
||||
|
||||
replace_if_change ($destpath, $content, $quiet);
|
||||
}
|
||||
|
||||
|
||||
sub main
|
||||
{
|
||||
my $quiet = 0;
|
||||
GetOptions ('quiet|q' => \$quiet)
|
||||
or die "usage: $0 [-q] destination-directory\n";
|
||||
|
||||
my $topdestdir = shift @ARGV
|
||||
or die "usage: $0 [-q] destination-directory\n";
|
||||
|
||||
$#ARGV == -1
|
||||
or die "usage: $0 [-q] destination-directory\n";
|
||||
|
||||
my $client = HTTP::Tiny->new(
|
||||
agent => 'autoconf-fetch.pl/1.0 ',
|
||||
keep_alive => 1,
|
||||
verify_SSL => 1
|
||||
);
|
||||
|
||||
my ($can_ssl, $whynot) = $client->can_ssl;
|
||||
die "$0: HTTPS support not available"
|
||||
. " (do you need to install IO::Socket::SSL?\n"
|
||||
. $whynot . "\n"
|
||||
unless $can_ssl;
|
||||
|
||||
fetch $_, 'gnulib', $topdestdir, 0, $quiet, $client
|
||||
foreach @gnulib_files;
|
||||
|
||||
fetch $_, 'automake', $topdestdir, 1, $quiet, $client
|
||||
foreach @automake_files;
|
||||
}
|
||||
|
||||
main ();
|
||||
|
||||
### Setup "GNU" style for perl-mode and cperl-mode.
|
||||
## Local Variables:
|
||||
## perl-indent-level: 2
|
||||
## perl-continued-statement-offset: 2
|
||||
## perl-continued-brace-offset: 0
|
||||
## perl-brace-offset: 0
|
||||
## perl-brace-imaginary-offset: 0
|
||||
## perl-label-offset: -2
|
||||
## cperl-indent-level: 2
|
||||
## cperl-brace-offset: 0
|
||||
## cperl-continued-brace-offset: 0
|
||||
## cperl-label-offset: -2
|
||||
## cperl-extra-newline-before-brace: t
|
||||
## cperl-merge-trailing-else: nil
|
||||
## cperl-continued-statement-offset: 2
|
||||
## End:
|
||||
@ -1,78 +0,0 @@
|
||||
#! /bin/sh
|
||||
|
||||
: "${WGET=wget}"
|
||||
: "${PERL=perl}"
|
||||
|
||||
gitweb_base="https://git.savannah.gnu.org/gitweb/?p="
|
||||
gitweb_op=";a=blob_plain;hb=HEAD;f="
|
||||
|
||||
gnulib_gitweb="${gitweb_base}gnulib.git${gitweb_op}"
|
||||
automake_gitweb="${gitweb_base}automake.git${gitweb_op}"
|
||||
|
||||
# This list should be in alphabetical order, *except* that this script
|
||||
# uses move-if-change itself, so that one should be first.
|
||||
gnulib_files="
|
||||
build-aux/move-if-change
|
||||
build-aux/announce-gen
|
||||
build-aux/config.guess
|
||||
build-aux/config.sub
|
||||
build-aux/gendocs.sh
|
||||
build-aux/git-version-gen
|
||||
build-aux/gitlog-to-changelog
|
||||
build-aux/gnupload
|
||||
build-aux/install-sh
|
||||
build-aux/mdate-sh
|
||||
build-aux/texinfo.tex
|
||||
build-aux/update-copyright
|
||||
build-aux/useless-if-before-free
|
||||
build-aux/vc-list-files
|
||||
doc/fdl.texi
|
||||
doc/gendocs_template
|
||||
doc/gnu-oids.texi
|
||||
doc/make-stds.texi
|
||||
doc/standards.texi
|
||||
m4/autobuild.m4
|
||||
top/GNUmakefile
|
||||
top/maint.mk
|
||||
"
|
||||
|
||||
automake_files="
|
||||
lib/Automake/Channels.pm
|
||||
lib/Automake/Configure_ac.pm
|
||||
lib/Automake/FileUtils.pm
|
||||
lib/Automake/Getopt.pm
|
||||
lib/Automake/XFile.pm
|
||||
"
|
||||
|
||||
srcdir="$1"
|
||||
shift
|
||||
|
||||
move_if_change="${srcdir}/build-aux/move-if-change"
|
||||
|
||||
scratch="$(mktemp -p . -d fetch.XXXXXXXXX)"
|
||||
trap "rm -rf '$scratch'" 0
|
||||
|
||||
run () {
|
||||
printf '+ %s\n' "$*"
|
||||
"$@" || exit 1
|
||||
}
|
||||
|
||||
for file in $gnulib_files; do
|
||||
fbase="${file##*/}"
|
||||
destdir="${file%/*}"
|
||||
if [ "$destdir" = top ]; then
|
||||
dest="${srcdir}/${fbase}"
|
||||
else
|
||||
dest="${srcdir}/${file}"
|
||||
fi
|
||||
run "$WGET" -nv -O "${scratch}/${fbase}" "${gnulib_gitweb}${file}"
|
||||
run "$move_if_change" "${scratch}/${fbase}" "$dest"
|
||||
done
|
||||
|
||||
for file in $automake_files; do
|
||||
fbase="${file##*/}"
|
||||
dest="${srcdir}/lib/Autom4te/${fbase}"
|
||||
run "$WGET" -nv -O "${scratch}/${fbase}" "${automake_gitweb}${file}"
|
||||
run "$PERL" -pi -e 's/Automake::/Autom4te::/g' "${scratch}/${fbase}"
|
||||
run "$move_if_change" "${scratch}/${fbase}" "$dest"
|
||||
done
|
||||
6
cfg.mk
6
cfg.mk
@ -48,12 +48,8 @@ Mail-Followup-To: autoconf@gnu.org
|
||||
|
||||
# Update files maintained in gnulib and autom4te.
|
||||
.PHONY: fetch
|
||||
|
||||
WGET = wget
|
||||
|
||||
fetch:
|
||||
WGET="$(WGET)" PERL="$(PERL)" \
|
||||
$(SHELL) $(srcdir)/build-aux/fetch.sh "$(abs_top_srcdir)"
|
||||
$(PERL) $(srcdir)/build-aux/fetch.pl "$(abs_top_srcdir)"
|
||||
|
||||
# Tests not to run.
|
||||
local-checks-to-skip ?= \
|
||||
|
||||
Loading…
Reference in New Issue
Block a user