xref: /openbsd/gnu/usr.bin/perl/cpan/autodie/t/truncate.t (revision d415bd75) 
1#!/usr/bin/perl -w
2use strict;
3
4use Test::More;
5use File::Temp qw(tempfile);
6use IO::Handle;
7use File::Spec;
8use FindBin qw($Bin);
9
10my ($truncate_status, $tmpfh, $tmpfile);
11
12# Some systems have a screwy tempfile. We don't run our tests there.
13eval {
14    ($tmpfh, $tmpfile) = tempfile(UNLINK => 1);
15};
16
17if ($@ or !defined $tmpfh) {
18    plan skip_all => 'tempfile() not happy on this system.';
19}
20
21eval {
22    $truncate_status = truncate($tmpfh, 0);
23};
24
25if ($@ || !defined($truncate_status)) {
26    plan skip_all => 'Truncate not implemented or not working on this system';
27}
28
29plan tests => 12;
30
31SKIP: {
32    my $can_truncate_stdout = truncate(\*STDOUT,0);
33
34    if ($can_truncate_stdout) {
35        skip("This system thinks we can truncate STDOUT. Suuure!", 1);
36    }
37
38    eval {
39        use autodie;
40        truncate(\*STDOUT,0);
41    };
42
43    isa_ok($@, 'autodie::exception', "Truncating STDOUT should throw an exception");
44
45}
46
47eval {
48    use autodie;
49    no warnings 'once';
50    truncate(\*FOO, 0);
51};
52
53isa_ok($@, 'autodie::exception', "Truncating an unopened file is wrong.");
54
55$tmpfh->print("Hello World");
56$tmpfh->flush;
57
58eval {
59    use autodie;
60    truncate($tmpfh, 0);
61};
62
63is($@, "", "Truncating a normal file should be fine");
64
65$tmpfh->close;
66
67# Time to test truncating via globs.
68
69# Firstly, truncating a closed filehandle should fail.
70# I know we tested this above, but we'll do a full dance of
71# opening and closing TRUNCATE_FH here.
72
73eval {
74    use autodie qw(truncate);
75    truncate(\*TRUNCATE_FH, 0);
76};
77
78isa_ok($@, 'autodie::exception', "Truncating unopened file (TRUNCATE_FH)");
79
80# Now open the file. If this throws an exception, there's something
81# wrong with our tests, or autodie...
82{
83    use autodie qw(open);
84    open(TRUNCATE_FH, '+<', $tmpfile);
85}
86
87# Now try truncating the filehandle. This should succeed.
88
89eval {
90    use autodie qw(truncate);
91    truncate(\*TRUNCATE_FH,0);
92};
93
94is($@, "", 'Truncating an opened glob (\*TRUNCATE_FH)');
95
96eval {
97    use autodie qw(truncate);
98    truncate(*TRUNCATE_FH,0);
99};
100
101is($@, "", 'Truncating an opened glob (*TRUNCATE_FH)');
102
103# Now let's change packages, since globs are package dependent
104
105eval {
106    package Fatal::Test;
107    no warnings 'once';
108    use autodie qw(truncate);
109    truncate(\*TRUNCATE_FH,0);  # Should die, as now unopened
110};
111
112isa_ok($@, 'autodie::exception', 'Truncating unopened file in different package (\*TRUNCATE_FH)');
113
114eval {
115    package Fatal::Test;
116    no warnings 'once';
117    use autodie qw(truncate);
118    truncate(*TRUNCATE_FH,0);  # Should die, as now unopened
119};
120
121isa_ok($@, 'autodie::exception', 'Truncating unopened file in different package (*TRUNCATE_FH)');
122
123# Now back to our previous test, just to make sure it hasn't changed
124# the original file.
125
126eval {
127    use autodie qw(truncate);
128    truncate(\*TRUNCATE_FH,0);
129};
130
131is($@, "", 'Truncating an opened glob #2 (\*TRUNCATE_FH)');
132
133eval {
134    use autodie qw(truncate);
135    truncate(*TRUNCATE_FH,0);
136};
137
138is($@, "", 'Truncating an opened glob #2 (*TRUNCATE_FH)');
139
140# Now to close the file and retry.
141{
142    use autodie qw(close);
143    close(TRUNCATE_FH);
144}
145
146eval {
147    use autodie qw(truncate);
148    truncate(\*TRUNCATE_FH,0);
149};
150
151isa_ok($@, 'autodie::exception', 'Truncating freshly closed glob (\*TRUNCATE_FH)');
152
153eval {
154    use autodie qw(truncate);
155    truncate(*TRUNCATE_FH,0);
156};
157
158isa_ok($@, 'autodie::exception', 'Truncating freshly closed glob (*TRUNCATE_FH)');
159