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            # Fix for bizarre -k bug in Strawberry Perl
174            sticky     => ( -k $test )[-1] ? 1 : 0,
175            setgid     => -g $test ? 1 : 0,
176            setuid     => -u $test ? 1 : 0,
177        },
178        '... file->* set'
179    );
180}
181
182# dir test
183{
184    my $test   = $dir;
185    my $source = TAP::Parser::Source->new;
186
187    $source->raw( \$test );
188    my $meta = $source->assemble_meta;
189
190    # separate meta->file to break up the test
191    my $file = delete $meta->{file};
192    is_deeply(
193        ct $meta,
194        ct {is_scalar    => 1,
195            has_newlines => 0,
196            length       => length($test),
197            is_object    => 0,
198            is_file      => 0,
199            is_dir       => 1,
200            is_symlink   => 0,
201        },
202        'assemble_meta for directory'
203    );
204
205    # now check file meta - remove things that will vary between platforms
206    my $stat = delete $file->{stat};
207    is( @$stat, 13, '... file->stat set' );
208    ok( delete $file->{dir}, '... file->dir set' );
209    isnt( delete $file->{size},    undef, '... file->size set' );
210    isnt( delete $file->{binary},  undef, '... file->binary set' );
211    isnt( delete $file->{empty},   undef, '... file->empty set' );
212    isnt( delete $file->{read},    undef, '... file->read set' );
213    isnt( delete $file->{write},   undef, '... file->write set' );
214    isnt( delete $file->{execute}, undef, '... file->execute set' );
215    is_deeply(
216        ct $file,
217        ct {basename   => 'source_tests',
218            ext        => '',
219            lc_ext     => '',
220            text       => 0,
221            exists     => 1,
222            is_dir     => 1,
223            is_file    => 0,
224            is_symlink => 0,
225            sticky     => ( -k $test )[-1] ? 1 : 0,
226            setgid     => -g $test ? 1 : 0,
227            setuid     => -u $test ? 1 : 0,
228        },
229        '... file->* set'
230    );
231}
232
233# symlink test
234SKIP: {
235    my $symlink_exists = eval { symlink( '', '' ); 1 };
236    $symlink_exists = 0 if $^O eq 'VMS'; # exists but not ready for prime time
237    skip 'symlink not supported on this platform', 9 unless $symlink_exists;
238
239    my $test    = File::Spec->catfile( $dir, 'source.t' );
240    my $symlink = File::Spec->catfile( $dir, 'source_link.T' );
241    my $source  = TAP::Parser::Source->new;
242
243    eval { symlink( File::Spec->rel2abs($test), $symlink ) };
244    if ( my $e = $@ ) {
245        diag($@);
246        die "aborting test";
247    }
248
249    $source->raw( \$symlink );
250    my $meta = $source->assemble_meta;
251
252    # separate meta->file to break up the test
253    my $file = delete $meta->{file};
254    is_deeply(
255        ct $meta,
256        ct {is_scalar    => 1,
257            has_newlines => 0,
258            length       => length($symlink),
259            is_object    => 0,
260            is_file      => 1,
261            is_dir       => 0,
262            is_symlink   => 1,
263        },
264        'assemble_meta for symlink'
265    );
266
267    # now check file meta - remove things that will vary between platforms
268    my $stat = delete $file->{stat};
269    is( @$stat, 13, '... file->stat set' );
270    my $lstat = delete $file->{lstat};
271    is( @$lstat, 13, '... file->lstat set' );
272    ok( delete $file->{size}, '... file->size set' );
273    ok( delete $file->{dir},  '... file->dir set' );
274    isnt( delete $file->{read},    undef, '... file->read set' );
275    isnt( delete $file->{write},   undef, '... file->write set' );
276    isnt( delete $file->{execute}, undef, '... file->execute set' );
277    is_deeply(
278        ct $file,
279        ct {basename   => 'source_link.T',
280            ext        => '.T',
281            lc_ext     => '.t',
282            shebang    => '#!/usr/bin/perl',
283            binary     => 0,
284            text       => 1,
285            empty      => 0,
286            exists     => 1,
287            is_dir     => 0,
288            is_file    => 1,
289            is_symlink => 1,
290            sticky     => ( -k $symlink )[-1] ? 1 : 0,
291            setgid     => -g $symlink ? 1 : 0,
292            setuid     => -u $symlink ? 1 : 0,
293        },
294        '... file->* set'
295    );
296
297    unlink $symlink;
298}
299
300