File: | /usr/local/share/autoconf/Autom4te/General.pm |
Coverage: | 73.7% |
line | stmt | bran | cond | sub | pod | time | code |
---|---|---|---|---|---|---|---|
1 | # autoconf -- create `configure' using m4 macros | ||||||
2 | # Copyright (C) 2001, 2002, 2003, 2004, 2006, 2007, 2009, 2010 Free | ||||||
3 | # Software 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 | |||||||
18 | package Autom4te::General; | ||||||
19 | |||||||
20 - 33 | =head1 NAME Autom4te::General - general support functions for Autoconf and Automake =head1 SYNOPSIS use Autom4te::General =head1 DESCRIPTION This perl module provides various general purpose support functions used in several executables of the Autoconf and Automake packages. =cut | ||||||
34 | |||||||
35 | 2774 2774 2774 | 142543 7007 3670 | use 5.005_03; | ||||
36 | 2774 2774 2774 | 10265 4224 11467 | use Exporter; | ||||
37 | 2774 2774 2774 | 10199 2908 15709 | use Autom4te::ChannelDefs; | ||||
38 | 2774 2774 2774 | 10867 2952 15715 | use Autom4te::Channels; | ||||
39 | 2774 2774 2774 | 11865 3260 20122 | use File::Basename; | ||||
40 | 2774 2774 2774 | 11843 2939 3630 | use File::Path (); | ||||
41 | 2774 2774 2774 | 9717 2985 40747 | use File::stat; | ||||
42 | 2774 2774 2774 | 10786 3153 27687 | use IO::File; | ||||
43 | 2774 2774 2774 | 11069 3786 20170 | use Carp; | ||||
44 | 2774 2774 2774 | 10746 3008 14036 | use strict; | ||||
45 | |||||||
46 | 2774 2774 2774 | 10567 5116 12106 | use vars qw (@ISA @EXPORT); | ||||
47 | |||||||
48 | @ISA = qw (Exporter); | ||||||
49 | |||||||
50 | # Variables we define and export. | ||||||
51 | my @export_vars = | ||||||
52 | qw ($debug $force $help $me $tmp $verbose $version); | ||||||
53 | |||||||
54 | # Functions we define and export. | ||||||
55 | my @export_subs = | ||||||
56 | qw (&debug | ||||||
57 | &getopt &shell_quote &mktmpdir | ||||||
58 | &uniq); | ||||||
59 | |||||||
60 | # Functions we forward (coming from modules we use). | ||||||
61 | my @export_forward_subs = | ||||||
62 | qw (&basename &dirname &fileparse); | ||||||
63 | |||||||
64 | @EXPORT = (@export_vars, @export_subs, @export_forward_subs); | ||||||
65 | |||||||
66 | |||||||
67 | # Variable we share with the main package. Be sure to have a single | ||||||
68 | # copy of them: using `my' together with multiple inclusion of this | ||||||
69 | # package would introduce several copies. | ||||||
70 | |||||||
71 - 81 | =head2 Global Variables =over 4 =item C<$debug> Set this variable to 1 if debug messages should be enabled. Debug messages are meant for developpers only, or when tracking down an incorrect execution. =cut | ||||||
82 | |||||||
83 | 2774 2774 2774 | 15635 8618 8633 | use vars qw ($debug); | ||||
84 | $debug = 0; | ||||||
85 | |||||||
86 - 91 | =item C<$force> Set this variable to 1 to recreate all the files, or to consider all the output files are obsolete. =cut | ||||||
92 | |||||||
93 | 2774 2774 2774 | 10397 3004 6978 | use vars qw ($force); | ||||
94 | $force = undef; | ||||||
95 | |||||||
96 - 100 | =item C<$help> Set to the help message associated with the option C<--help>. =cut | ||||||
101 | |||||||
102 | 2774 2774 2774 | 10156 2971 6326 | use vars qw ($help); | ||||
103 | $help = undef; | ||||||
104 | |||||||
105 - 109 | =item C<$me> The name of this application, for diagnostic messages. =cut | ||||||
110 | |||||||
111 | 2774 2774 2774 | 10382 3062 8016 | use vars qw ($me); | ||||
112 | $me = basename ($0); | ||||||
113 | |||||||
114 - 119 | =item C<$tmp> The name of the temporary directory created by C<mktmpdir>. Left C<undef> otherwise. =cut | ||||||
120 | |||||||
121 | # Our tmp dir. | ||||||
122 | 2774 2774 2774 | 10231 3074 6360 | use vars qw ($tmp); | ||||
123 | $tmp = undef; | ||||||
124 | |||||||
125 - 130 | =item C<$verbose> Enable verbosity messages. These messages are meant for ordinary users, and typically make explicit the steps being performed. =cut | ||||||
131 | |||||||
132 | 2774 2774 2774 | 10075 2931 6578 | use vars qw ($verbose); | ||||
133 | $verbose = 0; | ||||||
134 | |||||||
135 - 139 | =item C<$version> Set to the version message associated to the option C<--version>. =cut | ||||||
140 | |||||||
141 | 2774 2774 2774 | 15010 3557 7971 | use vars qw ($version); | ||||
142 | $version = undef; | ||||||
143 | |||||||
144 | =back | ||||||
145 | |||||||
146 | =cut | ||||||
147 | |||||||
148 | |||||||
149 | |||||||
150 | ## ----- ## | ||||||
151 | ## END. ## | ||||||
152 | ## ----- ## | ||||||
153 | |||||||
154 - 163 | =head2 Functions =over 4 =item C<END> Filter Perl's exit codes, delete any temporary directory (unless C<$debug>), and exit nonzero whenever closing C<STDOUT> fails. =cut | ||||||
164 | |||||||
165 | # END | ||||||
166 | # --- | ||||||
167 | sub END | ||||||
168 | { | ||||||
169 | # $? contains the exit status we will return. | ||||||
170 | # It was set using one of the following ways: | ||||||
171 | # | ||||||
172 | # 1) normal termination | ||||||
173 | # this sets $? = 0 | ||||||
174 | # 2) calling `exit (n)' | ||||||
175 | # this sets $? = n | ||||||
176 | # 3) calling die or friends (croak, confess...): | ||||||
177 | # a) when $! is non-0 | ||||||
178 | # this set $? = $! | ||||||
179 | # b) when $! is 0 but $? is not | ||||||
180 | # this sets $? = ($? >> 8) (i.e., the exit code of the | ||||||
181 | # last program executed) | ||||||
182 | # c) when both $! and $? are 0 | ||||||
183 | # this sets $? = 255 | ||||||
184 | # | ||||||
185 | # Cases 1), 2), and 3b) are fine, but we prefer $? = 1 for 3a) and 3c). | ||||||
186 | 2774 | 21469 | my $status = $?; | ||||
187 | 2774 | 52461 | $status = 1 if ($! && $! == $?) || $? == 255; | ||||
188 | # (Note that we cannot safely distinguish calls to `exit (n)' | ||||||
189 | # from calls to die when `$! = n'. It's not big deal because | ||||||
190 | # we only call `exit (0)' or `exit (1)'.) | ||||||
191 | |||||||
192 | 2774 | 63632 | if (!$debug && defined $tmp && -d $tmp) | ||||
193 | { | ||||||
194 | 2773 0 0 | 45572 0 0 | local $SIG{__WARN__} = sub { $status = 1; warn $_[0] }; | ||||
195 | 2773 | 25194 | File::Path::rmtree $tmp; | ||||
196 | } | ||||||
197 | |||||||
198 | # This is required if the code might send any output to stdout | ||||||
199 | # E.g., even --version or --help. So it's best to do it unconditionally. | ||||||
200 | 2774 | 2717707 | if (! close STDOUT) | ||||
201 | { | ||||||
202 | 0 | 0 | print STDERR "$me: closing standard output: $!\n"; | ||||
203 | 0 | 0 | $? = 1; | ||||
204 | 0 | 0 | return; | ||||
205 | } | ||||||
206 | |||||||
207 | 2774 | 10386 | $? = $status; | ||||
208 | } | ||||||
209 | |||||||
210 | |||||||
211 | ## ----------- ## | ||||||
212 | ## Functions. ## | ||||||
213 | ## ----------- ## | ||||||
214 | |||||||
215 | |||||||
216 - 221 | =item C<debug (@message)> If the debug mode is enabled (C<$debug> and C<$verbose>), report the C<@message> on C<STDERR>, signed with the name of the program. =cut | ||||||
222 | |||||||
223 | # &debug(@MESSAGE) | ||||||
224 | # ---------------- | ||||||
225 | # Messages displayed only if $DEBUG and $VERBOSE. | ||||||
226 | sub debug (@) | ||||||
227 | { | ||||||
228 | 14 | 1 | 217 | print STDERR "$me: ", @_, "\n" | |||
229 | if $verbose && $debug; | ||||||
230 | } | ||||||
231 | |||||||
232 | |||||||
233 - 242 | =item C<getopt (%option)> Wrapper around C<Getopt::Long>. In addition to the user C<option>s, support C<-h>/C<--help>, C<-V>/C<--version>, C<-v>/C<--verbose>, C<-d>/C<--debug>, C<-f>/C<--force>. Conform to the GNU Coding Standards for error messages. Try to work around a weird behavior from C<Getopt::Long> to preserve C<-> as an C<@ARGV> instead of rejecting it as a broken option. =cut | ||||||
243 | |||||||
244 | # getopt (%OPTION) | ||||||
245 | # ---------------- | ||||||
246 | # Handle the %OPTION, plus all the common options. | ||||||
247 | # Work around Getopt bugs wrt `-'. | ||||||
248 | sub getopt (%) | ||||||
249 | { | ||||||
250 | 2774 | 1 | 27734 | my (%option) = @_; | |||
251 | 2774 2774 2774 | 20904 4120 11554 | use Getopt::Long; | ||||
252 | |||||||
253 | # F*k. Getopt seems bogus and dies when given `-' with `bundling'. | ||||||
254 | # If fixed some day, use this: '' => sub { push @ARGV, "-" } | ||||||
255 | 2774 | 93684 | my $stdin = grep /^-$/, @ARGV; | ||||
256 | 2774 | 242300 | @ARGV = grep !/^-$/, @ARGV; | ||||
257 | 0 0 | 0 0 | %option = ("h|help" => sub { print $help; exit 0 }, | ||||
258 | 1 1 | 1104 1 | "V|version" => sub { print $version; exit 0 }, | ||||
259 | |||||||
260 | 0 | 0 | "v|verbose" => sub { ++$verbose }, | ||||
261 | 0 | 0 | "d|debug" => sub { ++$debug }, | ||||
262 | 2774 | 92307 | 'f|force' => \$force, | ||||
263 | |||||||
264 | # User options last, so that they have precedence. | ||||||
265 | %option); | ||||||
266 | 2774 | 14354 | Getopt::Long::Configure ("bundling", "pass_through"); | ||||
267 | 2774 | 217472 | GetOptions (%option) | ||||
268 | or exit 1; | ||||||
269 | |||||||
270 | 2773 34512 | 39913514 56818 | foreach (grep { /^-./ } @ARGV) | ||||
271 | { | ||||||
272 | 0 | 0 | print STDERR "$0: unrecognized option `$_'\n"; | ||||
273 | 0 | 0 | print STDERR "Try `$0 --help' for more information.\n"; | ||||
274 | 0 | 0 | exit (1); | ||||
275 | } | ||||||
276 | |||||||
277 | 2773 | 10347 | push @ARGV, '-' | ||||
278 | if $stdin; | ||||||
279 | |||||||
280 | 2773 | 11019 | setup_channel 'note', silent => !$verbose; | ||||
281 | 2773 | 9799 | setup_channel 'verb', silent => !$verbose; | ||||
282 | } | ||||||
283 | |||||||
284 | |||||||
285 - 289 | =item C<shell_quote ($file_name)> Quote C<$file_name> for the shell. =cut | ||||||
290 | |||||||
291 | # $FILE_NAME | ||||||
292 | # shell_quote ($FILE_NAME) | ||||||
293 | # ------------------------ | ||||||
294 | # If the string $S is a well-behaved file name, simply return it. | ||||||
295 | # If it contains white space, quotes, etc., quote it, and return | ||||||
296 | # the new string. | ||||||
297 | sub shell_quote($) | ||||||
298 | { | ||||||
299 | 139925 | 1 | 210827 | my ($s) = @_; | |||
300 | 139925 | 344474 | if ($s =~ m![^\w+/.,-]!) | ||||
301 | { | ||||||
302 | # Convert each single quote to '\'' | ||||||
303 | 54 | 125 | $s =~ s/\'/\'\\\'\'/g; | ||||
304 | # Then single quote the string. | ||||||
305 | 54 | 146 | $s = "'$s'"; | ||||
306 | } | ||||||
307 | 139925 | 408343 | return $s; | ||||
308 | } | ||||||
309 | |||||||
310 - 316 | =item C<mktmpdir ($signature)> Create a temporary directory which name is based on C<$signature>. Store its name in C<$tmp>. C<END> is in charge of removing it, unless C<$debug>. =cut | ||||||
317 | |||||||
318 | # mktmpdir ($SIGNATURE) | ||||||
319 | # --------------------- | ||||||
320 | sub mktmpdir ($) | ||||||
321 | { | ||||||
322 | 2773 | 1 | 9944 | my ($signature) = @_; | |||
323 | 2773 | 47638 | my $TMPDIR = $ENV{'TMPDIR'} || '/tmp'; | ||||
324 | 2773 | 14927 | my $quoted_tmpdir = shell_quote ($TMPDIR); | ||||
325 | |||||||
326 | # If mktemp supports dirs, use it. | ||||||
327 | 2773 | 7785263 | $tmp = `(umask 077 && | ||||
328 | mktemp -d $quoted_tmpdir/"${signature}XXXXXX") 2>/dev/null`; | ||||||
329 | 2773 | 24872 | chomp $tmp; | ||||
330 | |||||||
331 | 2773 | 100420 | if (!$tmp || ! -d $tmp) | ||||
332 | { | ||||||
333 | 0 | 0 | $tmp = "$TMPDIR/$signature" . int (rand 10000) . ".$$"; | ||||
334 | 0 | 0 | mkdir $tmp, 0700 | ||||
335 | or croak "$me: cannot create $tmp: $!\n"; | ||||||
336 | } | ||||||
337 | |||||||
338 | 2773 | 47021 | print STDERR "$me:$$: working in $tmp\n" | ||||
339 | if $debug; | ||||||
340 | } | ||||||
341 | |||||||
342 | |||||||
343 - 348 | =item C<uniq (@list)> Return C<@list> with no duplicates, keeping only the first occurrences. =cut | ||||||
349 | |||||||
350 | # @RES | ||||||
351 | # uniq (@LIST) | ||||||
352 | # ------------ | ||||||
353 | sub uniq (@) | ||||||
354 | { | ||||||
355 | 2758 | 1 | 6589 | my @res = (); | |||
356 | 2758 | 5507 | my %seen = (); | ||||
357 | 2758 | 9767 | foreach my $item (@_) | ||||
358 | { | ||||||
359 | 8276 | 24650 | if (! exists $seen{$item}) | ||||
360 | { | ||||||
361 | 2758 | 7225 | $seen{$item} = 1; | ||||
362 | 2758 | 6928 | push (@res, $item); | ||||
363 | } | ||||||
364 | } | ||||||
365 | 2758 | 15308 | return wantarray ? @res : "@res"; | ||||
366 | } | ||||||
367 | |||||||
368 | |||||||
369 - 374 | =item C<handle_exec_errors ($command)> Display an error message for C<$command>, based on the content of C<$?> and C<$!>. =cut | ||||||
375 | |||||||
376 | |||||||
377 | # handle_exec_errors ($COMMAND) | ||||||
378 | # ----------------------------- | ||||||
379 | sub handle_exec_errors ($) | ||||||
380 | { | ||||||
381 | 0 | 1 | my ($command) = @_; | ||||
382 | |||||||
383 | 0 | $command = (split (' ', $command))[0]; | |||||
384 | 0 | if ($!) | |||||
385 | { | ||||||
386 | 0 | error "failed to run $command: $!"; | |||||
387 | } | ||||||
388 | else | ||||||
389 | { | ||||||
390 | 2774 2774 2774 | 13492 3452 17258 | use POSIX qw (WIFEXITED WEXITSTATUS WIFSIGNALED WTERMSIG); | ||||
391 | |||||||
392 | 0 | if (WIFEXITED ($?)) | |||||
393 | { | ||||||
394 | 0 | my $status = WEXITSTATUS ($?); | |||||
395 | # WIFEXITED and WEXITSTATUS can alter $!, reset it so that | ||||||
396 | # error() actually propagates the command's exit status, not $!. | ||||||
397 | 0 | $! = 0; | |||||
398 | 0 | error "$command failed with exit status: $status"; | |||||
399 | } | ||||||
400 | elsif (WIFSIGNALED ($?)) | ||||||
401 | { | ||||||
402 | 0 | my $signal = WTERMSIG ($?); | |||||
403 | # In this case we prefer to exit with status 1. | ||||||
404 | 0 | $! = 1; | |||||
405 | 0 | error "$command terminated by signal: $signal"; | |||||
406 | } | ||||||
407 | else | ||||||
408 | { | ||||||
409 | 0 | error "$command exited abnormally"; | |||||
410 | } | ||||||
411 | } | ||||||
412 | } | ||||||
413 | |||||||
414 | =back | ||||||
415 | |||||||
416 - 425 | =head1 SEE ALSO L<Autom4te::XFile> =head1 HISTORY Written by Alexandre Duret-Lutz E<lt>F<adl@gnu.org>E<gt> and Akim Demaille E<lt>F<akim@freefriends.org>E<gt>. =cut | ||||||
426 | |||||||
427 | |||||||
428 | |||||||
429 | 1; # for require | ||||||
430 | |||||||
431 | ### Setup "GNU" style for perl-mode and cperl-mode. | ||||||
432 | ## Local Variables: | ||||||
433 | ## perl-indent-level: 2 | ||||||
434 | ## perl-continued-statement-offset: 2 | ||||||
435 | ## perl-continued-brace-offset: 0 | ||||||
436 | ## perl-brace-offset: 0 | ||||||
437 | ## perl-brace-imaginary-offset: 0 | ||||||
438 | ## perl-label-offset: -2 | ||||||
439 | ## cperl-indent-level: 2 | ||||||
440 | ## cperl-brace-offset: 0 | ||||||
441 | ## cperl-continued-brace-offset: 0 | ||||||
442 | ## cperl-label-offset: -2 | ||||||
443 | ## cperl-extra-newline-before-brace: t | ||||||
444 | ## cperl-merge-trailing-else: nil | ||||||
445 | ## cperl-continued-statement-offset: 2 | ||||||
446 | ## End: |