From 93270f112e69ede0afbb57d40c4bc6fbb6a1c2cf Mon Sep 17 00:00:00 2001 From: Zack Weinberg Date: Fri, 11 Sep 2020 14:51:00 -0400 Subject: [PATCH] Rewrite fetch.sh in Perl. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit 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. --- build-aux/fetch.pl | 243 +++++++++++++++++++++++++++++++++++++++++++++ build-aux/fetch.sh | 78 --------------- cfg.mk | 6 +- 3 files changed, 244 insertions(+), 83 deletions(-) create mode 100755 build-aux/fetch.pl delete mode 100755 build-aux/fetch.sh diff --git a/build-aux/fetch.pl b/build-aux/fetch.pl new file mode 100755 index 00000000..b2d41055 --- /dev/null +++ b/build-aux/fetch.pl @@ -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 . + +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: diff --git a/build-aux/fetch.sh b/build-aux/fetch.sh deleted file mode 100755 index f5a5537a..00000000 --- a/build-aux/fetch.sh +++ /dev/null @@ -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 diff --git a/cfg.mk b/cfg.mk index e6dc4996..33ad6e06 100644 --- a/cfg.mk +++ b/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 ?= \