lib/Autom4te/General.pm

   1 # autoconf -- create 'configure' using m4 macros
   2 # Copyright (C) 2001-2004, 2006-2007, 2009-2017, 2020-2024 Free Software
   3 # Foundation, Inc.
   4
   5 # This program is free software: you can redistribute it and/or modify
   6 # it under the terms of the GNU General Public License as published by
   7 # the Free Software Foundation, either version 3 of the License, or
   8 # (at your option) any later version.
   9
  10 # This program is distributed in the hope that it will be useful,
  11 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13 # GNU General Public License for more details.
  14
  15 # You should have received a copy of the GNU General Public License
  16 # along with this program.  If not, see <https://www.gnu.org/licenses/>.
  17
  18 package Autom4te::General;
  19
  20 =head1 NAME
  21
  22 Autom4te::General - general support functions for Autoconf
  23
  24 =head1 SYNOPSIS
  25
  26   use Autom4te::General
  27
  28 =head1 DESCRIPTION
  29
  30 This perl module provides various general purpose support functions
  31 used in several executables of the Autoconf package.
  32
  33 =cut
  34
  35 use 5.006;
  36 use strict;
  37 use warnings FATAL => 'all';
  38
  39 use Carp;
  40 use Exporter;
  41 use File::Basename;
  42 use File::Spec ();
  43 use File::stat;
  44 use File::Temp ();
  45 use IO::File;
  46
  47 use Autom4te::ChannelDefs;
  48 use Autom4te::Channels;
  49 use Autom4te::Getopt ();
  50
  51 our @ISA = qw (Exporter);
  52
  53 # Variables we define and export.
  54 my @export_vars =
  55   qw ($debug $force $help $me $tmp $verbose $version);
  56
  57 # Functions we define and export.
  58 my @export_subs =
  59   qw (&debug
  60       &getopt &shell_quote &mktmpdir
  61       &uniq);
  62
  63 # Functions we forward (coming from modules we use).
  64 my @export_forward_subs =
  65   qw (&basename &dirname &fileparse);
  66
  67 our @EXPORT = (@export_vars, @export_subs, @export_forward_subs);
  68
  69
  70 # Variable we share with the main package.  Be sure to have a single
  71 # copy of them: using 'my' together with multiple inclusion of this
  72 # package would introduce several copies.
  73
  74 =head2 Global Variables
  75
  76 =over 4
  77
  78 =item C<$debug>
  79
  80 Set this variable to 1 if debug messages should be enabled.  Debug
  81 messages are meant for developers only, or when tracking down an
  82 incorrect execution.
  83
  84 =cut
  85
  86 our $debug = 0;
  87
  88 =item C<$force>
  89
  90 Set this variable to 1 to recreate all the files, or to consider all
  91 the output files are obsolete.
  92
  93 =cut
  94
  95 our $force = undef;
  96
  97 =item C<$help>
  98
  99 Set to the help message associated with the option C<--help>.
 100
 101 =cut
 102
 103 our $help = undef;
 104
 105 =item C<$me>
 106
 107 The name of this application, for diagnostic messages.
 108
 109 =cut
 110
 111 our $me = basename ($0);
 112
 113 =item C<$tmp>
 114
 115 The name of the temporary directory created by C<mktmpdir>.  Left
 116 C<undef> otherwise.
 117
 118 =cut
 119
 120 # Our tmp dir.
 121 our $tmp = undef;
 122
 123 =item C<$verbose>
 124
 125 Enable verbosity messages.  These messages are meant for ordinary
 126 users, and typically make explicit the steps being performed.
 127
 128 =cut
 129
 130 our $verbose = 0;
 131
 132 =item C<$version>
 133
 134 Set to the version message associated to the option C<--version>.
 135
 136 =cut
 137
 138 our $version = undef;
 139
 140 =back
 141
 142 =cut
 143
 144
 145
 146 ## ----- ##
 147 ## END.  ##
 148 ## ----- ##
 149
 150 =head2 Functions
 151
 152 =over 4
 153
 154 =item C<END>
 155
 156 Filter Perl's exit codes and exit nonzero whenever closing C<STDOUT> fails.
 157
 158 =cut
 159
 160 # END
 161 # ---
 162 sub END
 163 {
 164   # $? contains the exit status we will return.
 165   # It was set using one of the following ways:
 166   #
 167   #  1) normal termination
 168   #     this sets $? = 0
 169   #  2) calling 'exit (n)'
 170   #     this sets $? = n
 171   #  3) calling die or friends (croak, confess...):
 172   #     a) when $! is non-0
 173   #        this set $? = $!
 174   #     b) when $! is 0 but $? is not
 175   #        this sets $? = ($? >> 8)   (i.e., the exit code of the
 176   #        last program executed)
 177   #     c) when both $! and $? are 0
 178   #        this sets $? = 255
 179   #
 180   # Cases 1), 2), and 3b) are fine, but we prefer $? = 1 for 3a) and 3c).
 181   my $status = $?;
 182   $status = 1 if ($! && $! == $?) || $? == 255;
 183   # (Note that we cannot safely distinguish calls to 'exit (n)'
 184   # from calls to die when '$! = n'.  It's not big deal because
 185   # we only call 'exit (0)' or 'exit (1)'.)
 186
 187   # This is required if the code might send any output to stdout
 188   # E.g., even --version or --help.  So it's best to do it unconditionally.
 189   if (! close STDOUT)
 190     {
 191       print STDERR "$me: closing standard output: $!\n";
 192       $? = 1;
 193       return;
 194     }
 195
 196   $? = $status;
 197 }
 198
 199
 200 ## ----------- ##
 201 ## Functions.  ##
 202 ## ----------- ##
 203
 204
 205 =item C<debug (@message)>
 206
 207 If the debug mode is enabled (C<$debug> and C<$verbose>), report the
 208 C<@message> on C<STDERR>, signed with the name of the program.
 209
 210 =cut
 211
 212 # &debug(@MESSAGE)
 213 # ----------------
 214 # Messages displayed only if $DEBUG and $VERBOSE.
 215 sub debug (@)
 216 {
 217   print STDERR "$me: ", @_, "\n"
 218     if $verbose && $debug;
 219 }
 220
 221
 222 =item C<getopt (%option)>
 223
 224 Wrapper around C<Autom4te::Getopt::parse_options>.  In addition to
 225 the user C<option>s, support C<-h>/C<--help>, C<-V>/C<--version>,
 226 C<-v>/C<--verbose>, C<-d>/C<--debug>, C<-f>/C<--force>.  Conform to
 227 the GNU Coding Standards for error messages.
 228
 229 =cut
 230
 231 # getopt (%OPTION)
 232 # ----------------
 233 # Handle the %OPTION, plus all the common options.
 234 sub getopt (%)
 235 {
 236   my (%option) = @_;
 237   %option = ("h|help"     => sub { print $help; exit 0 },
 238              "V|version"  => sub { print $version; exit 0 },
 239
 240              "v|verbose"  => sub { ++$verbose },
 241              "d|debug"    => sub { ++$debug },
 242              'f|force'    => \$force,
 243
 244              # User options last, so that they have precedence.
 245              %option);
 246   Autom4te::Getopt::parse_options (%option);
 247
 248   setup_channel 'note', silent => !$verbose;
 249   setup_channel 'verb', silent => !$verbose;
 250 }
 251
 252
 253 =item C<shell_quote ($file_name)>
 254
 255 Quote C<$file_name> for the shell.
 256
 257 =cut
 258
 259 # $FILE_NAME
 260 # shell_quote ($FILE_NAME)
 261 # ------------------------
 262 # If the string $S is a well-behaved file name, simply return it.
 263 # If it contains white space, quotes, etc., quote it, and return
 264 # the new string.
 265 sub shell_quote($)
 266 {
 267   my ($s) = @_;
 268   if ($s =~ m![^\w+/.,-]!)
 269     {
 270       # Convert each single quote to '\''
 271       $s =~ s/\'/\'\\\'\'/g;
 272       # Then single quote the string.
 273       $s = "'$s'";
 274     }
 275   return $s;
 276 }
 277
 278 =item C<mktmpdir ($signature)>
 279
 280 Create a temporary directory which name is based on C<$signature>.
 281 Store its name in C<$tmp>.  It will be removed at program exit,
 282 unless C<$debug> is true.
 283
 284 =cut
 285
 286 # mktmpdir ($SIGNATURE)
 287 # ---------------------
 288 sub mktmpdir ($)
 289 {
 290   my ($signature) = @_;
 291
 292   # Ensure that we refer to the temporary directory by absolute
 293   # pathname; most importantly, this ensures that C<do FILE> will
 294   # work whenever FILE is in $tmp, even when '.' is not in @INC
 295   # (perl 5.26 and later).
 296   my $TMPDIR = File::Spec->rel2abs (File::Spec->tmpdir ());
 297   $tmp = File::Temp::tempdir (
 298     $signature . "XXXXXX",
 299     DIR => $TMPDIR,
 300     CLEANUP => !$debug
 301   );
 302
 303   print STDERR "$me:$$: working in $tmp\n"
 304     if $debug;
 305
 306   return $tmp;
 307 }
 308
 309
 310 =item C<uniq (@list)>
 311
 312 Return C<@list> with no duplicates, keeping only the first
 313 occurrences.
 314
 315 =cut
 316
 317 # @RES
 318 # uniq (@LIST)
 319 # ------------
 320 sub uniq (@)
 321 {
 322   my @res = ();
 323   my %seen = ();
 324   foreach my $item (@_)
 325     {
 326       if (! exists $seen{$item})
 327         {
 328           $seen{$item} = 1;
 329           push (@res, $item);
 330         }
 331     }
 332   return wantarray ? @res : "@res";
 333 }
 334
 335
 336 =item C<handle_exec_errors ($command)>
 337
 338 Display an error message for C<$command>, based on the content of
 339 C<$?> and C<$!>.
 340
 341 =cut
 342
 343
 344 # handle_exec_errors ($COMMAND)
 345 # -----------------------------
 346 sub handle_exec_errors ($)
 347 {
 348   my ($command) = @_;
 349
 350   $command = (split (' ', $command))[0];
 351   if ($!)
 352     {
 353       error "failed to run $command: $!";
 354     }
 355   else
 356     {
 357       use POSIX qw (WIFEXITED WEXITSTATUS WIFSIGNALED WTERMSIG);
 358
 359       if (WIFEXITED ($?))
 360         {
 361           my $status = WEXITSTATUS ($?);
 362           # WIFEXITED and WEXITSTATUS can alter $!, reset it so that
 363           # error() actually propagates the command's exit status, not $!.
 364           $! = 0;
 365           error "$command failed with exit status: $status";
 366         }
 367       elsif (WIFSIGNALED ($?))
 368         {
 369           my $signal = WTERMSIG ($?);
 370           # In this case we prefer to exit with status 1.
 371           $! = 1;
 372           error "$command terminated by signal: $signal";
 373         }
 374       else
 375         {
 376           error "$command exited abnormally";
 377         }
 378     }
 379 }
 380
 381 =back
 382
 383 =head1 SEE ALSO
 384
 385 L<Autom4te::XFile>
 386
 387 =head1 HISTORY
 388
 389 Written by Alexandre Duret-Lutz E<lt>F<adl@gnu.org>E<gt> and Akim
 390 Demaille E<lt>F<akim@freefriends.org>E<gt>.
 391
 392 =cut
 393
 394
 395
 396 1; # for require
 397
 398 ### Setup "GNU" style for perl-mode and cperl-mode.
 399 ## Local Variables:
 400 ## perl-indent-level: 2
 401 ## perl-continued-statement-offset: 2
 402 ## perl-continued-brace-offset: 0
 403 ## perl-brace-offset: 0
 404 ## perl-brace-imaginary-offset: 0
 405 ## perl-label-offset: -2
 406 ## cperl-indent-level: 2
 407 ## cperl-brace-offset: 0
 408 ## cperl-continued-brace-offset: 0
 409 ## cperl-label-offset: -2
 410 ## cperl-extra-newline-before-brace: t
 411 ## cperl-merge-trailing-else: nil
 412 ## cperl-continued-statement-offset: 2
 413 ## End: