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