File Coverage

File:lib/Parrot/Configure/Utils.pm
Coverage:94.5%

linestmtbrancondsubcode
1# Copyright (C) 2001-2008, Parrot Foundation.
2
3 - 21
=head1 NAME

Parrot::Configure::Utils - Configuration Step Utilities

=head1 DESCRIPTION

The C<Parrot::Configure::Utils> module contains utility functions for use by
the configuration step classes found under F<config/>.

The subroutines found in this module do B<not> require the Parrot::Configure
object as an argument.  Those subroutines formerly found in this module which
B<do> require the Parrot::Configure object as an argument have been moved into
Parrot::Configure::Compiler.

=head2 Functions

=over 4

=cut
22
23package Parrot::Configure::Utils;
24
25
103
103
103
103
use strict;
26
103
103
103
103
use warnings;
27
28
103
103
103
103
use base qw( Exporter );
29
30
103
103
103
103
use Carp;
31
103
103
103
103
use File::Copy ();
32
103
103
103
103
use File::Spec;
33
103
103
103
103
use File::Which;
34
103
103
103
103
use lib ("lib");
35
103
103
103
103
use Parrot::BuildUtil ();
36our @EXPORT = ();
37our @EXPORT_OK = qw(
38    prompt copy_if_diff move_if_diff integrate
39    capture_output check_progs _slurp
40    _run_command _build_compile_command
41    print_to_cache read_from_cache
42);
43our %EXPORT_TAGS = (
44    inter => [qw(prompt integrate)],
45    auto => [
46        qw(capture_output check_progs)
47    ],
48    gen => [qw( copy_if_diff move_if_diff )],
49    cache => [qw( print_to_cache read_from_cache ) ],
50);
51
52 - 57
=item C<_run_command($command, $out, $err)>

Runs the specified command. Output is directed to the file specified by
C<$out>, warnings and errors are directed to the file specified by C<$err>.

=cut
58
59sub _run_command {
60
465
465
    my ( $command, $out, $err, $verbose ) = @_;
61
62
465
100
    if ($verbose) {
63
45
        print "$command\n";
64    }
65
66    # Mostly copied from Parrot::Test.pm
67
465
    foreach ( $out, $err ) {
68
930
100
100
        $_ = File::Spec->devnull
69            if $_ and $_ eq '/dev/null';
70    }
71
72
465
100
100
    if ( $out and $err and $out eq $err ) {
73
371
        $err = "&STDOUT";
74    }
75
76    # Save the old filehandles; we must not let them get closed.
77
465
100
50
    open my $OLDOUT, '>&', \*STDOUT or die "Can't save stdout" if $out;
78
465
100
50
    open my $OLDERR, '>&', \*STDERR or die "Can't save stderr" if $err;
79
80
465
100
50
    open STDOUT, '>', $out or die "Can't redirect stdout" if $out;
81
82    # See 'Obscure Open Tricks' in perlopentut
83
465
100
50
    open STDERR, ">$err" ## no critic InputOutput::ProhibitTwoArgOpen
84        or die "Can't redirect stderr"
85        if $err;
86
87
465
    system $command;
88
465
    my $exit_code = $? >> 8;
89
90
465
100
50
    close STDOUT or die "Can't close stdout" if $out;
91
465
100
50
    close STDERR or die "Can't close stderr" if $err;
92
93
465
100
50
    open STDOUT, '>&', $OLDOUT or die "Can't restore stdout" if $out;
94
465
100
50
    open STDERR, '>&', $OLDERR or die "Can't restore stderr" if $err;
95
96
465
100
    if ($verbose) {
97
45
        foreach ( $out, $err ) {
98
90
100
100
            if ( ( defined($_) )
99                && ( $_ ne File::Spec->devnull )
100                && ( !m/^&/ ) )
101            {
102
46
                open( my $verbose_handle, '<', $_ );
103
46
                print <$verbose_handle>;
104
46
                close $verbose_handle;
105            }
106        }
107    }
108
109
465
    return $exit_code;
110}
111
112 - 116
=item C<_build_compile_command( $cc, $ccflags, $cc_args )>

