1#!/usr/bin/perl -w 2 3BEGIN { 4 unshift @INC, 't/lib'; 5} 6 7use strict; 8use warnings; 9 10use Test::More tests => 45; 11use File::Spec; 12 13my $dir = 't/source_tests'; 14 15use_ok('TAP::Parser::Source'); 16 17sub ct($) { 18 my $hash = shift; 19 if ( $ENV{PERL_CORE} ) { 20 delete $hash->{is_symlink}; 21 delete $hash->{lstat}; 22 } 23 return $hash; 24} 25 26# Basic tests 27{ 28 my $source = TAP::Parser::Source->new; 29 isa_ok( $source, 'TAP::Parser::Source', 'new source' ); 30 can_ok( 31 $source, 32 qw( raw meta config merge switches test_args assemble_meta ) 33 ); 34 35 is_deeply( $source->config, {}, 'config empty by default' ); 36 $source->config->{Foo} = { bar => 'baz' }; 37 is_deeply( 38 $source->config_for('Foo'), { bar => 'baz' }, 39 'config_for( Foo )' 40 ); 41 is_deeply( 42 $source->config_for('TAP::Parser::SourceHandler::Foo'), 43 { bar => 'baz' }, 'config_for( ...::SourceHandler::Foo )' 44 ); 45 46 ok( !$source->merge, 'merge not set by default' ); 47 $source->merge(1); 48 ok( $source->merge, '... merge now set' ); 49 50 is( $source->switches, undef, 'switches not set by default' ); 51 $source->switches( ['-Ilib'] ); 52 is_deeply( $source->switches, ['-Ilib'], '... switches now set' ); 53 54 is( $source->test_args, undef, 'test_args not set by default' ); 55 $source->test_args( ['foo'] ); 56 is_deeply( $source->test_args, ['foo'], '... test_args now set' ); 57 58 $source->raw( \'hello world' ); 59 my $meta = $source->assemble_meta; 60 is_deeply( 61 $meta, 62 { is_scalar => 1, 63 is_object => 0, 64 has_newlines => 0, 65 length => 11, 66 }, 67 'assemble_meta for scalar that isnt a file' 68 ); 69 70 is( $source->meta, $meta, '... and caches meta' ); 71} 72 73# array check 74{ 75 my $source = TAP::Parser::Source->new; 76 $source->raw( [ 'hello', 'world' ] ); 77 my $meta = $source->assemble_meta; 78 is_deeply( 79 $meta, 80 { is_array => 1, 81 is_object => 0, 82 size => 2, 83 }, 84 'assemble_meta for array' 85 ); 86} 87 88# hash check 89{ 90 my $source = TAP::Parser::Source->new; 91 $source->raw( { hello => 'world' } ); 92 my $meta = $source->assemble_meta; 93 is_deeply( 94 $meta, 95 { is_hash => 1, 96 is_object => 0, 97 }, 98 'assemble_meta for array' 99 ); 100} 101 102# glob check 103{ 104 my $source = TAP::Parser::Source->new; 105 $source->raw( \*__DATA__ ); 106 my $meta = $source->assemble_meta; 107 is_deeply( 108 $meta, 109 { is_glob => 1, 110 is_object => 0, 111 }, 112 'assemble_meta for array' 113 ); 114} 115 116# object check 117{ 118 my $source = TAP::Parser::Source->new; 119 $source->raw( bless {}, 'Foo::Bar' ); 120 my $meta = $source->assemble_meta; 121 is_deeply( 122 $meta, 123 { is_object => 1, 124 class => 'Foo::Bar', 125 }, 126 'assemble_meta for array' 127 ); 128} 129 130# file test 131{ 132 my $test = File::Spec->catfile( $dir, 'source.t' ); 133 my $source = TAP::Parser::Source->new; 134 135 $source->raw( \$test ); 136 my $meta = $source->assemble_meta; 137 138 # separate meta->file to break up the test 139 my $file = delete $meta->{file}; 140 is_deeply( 141 ct $meta, 142 ct {is_scalar => 1, 143 has_newlines => 0, 144 length => length($test), 145 is_object => 0, 146 is_file => 1, 147 is_dir => 0, 148 is_symlink => 0, 149 }, 150 'assemble_meta for file' 151 ); 152 153 # now check file meta - remove things that will vary between platforms 154 my $stat = delete $file->{stat}; 155 is( @$stat, 13, '... file->stat set' ); 156 ok( delete $file->{size}, '... file->size set' ); 157 ok( delete $file->{dir}, '... file->dir set' ); 158 isnt( delete $file->{read}, undef, '... file->read set' ); 159 isnt( delete $file->{write}, undef, '... file->write set' ); 160 isnt( delete $file->{execute}, undef, '... file->execute set' ); 161 is_deeply( 162 ct $file, 163 ct {basename => 'source.t', 164 ext => '.t', 165 lc_ext => '.t', 166 shebang => '#!/usr/bin/perl', 167 binary => 0, 168 text => 1, 169 empty => 0, 170 exists => 1, 171 is_dir => 0, 172 is_file => 1, 173 is_symlink => 0, 174 175 # Fix for bizarre -k bug in Strawberry Perl 176 sticky => ( -k $test )[-1] ? 1 : 0, 177 setgid => -g $test ? 1 : 0, 178 setuid => -u $test ? 1 : 0, 179 }, 180 '... file->* set' 181 ); 182} 183 184# dir test 185{ 186 my $test = $dir; 187 my $source = TAP::Parser::Source->new; 188 189 $source->raw( \$test ); 190 my $meta = $source->assemble_meta; 191 192 # separate meta->file to break up the test 193 my $file = delete $meta->{file}; 194 is_deeply( 195 ct $meta, 196 ct {is_scalar => 1, 197 has_newlines => 0, 198 length => length($test), 199 is_object => 0, 200 is_file => 0, 201 is_dir => 1, 202 is_symlink => 0, 203 }, 204 'assemble_meta for directory' 205 ); 206 207 # now check file meta - remove things that will vary between platforms 208 my $stat = delete $file->{stat}; 209 is( @$stat, 13, '... file->stat set' ); 210 ok( delete $file->{dir}, '... file->dir set' ); 211 isnt( delete $file->{size}, undef, '... file->size set' ); 212 isnt( delete $file->{binary}, undef, '... file->binary set' ); 213 isnt( delete $file->{empty}, undef, '... file->empty set' ); 214 isnt( delete $file->{read}, undef, '... file->read set' ); 215 isnt( delete $file->{write}, undef, '... file->write set' ); 216 isnt( delete $file->{execute}, undef, '... file->execute set' ); 217 is_deeply( 218 ct $file, 219 ct {basename => 'source_tests', 220 ext => '', 221 lc_ext => '', 222 text => 0, 223 exists => 1, 224 is_dir => 1, 225 is_file => 0, 226 is_symlink => 0, 227 sticky => ( -k $test )[-1] ? 1 : 0, 228 setgid => -g $test ? 1 : 0, 229 setuid => -u $test ? 1 : 0, 230 }, 231 '... file->* set' 232 ); 233} 234 235# symlink test 236SKIP: { 237 my $symlink_exists = eval { symlink( '', '' ); 1 }; 238 $symlink_exists = 0 if $^O eq 'VMS'; # exists but not ready for prime time 239 $symlink_exists = 0 if $^O eq 'msys'; # exists but not ready for prime time 240 skip 'symlink not supported on this platform', 9 unless $symlink_exists; 241 242 my $test = File::Spec->catfile( $dir, 'source.t' ); 243 my $symlink = File::Spec->catfile( $dir, 'source_link.T' ); 244 my $source = TAP::Parser::Source->new; 245 246 my $did_symlink = eval { symlink( File::Spec->rel2abs($test), $symlink ) }; 247 if ( my $e = $@ ) { 248 diag($@); 249 die "aborting test"; 250 } 251 skip "symlink not successful: $!", 9 unless $did_symlink; 252 253 $source->raw( \$symlink ); 254 my $meta = $source->assemble_meta; 255 256 # separate meta->file to break up the test 257 my $file = delete $meta->{file}; 258 is_deeply( 259 ct $meta, 260 ct {is_scalar => 1, 261 has_newlines => 0, 262 length => length($symlink), 263 is_object => 0, 264 is_file => 1, 265 is_dir => 0, 266 is_symlink => 1, 267 }, 268 'assemble_meta for symlink' 269 ); 270 271 # now check file meta - remove things that will vary between platforms 272 my $stat = delete $file->{stat}; 273 is( @$stat, 13, '... file->stat set' ); 274 my $lstat = delete $file->{lstat}; 275 is( @$lstat, 13, '... file->lstat set' ); 276 ok( delete $file->{size}, '... file->size set' ); 277 ok( delete $file->{dir}, '... file->dir set' ); 278 isnt( delete $file->{read}, undef, '... file->read set' ); 279 isnt( delete $file->{write}, undef, '... file->write set' ); 280 isnt( delete $file->{execute}, undef, '... file->execute set' ); 281 is_deeply( 282 ct $file, 283 ct {basename => 'source_link.T', 284 ext => '.T', 285 lc_ext => '.t', 286 shebang => '#!/usr/bin/perl', 287 binary => 0, 288 text => 1, 289 empty => 0, 290 exists => 1, 291 is_dir => 0, 292 is_file => 1, 293 is_symlink => 1, 294 sticky => ( -k $symlink )[-1] ? 1 : 0, 295 setgid => -g $symlink ? 1 : 0, 296 setuid => -u $symlink ? 1 : 0, 297 }, 298 '... file->* set' 299 ); 300 301 unlink $symlink; 302} 303 304