build-aux/fetch.pl

   1 #! /usr/bin/perl
   2 # Copyright (C) 2020-2022 Free Software Foundation, Inc.
   3
   4 # This program is free software; you can redistribute it and/or modify
   5 # it under the terms of the GNU General Public License as published by
   6 # the Free Software Foundation; either version 2, or (at your option)
   7 # any later version.
   8
   9 # This program is distributed in the hope that it will be useful,
  10 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  11 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12 # GNU General Public License for more details.
  13
  14 # You should have received a copy of the GNU General Public License
  15 # along with this program.  If not, see <https://www.gnu.org/licenses/>.
  16
  17 use 5.014;  # first version with HTTP::Tiny
  18 use strict;
  19 use utf8;
  20 use feature 'unicode_strings';
  21 use warnings FATAL => 'all';
  22
  23 use Fcntl qw (S_IMODE);
  24 use File::Spec;
  25 use File::stat;
  26 use File::Temp qw (tempfile);
  27 use Getopt::Long;
  28 use HTTP::Tiny;
  29
  30 # From outside to inside: locations in our source tree where to put
  31 # files retrieved from other projects; the savannah.gnu.org project
  32 # name of each project to retrieve files from; and the set of files
  33 # to retrieve from that project into that location.
  34 # Files put into a directory named 'Autom4te' are subject to "editing"
  35 # (see the $edit parameter to sub fetch).
  36 our %to_fetch = (
  37   '.' => {
  38     gnulib => [
  39       'top/GNUmakefile',
  40       'top/maint.mk',
  41     ],
  42   },
  43   'build-aux' => {
  44     automake => [
  45       'lib/install-sh',
  46     ],
  47     config => [
  48       'config.guess',
  49       'config.sub',
  50     ],
  51     gnulib => [
  52       'build-aux/announce-gen',
  53       'build-aux/gendocs.sh',
  54       'build-aux/git-version-gen',
  55       'build-aux/gitlog-to-changelog',
  56       'build-aux/gnupload',
  57       'build-aux/move-if-change',
  58       'build-aux/update-copyright',
  59       'build-aux/useless-if-before-free',
  60       'build-aux/vc-list-files',
  61     ],
  62     texinfo => [
  63       'doc/texinfo.tex',
  64     ],
  65   },
  66   'doc' => {
  67     gnulib => [
  68       'doc/gendocs_template',
  69     ],
  70     gnustandards => [
  71       'gnustandards/fdl.texi',
  72       'gnustandards/gnu-oids.texi',
  73       'gnustandards/make-stds.texi',
  74       'gnustandards/standards.texi',
  75     ],
  76   },
  77   'lib/Autom4te' => {
  78     automake => [
  79       'lib/Automake/ChannelDefs.pm',
  80       'lib/Automake/Channels.pm',
  81       'lib/Automake/Configure_ac.pm',
  82       'lib/Automake/FileUtils.pm',
  83       'lib/Automake/Getopt.pm',
  84       'lib/Automake/XFile.pm',
  85     ],
  86   },
  87   'm4' => {
  88     gnulib => [
  89       'm4/autobuild.m4',
  90     ],
  91   },
  92 );
  93
  94
  95 # Shorthands for catfile and splitpath.
  96 # File::Spec::Functions was only added in 5.30, which is much too new.
  97 sub catfile
  98 {
  99   return File::Spec->catfile (@_);
 100 }
 101
 102 sub splitpath
 103 {
 104   return File::Spec->splitpath (@_);
 105 }
 106
 107
 108 # urlquote($s)
 109 # Returns $s, %-quoted appropriately for interpolation into the
 110 # path or query component of a URL.  Assumes that non-ASCII characters
 111 # should be encoded in UTF-8 before quoting.
 112 sub urlquote($)
 113 {
 114   my ($s) = @_;
 115
 116   utf8::encode($s);
 117   use bytes;
 118   $s =~ s!
 119     [^./0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ_abcdefghijklmnopqrstuvwxyz~-]
 120    !
 121     sprintf("%%%02X", ord($&))
 122    !egx;
 123   return $s;
 124 }
 125
 126
 127 # savannah_url($repo, $filename)
 128 # Returns the URL from which the contents of $filename within $repo
 129 # can be retrieved, assuming $repo is the name of a savannah.gnu.org
 130 # Git repository.
 131 sub savannah_url($$)
 132 {
 133   my ($repo, $filename) = @_;
 134
 135   $repo = urlquote ($repo);
 136   $filename = urlquote ($filename);
 137
 138   # The GNU Coding Standards are still maintained in CVS.
 139   if ($repo eq 'gnustandards')
 140     {
 141       my $cvsweb_base = 'https://cvs.savannah.gnu.org/viewvc/*checkout*/';
 142       return $cvsweb_base . $repo . '/' . $filename;
 143     }
 144   else
 145     {
 146       my $cgit_base = 'https://git.savannah.gnu.org/cgit/';
 147       my $cgit_op   = '.git/plain/';
 148
 149       return $cgit_base . $repo . $cgit_op . $filename;
 150   }
 151 }
 152
 153
 154 # slurp ($filename)
 155 # Read the contents of $filename into a scalar and return them.
 156 # If $filename does not exist, return undef; any other error is fatal.
 157 sub slurp ($)
 158 {
 159   my ($filename) = @_;
 160   local $/; # engage slurp mode
 161   if (open my $fh, '<', $filename)
 162     {
 163       return scalar <$fh>;
 164     }
 165   elsif ($!{ENOENT})
 166     {
 167       return undef;
 168     }
 169   else
 170     {
 171       die "$filename: $!\n";
 172     }
 173 }
 174
 175
 176 # replace_if_change ($file, $newcontents, $quiet)
 177 # If $newcontents is different from the contents of $file,
 178 # atomically replace $file's contents with $newcontents.
 179 # This function assumes POSIX semantics for rename over an existing
 180 # file (i.e.  atomic replacement, not an error).
 181 sub replace_if_change ($$$)
 182 {
 183   my ($file, $newcontents, $quiet) = @_;
 184   my $oldcontents = slurp $file;
 185
 186   if (defined $oldcontents && $oldcontents eq $newcontents)
 187     {
 188       print STDERR "$file is unchanged\n" unless $quiet;
 189       return;
 190     }
 191
 192   my (undef, $subdir, undef) = splitpath $file;
 193   my ($tmp_fh, $tmp_name) = tempfile (DIR => $subdir);
 194
 195   {
 196     local $\;
 197     local $,;
 198     print $tmp_fh $newcontents;
 199   }
 200   close $tmp_fh
 201     or die "$0: writing to $tmp_name: $!\n";
 202
 203   # Preserve the permissions of the original file, if it exists.
 204   if (defined $oldcontents)
 205     {
 206       my $st = stat $file;
 207       chmod (S_IMODE ($st->mode), $tmp_name)
 208         or die "$0: setting permissions on $tmp_name: $!\n";
 209     }
 210
 211   rename $tmp_name, $file
 212     or die "$0: rename($tmp_name, $file): $!\n";
 213
 214   print STDERR "$file updated\n";
 215 }
 216
 217
 218 # fetch ($path, $repo, $destdir, $edit, $quiet, $client)
 219 # Retrieve $path from repository $repo,
 220 # writing it to $destdir/$(basename $path).
 221 # If $edit is true, perform s/\bAutomake::/Autom4te::/g on the file's
 222 # contents.
 223 # If $quiet is true, don't print progress reports.
 224 # $client must be a HTTP::Tiny instance.
 225 sub fetch ($$$$$$)
 226 {
 227   my ($path, $repo, $destdir, $edit, $quiet, $client) = @_;
 228   my (undef, undef, $file) = splitpath ($path);
 229   my $destpath = catfile ($destdir, $file);
 230
 231   my $uri = savannah_url ($repo, $path);
 232   print STDERR "fetch $destpath <- $uri ...\n" unless $quiet;
 233
 234   my $resp = $client->get ($uri);
 235
 236   die "$uri: $resp->{status} $resp->{reason}\n"
 237     unless $resp->{success};
 238
 239   my $content = $resp->{content};
 240   # don't use \s here or it will eat blank lines
 241   $content =~ s/[ \t]+$//gm;
 242   $content =~ s/\bAutomake::/Autom4te::/g if $edit;
 243
 244   replace_if_change ($destpath, $content, $quiet);
 245 }
 246
 247
 248 sub main
 249 {
 250   my $quiet = 0;
 251   GetOptions ('quiet|q' => \$quiet)
 252     or die "usage: $0 [-q] destination-directory\n";
 253
 254   my $topdestdir = shift @ARGV
 255     or die "usage: $0 [-q] destination-directory\n";
 256
 257   $#ARGV == -1
 258     or die "usage: $0 [-q] destination-directory\n";
 259
 260   my $client = HTTP::Tiny->new(
 261     agent => 'autoconf-fetch.pl/1.0 ',
 262     keep_alive => 1,
 263     verify_SSL => 1
 264   );
 265
 266   my ($can_ssl, $whynot) = $client->can_ssl;
 267   die "$0: HTTPS support not available"
 268     . " (do you need to install IO::Socket::SSL?\n"
 269     . $whynot . "\n"
 270     unless $can_ssl;
 271
 272   while (my ($subdir, $groups) = each %to_fetch)
 273     {
 274       my $edit = $subdir =~ m!/Autom4te$!;
 275       my $destdir = catfile ($topdestdir, $subdir);
 276       while (my ($project, $files) = each %$groups)
 277         {
 278           fetch $_, $project, $destdir, $edit, $quiet, $client
 279             foreach @$files;
 280         }
 281       }
 282 }
 283
 284 main ();
 285
 286 ### Setup "GNU" style for perl-mode and cperl-mode.
 287 ## Local Variables:
 288 ## perl-indent-level: 2
 289 ## perl-continued-statement-offset: 2
 290 ## perl-continued-brace-offset: 0
 291 ## perl-brace-offset: 0
 292 ## perl-brace-imaginary-offset: 0
 293 ## perl-label-offset: -2
 294 ## cperl-indent-level: 2
 295 ## cperl-brace-offset: 0
 296 ## cperl-continued-brace-offset: 0
 297 ## cperl-label-offset: -2
 298 ## cperl-extra-newline-before-brace: t
 299 ## cperl-merge-trailing-else: nil
 300 ## cperl-continued-statement-offset: 2
 301 ## End: