1#!perl 2# Copyright (C) 2001-2011, Parrot Foundation. 3 4use strict; 5use warnings; 6 7use Test::More tests => 34; 8use Carp; 9use Cwd; 10use File::Basename qw(basename dirname); 11use File::Temp 0.13 qw/ tempfile /; 12use File::Spec; 13use lib qw( lib t/configure/testlib ); 14use Tie::Filehandle::Preempt::Stdin; 15use Parrot::Configure::Utils qw(_slurp capture); 16 17BEGIN { use Parrot::Configure::Utils; } 18 19Parrot::Configure::Utils->import(@Parrot::Configure::Utils::EXPORT_OK); 20can_ok( __PACKAGE__, @Parrot::Configure::Utils::EXPORT_OK ); 21 22my $cwd = cwd(); 23my ( @prompts, $object, $cc, $nonexistent, $command ); 24 25# integrate() 26 27is( integrate( undef, undef ), undef, "integrate(undef, undef)" ); 28is( integrate( undef, 1 ), 1, "integrate(undef, 1)" ); 29is( integrate( 1, undef ), 1, "integrate(1, undef)" ); 30is( integrate( 1, 2 ), 2, "integrate(1, 1)" ); 31is( integrate( 1, q{ } ), 1, 'integrate(1, [empty string])' ); 32 33# prompt() 34# Tests in t/configure/1??-inter-*.t do a good job of testing prompt(). 35# They leave only one condition to be tested here. 36 37@prompts = (q{}); 38$object = tie *STDIN, 'Tie::Filehandle::Preempt::Stdin', @prompts; 39can_ok( 'Tie::Filehandle::Preempt::Stdin', ('READLINE') ); 40isa_ok( $object, 'Tie::Filehandle::Preempt::Stdin' ); 41$cc = q{gcc-3.3}; 42{ 43 my ($rv, $stdout) = 44 capture ( sub { prompt( "What C compiler do you want to use?", $cc ) } ); 45 ok( $stdout, "prompts were captured" ); 46 is( $rv, $cc, "Empty response to prompt led to expected return value" ); 47} 48$object = undef; 49untie *STDIN; 50 51# file_checksum(), not exported 52 53$nonexistent = $$; 54eval { my $sum = Parrot::Configure::Utils::file_checksum($nonexistent); }; 55like( 56 $@, qr/Can't open $nonexistent/, #' 57 "Got expected error message when trying to get checksum on non-existent file" 58); 59 60{ 61 my ( $tmpfile, $fname ) = tempfile( UNLINK => 1 ); 62 print $tmpfile "foo" x 1000; 63 $tmpfile->flush; 64 is( Parrot::Configure::Utils::file_checksum($fname), 65 '324000', "file_checksum() returns correct checksum" ); 66} 67 68{ 69 my ( $tmpfile, $fname ) = tempfile( UNLINK => 1 ); 70 my $str = 'Do not print this line'; 71 print $tmpfile "foo" x 500; 72 print $tmpfile "\n"; 73 print $tmpfile "$str\n"; 74 print $tmpfile "foo" x 500; 75 $tmpfile->flush; 76 my $ignore_pattern = qr/$str/; 77 my $csum = Parrot::Configure::Utils::file_checksum( $fname, $ignore_pattern ); 78 is( $csum, '324010', "file_checksum() returns correct checksum" ); 79} 80 81# copy_if_diff() 82 83{ 84 my ( $fromfile, $fromfname ) = tempfile( UNLINK => 1 ); 85 my ( $tofile, $tofname ) = tempfile( UNLINK => 1 ); 86 print $fromfile "foo" x 1000; 87 $fromfile->flush; 88 89 ok( copy_if_diff( $fromfname, $tofname ), "copy_if_diff() true return status" ); 90 is( Parrot::Configure::Utils::file_checksum($tofname), 91 '324000', "copy_if_diff() copied differing files" ); 92} 93 94{ 95 my ( $fromfile, $fromfname ) = tempfile( UNLINK => 1 ); 96 my ( $tofile, $tofname ) = tempfile( UNLINK => 1 ); 97 print $fromfile "foo" x 1000; 98 $fromfile->flush; 99 print $tofile "foo" x 1000; 100 $tofile->flush; 101 102 ok( !defined( copy_if_diff( $fromfname, $tofname ) ), "copy_if_diff() true return undef" ); 103} 104 105# move_if_diff() 106 107{ 108 my ( $fromfile, $fromfname ) = tempfile( UNLINK => 1 ); 109 my ( $tofile, $tofname ) = tempfile( UNLINK => 1 ); 110 print $fromfile "foo" x 1000; 111 $fromfile->close; 112 $tofile->close; 113 114 # redirect STDERR to avoid warnings 115 my $redir = File::Spec->devnull; 116 117 # copy file descriptors 118 open *OLDERR, ">&", "STDERR"; 119 $fromfile->close(); 120 $tofile->close(); 121 122 ok( move_if_diff( $fromfname, $tofname ), "move_if_diff() true return status" ); 123 ok( !-e $fromfname, "move_if_diff() moved differing file" ); 124 125 # redirect STDERR for the test below 126 close *STDERR; 127 open *STDERR, '<', $redir; 128 129 ok( -e $tofname, "move_if_diff() moved differing file" ); 130 131 # restore STDERR 132 close *STDERR; 133 open *STDERR, ">&", "OLDERR"; 134 close *OLDERR; 135} 136 137{ 138 my %tf_params = ( UNLINK => 1, ); 139 $tf_params{SUFFIX} = '.exe' if ( 140 ( $^O eq 'MSWin32' ) || 141 ( $^O eq 'cygwin' ) 142 ); 143 my ( $tmpfile, $fname ) = tempfile(%tf_params); 144 145 local $ENV{PATH} = dirname($fname); 146 chmod 0777, $fname; 147 my $prog = basename($fname); 148 149 is( check_progs($prog), $prog, "check_progs() returns the proper program" ); 150} 151 152{ 153 my %tf_params = ( UNLINK => 1, ); 154 $tf_params{SUFFIX} = '.exe' if ( 155 ( $^O eq 'MSWin32' ) || 156 ( $^O eq 'cygwin' ) 157 ); 158 my ( $tmpfile, $fname ) = tempfile(%tf_params); 159 160 local $ENV{PATH} = dirname($fname); 161 chmod 0777, $fname; 162 my $prog = basename($fname); 163 164 is( check_progs( [$prog] ), 165 $prog, "check_progs() returns the proper program when passed an array ref" ); 166} 167 168{ 169 my $cmd = 'someboguscommand'; 170 ok( !check_progs( [$cmd] ), "check_progs() returns undef in scalar context on failure" ); 171 ok( !check_progs($cmd), "check_progs() returns undef in scalar context on failure" ); 172 is_deeply( [ check_progs( [$cmd] ) ], 173 [], "check_progs() returns () in list context on failure" ); 174 is_deeply( [ check_progs($cmd) ], [], "check_progs() returns () in list context on failure" ); 175} 176 177{ 178 my %tf_params = ( UNLINK => 1, ); 179 $tf_params{SUFFIX} = '.exe' if ( 180 ( $^O eq 'MSWin32' ) || 181 ( $^O eq 'cygwin' ) 182 ); 183 my ( $tmpfile, $fname ) = tempfile(%tf_params); 184 185 local $ENV{PATH} = dirname($fname); 186 chmod 0777, $fname; 187 my $prog = basename($fname); 188 189 my $verbose = 1; 190 my ($rv, $stdout) = 191 capture ( sub { is( check_progs( $prog, $verbose ), 192 $prog, "check_progs() returns the proper program" ) } ); 193 like( $stdout, qr/checking for program/, "Got expected verbose output" ); 194} 195 196{ 197 my $verbose = 1; 198 my ($prog, $stdout) = 199 capture ( sub { check_progs 200 ( [ 'gmake', 'mingw32-make', 'nmake', 'dmake', 'make' ], 201 $verbose) } ); 202 ok( defined($prog), "check_progs() returned a 'make' program" ); 203 like( $stdout, qr/checking for program/s, "Got expected verbose output" ); 204 like( $stdout, qr/$prog(\.EXE)? is executable/s, 205 "Got expected verbose output for executable program" ); 206} 207 208# print_to_cache(); read_from_cache() 209 210{ 211 my ( $fh, $file ) = tempfile( UNLINK => 1 ); 212 my $value = 'foobar'; 213 ok( print_to_cache( $file, $value ), 214 "print_to_cache() returned true value" ); 215 is( _slurp($file), 216 "$value\n", 217 "Correct value printed to cachefile" 218 ); 219 is( read_from_cache( $file ), $value, 220 "Got expected value from read_from_cache()" 221 ); 222} 223 224{ 225 my ( $tmpfile, $fname ) = tempfile( UNLINK => 1 ); 226 print $tmpfile "foo" x 1000; 227 $tmpfile->flush; 228 is( _slurp($fname), "foo" x 1000, "_slurp() slurped the file" ); 229} 230 231################### DOCUMENTATION ################### 232 233=head1 NAME 234 235t/configure/033-step.t - tests Parrot::Configure::Utils 236 237=head1 SYNOPSIS 238 239 prove t/configure/033-step.t 240 241=head1 DESCRIPTION 242 243Regression tests for the L<Parrot::Configure::Utils> module. 244 245=cut 246 247# Local Variables: 248# mode: cperl 249# cperl-indent-level: 4 250# fill-column: 100 251# End: 252# vim: expandtab shiftwidth=4: 253