Constructs a command-line to do the compile.

=cut
117
118sub _build_compile_command {
119
271
271
    my ( $cc, $ccflags, $cc_args ) = @_;
120
271
100
    $_ ||= '' for ( $cc, $ccflags, $cc_args );
121
122
271
    return "$cc $ccflags $cc_args -I./include -c test_$$.c";
123}
124
125 - 129
=item C<integrate($orig, $new)>

Integrates C<$new> into C<$orig>.  Returns C<$orig> if C<$new> is undefined.

=cut
130
131sub integrate {
132
127
127
    my ( $orig, $new ) = @_;
133
134    # Rather than sprinkling "if defined(...)", everywhere,
135    # various inter::* steps (coded in config/inter/*.pm) permit simply
136    # passing in potentially undefined strings.
137    # In these instances, we simply pass back the original string without
138    # generating a warning.
139
127
100
    return $orig unless defined $new;
140
141
63
100
    if ( $new =~ /\S/ ) {
142
60
        $orig = $new;
143    }
144
145
63
    return $orig;
146}
147
148 - 153
=item C<prompt($message, $value)>

Prints out "message [default] " and waits for the user's response. Returns the
response, or the default if the user just hit C<ENTER>.

=cut
154
155sub prompt {
156
55
55
    my ( $message, $value ) = @_;
157
158
55
    print("$message [$value] ");
159
160
55
    chomp( my $input = <STDIN> );
161
162
55
100
    if ($input) {
163
53
        $value = $input;
164    }
165
166
55
    return integrate( $value, $input );
167}
168
169 - 176
=item C<file_checksum($filename, $ignore_pattern)>

Creates a checksum for the specified file. This is used to compare files.

Any lines matching the regular expression specified by C<$ignore_pattern> are
not included in the checksum.

=cut
177
178sub file_checksum {
179
62
62
    my ( $filename, $ignore_pattern ) = @_;
180
62
100
    open( my $file, '<', $filename ) or die "Can't open $filename: $!";
181
61
    my $sum = 0;
182
61
    while (<$file>) {
183
46454
100
100
        next if defined($ignore_pattern) && /$ignore_pattern/;
184
46451
        $sum += unpack( "%32C*", $_ );
185    }
186
61
50
    close($file) or die "Can't close $filename: $!";
187
61
    return $sum;
188}
189
190 - 198
=item C<copy_if_diff($from, $to, $ignore_pattern)>

Copies the file specified by C<$from> to the location specified by C<$to> if
its contents have changed.

The regular expression specified by C<$ignore_pattern> is passed to
C<file_checksum()> when comparing the files.

=cut
199
200sub copy_if_diff {
201
304
304
    my ( $from, $to, $ignore_pattern ) = @_;
202
203    # Don't touch the file if it didn't change (avoid unnecessary rebuilds)
204
304
100
    if ( -r $to ) {
205
29
        my $from_sum = file_checksum( $from, $ignore_pattern );
206
29
        my $to_sum = file_checksum( $to, $ignore_pattern );
207
29
100
        return if $from_sum == $to_sum;
208    }
209
210
286
    File::Copy::copy( $from, $to );
211
212    # Make sure the timestamp is updated
213
286
    my $now = time;
214
286
    utime $now, $now, $to;
215
216
286
    return 1;
217}
218
219 - 224
=item C<move_if_diff($from, $to, $ignore_pattern)>

Moves the file specified by C<$from> to the location specified by C<$to> if
its contents have changed.

=cut
225
226sub move_if_diff { ## no critic Subroutines::RequireFinalReturn
227
302
302
    my ( $from, $to, $ignore_pattern ) = @_;
228
302
    copy_if_diff( $from, $to, $ignore_pattern );
229
302
    unlink $from;
230}
231
232 - 238
=item C<capture_output($command)>

Executes the given command. The command's output (both stdout and stderr), and
its return status is returned as a 3-tuple. B<STDERR> is redirected to
F<test.err> during the execution, and deleted after the command's run.

=cut
239
240sub capture_output {
241
33
33
    my $command = join ' ', @_;
242
243    # disable STDERR
244
33
    open my $OLDERR, '>&', \*STDERR;
245
33
    open STDERR, '>', "test_$$.err";
246
247
33
    my $output = `$command`;
248
33
100
    my $retval = ( $? == -1 ) ? -1 : ( $? >> 8 );
249
250    # reenable STDERR
251
33
    close STDERR;
252
33
    open STDERR, '>&', $OLDERR;
253
254    # slurp stderr
255
33
    my $out_err = _slurp("./test_$$.err");
256
257    # cleanup
258
33
    unlink "test_$$.err";
259
260
33
100
    return ( $output, $out_err, $retval ) if wantarray;
261
21
    return $output;
262}
263
264 - 273
=item C<check_progs([$programs])>

Where C<$programs> may be either a scalar with the name of a single program or
an array ref of programs to search the current C<PATH> for.  The first matching
program name is returned or C<undef> on failure.  Note: this function only
returns the name of the program and not its complete path.

This function is similar to C<autoconf>'s C<AC_CHECK_PROGS> macro.

=cut
274
275sub check_progs {
276
19
19
    my ( $progs, $verbose ) = @_;
277
278
19
100
    $progs = [$progs] unless ref $progs eq 'ARRAY';
279
280
19
100
    print "checking for program: ", join( " or ", @$progs ), "\n" if $verbose;
281
19
    foreach my $prog (@$progs) {
282
31
        my $util = $prog;
283
284        # use the first word in the string to ignore any options
285
31
        ($util) = $util =~ /(\S+)/;
286
31
        my $path = which($util);
287
288
31
100
        if ($verbose) {
289
6
100
            print "$path is executable\n" if $path;
290        }
291
292
31
100
        return $prog if $path;
293    }
294
295
6
    return;
296}
297
298 - 305
=item C<print_to_cache( $cachefile, $value )>

Opens a handle to write to the file specified in the first argument. Prints
the value specified in the second argument, followed by a newline.  Typically,
this will be a hidden file in the user's top-level parrot directory.
Implicitly returns true value upon success; C<die>s otherwise.

=cut
306
307sub print_to_cache {
308
1
1
    my ($cache, $value) = @_;
309
1
50
    open my $FH, ">", $cache
310        or die "Unable to open handle to $cache for writing: $!";
311
1
1
    print {$FH} "$value\n";
312
1
50
    close $FH or die "Unable to close handle to $cache after writing: $!";
313}
314
315 - 321
=item C<read_from_cache( $cachefile )>

Opens a handle to read from the file specified in the first argument. This is
assumed to be a file consisting of a single string, optionally terminated with
a newline.  The string is returned.

=cut
322
323sub read_from_cache {
324
5
5
    my ($cache) = @_;
325
5
    my $value;
326
5
50
    open my $FH, '<', $cache
327        or die "Unable to open $cache for reading: $!";
328
5
    chomp($value = <$FH>);
329
5
50
    close $FH or die "Unable to close $cache after reading: $!";
330
5
    return $value;
331}
332
333 - 338
=item C<_slurp($filename)>

Slurps C<$filename> into memory and returns it as a string.  This is just an
alias for C<Parrot::BuildUtil::slurp_file>.

=cut
339
340*_slurp = \&Parrot::BuildUtil::slurp_file;
341
342=back
343
344=cut
345
346 - 358
=head1 SEE ALSO

=over 4

=item C<Parrot::Configure::runsteps()>

=item F<docs/configuration.pod>

=item F<lib/Parrot/Configure/Compiler.pm>

=back

=cut
359
3601;
361
362# Local Variables:
363# mode: cperl
364# cperl-indent-level: 4
365# fill-column: 100
366# End:
367# vim: expandtab shiftwidth=4: