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