xref: /openbsd-src/gnu/usr.bin/perl/cpan/Test-Harness/t/source.t (revision 5486feefcc8cb79b19e014ab332cc5dfd05b3b33)
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