Commit | Line | Data |
---|---|---|
03309359 | 1 | #!./perl |
2 | ||
3 | BEGIN { | |
4 | chdir 't' if -d 't'; | |
5 | @INC = '../lib'; | |
6 | } | |
7 | ||
85dd7502 | 8 | use Config; |
c78f3842 | 9 | use Test::More tests => 15; |
03309359 | 10 | |
11 | # these two should be kept in sync with the pragma itself | |
12 | # if hint bits are changed there, other things *will* break | |
13 | my $hint_bits = 0x00400000; | |
14 | my $error = "filetest: the only implemented subpragma is 'access'.\n"; | |
15 | ||
16 | # can't use it yet, because of the import death | |
17 | ok( require filetest, 'required pragma successfully' ); | |
18 | ||
19 | # and here's one culprit, right here | |
20 | eval { filetest->import('bad subpragma') }; | |
21 | is( $@, $error, 'filetest dies with bad subpragma on import' ); | |
22 | ||
23 | is( $^H & $hint_bits, 0, 'hint bits not set without pragma in place' ); | |
24 | ||
25 | # now try the normal usage | |
26 | # can't check $^H here; it's lexically magic (see perlvar) | |
27 | # the test harness unintentionally hoards the goodies for itself | |
28 | use_ok( 'filetest', 'access' ); | |
29 | ||
30 | # and import again, to see it here | |
31 | filetest->import('access'); | |
32 | ok( $^H & $hint_bits, 'hint bits set with pragma loaded' ); | |
33 | ||
34 | # and now get rid of it | |
35 | filetest->unimport('access'); | |
36 | is( $^H & $hint_bits, 0, 'hint bits not set with pragma unimported' ); | |
37 | ||
38 | eval { filetest->unimport() }; | |
39 | is( $@, $error, 'filetest dies without subpragma on unimport' ); | |
40 | ||
41 | # there'll be a compilation aborted failure here, with the eval string | |
42 | eval "no filetest 'fake pragma'"; | |
43 | like( $@, qr/^$error/, 'filetest dies with bad subpragma on unuse' ); | |
44 | ||
45 | eval "use filetest 'bad subpragma'"; | |
46 | like( $@, qr/^$error/, 'filetest dies with bad subpragma on use' ); | |
47 | ||
48 | eval "use filetest"; | |
49 | like( $@, qr/^$error/, 'filetest dies with missing subpragma on use' ); | |
50 | ||
51 | eval "no filetest"; | |
52 | like( $@, qr/^$error/, 'filetest dies with missing subpragma on unuse' ); | |
43b06338 SR |
53 | |
54 | SKIP: { | |
55 | # A real test for filetest. | |
56 | # This works for systems with /usr/bin/chflags (i.e. BSD4.4 systems). | |
57 | my $chflags = "/usr/bin/chflags"; | |
58 | my $tstfile = "filetest.tst"; | |
3acb6bcd | 59 | skip("No $chflags available", 4) if !-x $chflags; |
43b06338 | 60 | |
85dd7502 SR |
61 | my $skip_eff_user_tests = (!$Config{d_setreuid} && !$Config{d_setresuid}) |
62 | || | |
63 | (!$Config{d_setregid} && !$Config{d_setresgid}); | |
64 | ||
65 | eval { | |
66 | if (!-e $tstfile) { | |
67 | open(T, ">$tstfile") or die "Can't create $tstfile: $!"; | |
68 | close T; | |
69 | } | |
70 | system($chflags, "uchg", $tstfile); | |
71 | die "Can't exec $chflags uchg" if $? != 0; | |
72 | }; | |
73 | skip("Errors in test using chflags: $@", 4) if $@; | |
74 | ||
75 | { | |
76 | use filetest 'access'; | |
77 | SKIP: { | |
78 | skip("No tests on effective user id", 1) | |
79 | if $skip_eff_user_tests; | |
43b06338 | 80 | is(-w $tstfile, undef, "$tstfile should not be recognized as writable"); |
43b06338 | 81 | } |
85dd7502 SR |
82 | is(-W $tstfile, undef, "$tstfile should not be recognized as writable"); |
83 | } | |
84 | ||
85 | { | |
86 | no filetest 'access'; | |
87 | SKIP: { | |
88 | skip("No tests on effective user id", 1) | |
89 | if $skip_eff_user_tests; | |
43b06338 | 90 | is(-w $tstfile, 1, "$tstfile should be recognized as writable"); |
43b06338 | 91 | } |
85dd7502 | 92 | is(-W $tstfile, 1, "$tstfile should be recognized as writable"); |
43b06338 SR |
93 | } |
94 | ||
95 | # cleanup | |
96 | system($chflags, "nouchg", $tstfile); | |
97 | unlink $tstfile; | |
98 | warn "Can't remove $tstfile: $!" if -e $tstfile; | |
99 | } |