1#!./perl -w 2 3BEGIN { 4 unshift @INC, 't'; 5 require Config; 6 if (($Config::Config{'extensions'} !~ /\bB\b/) ){ 7 print "1..0 # Skip -- Perl configured without B module\n"; 8 exit 0; 9 } 10 require 'test.pl'; 11} 12 13use strict; 14use Config; 15use File::Spec; 16use File::Path; 17 18my $path = File::Spec->catdir( 'lib', 'B' ); 19unless (-d $path) { 20 mkpath( $path ) or skip_all( 'Cannot create fake module path' ); 21} 22 23my $file = File::Spec->catfile( $path, 'success.pm' ); 24local *OUT; 25open(OUT, '>', $file) or skip_all( 'Cannot write fake backend module'); 26print OUT while <DATA>; 27close *OUT; 28 29plan( 9 ); # And someone's responsible. 30 31# use() makes it difficult to avoid O::import() 32require_ok( 'O' ); 33 34my @lines = get_lines( '-MO=success,foo,bar' ); 35 36is( $lines[0], 'Compiling!', 'Output should not be saved without -q switch' ); 37is( $lines[1], '(foo) <bar>', 'O.pm should call backend compile() method' ); 38is( $lines[2], '[]', 'Nothing should be in $O::BEGIN_output without -q' ); 39is( $lines[3], '-e syntax OK', 'O.pm should not munge perl output without -qq'); 40 41@lines = get_lines( '-MO=-q,success,foo,bar' ); 42isnt( $lines[1], 'Compiling!', 'Output should not be printed with -q switch' ); 43 44SKIP: { 45 skip( '-q redirection does not work without PerlIO', 2) 46 unless $Config{useperlio}; 47 is( $lines[1], "[Compiling!", '... but should be in $O::BEGIN_output' ); 48 49 @lines = get_lines( '-MO=-qq,success,foo,bar' ); 50 is( scalar @lines, 3, '-qq should suppress even the syntax OK message' ); 51} 52 53@lines = get_lines( '-MO=success,fail' ); 54like( $lines[1], qr/fail at .eval/, 55 'O.pm should die if backend compile() does not return a subref' ); 56 57sub get_lines { 58 my $compile = shift; 59 split(/[\r\n]+/, runperl( switches => [ '-Ilib', $compile ], 60 prog => 1, stderr => 1 )); 61} 62 63END { 64 1 while unlink($file); 65 rmdir($path); # not "1 while" since there might be more in there 66} 67 68__END__ 69package B::success; 70 71$| = 1; 72print "Compiling!\n"; 73 74sub compile { 75 return 'fail' if ($_[0] eq 'fail'); 76 print "($_[0]) <$_[1]>\n"; 77 return sub { print "[$O::BEGIN_output]\n" }; 78} 79 801; 81