xref: /openbsd-src/gnu/usr.bin/perl/cpan/autodie/t/truncate.t (revision f2da64fbbbf1b03f09f390ab01267c93dfd77c4c) 
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();
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# Time to test truncating via globs.
66
67# Firstly, truncating a closed filehandle should fail.
68# I know we tested this above, but we'll do a full dance of
69# opening and closing TRUNCATE_FH here.
70
71eval {
72    use autodie qw(truncate);
73    truncate(\*TRUNCATE_FH, 0);
74};
75
76isa_ok($@, 'autodie::exception', "Truncating unopened file (TRUNCATE_FH)");
77
78# Now open the file. If this throws an exception, there's something
79# wrong with our tests, or autodie...
80{
81    use autodie qw(open);
82    open(TRUNCATE_FH, '+<', $tmpfile);
83}
84
85# Now try truncating the filehandle. This should succeed.
86
87eval {
88    use autodie qw(truncate);
89    truncate(\*TRUNCATE_FH,0);
90};
91
92is($@, "", 'Truncating an opened glob (\*TRUNCATE_FH)');
93
94eval {
95    use autodie qw(truncate);
96    truncate(*TRUNCATE_FH,0);
97};
98
99is($@, "", 'Truncating an opened glob (*TRUNCATE_FH)');
100
101# Now let's change packages, since globs are package dependent
102
103eval {
104    package Fatal::Test;
105    no warnings 'once';
106    use autodie qw(truncate);
107    truncate(\*TRUNCATE_FH,0);  # Should die, as now unopened
108};
109
110isa_ok($@, 'autodie::exception', 'Truncating unopened file in different package (\*TRUNCATE_FH)');
111
112eval {
113    package Fatal::Test;
114    no warnings 'once';
115    use autodie qw(truncate);
116    truncate(*TRUNCATE_FH,0);  # Should die, as now unopened
117};
118
119isa_ok($@, 'autodie::exception', 'Truncating unopened file in different package (*TRUNCATE_FH)');
120
121# Now back to our previous test, just to make sure it hasn't changed
122# the original file.
123
124eval {
125    use autodie qw(truncate);
126    truncate(\*TRUNCATE_FH,0);
127};
128
129is($@, "", 'Truncating an opened glob #2 (\*TRUNCATE_FH)');
130
131eval {
132    use autodie qw(truncate);
133    truncate(*TRUNCATE_FH,0);
134};
135
136is($@, "", 'Truncating an opened glob #2 (*TRUNCATE_FH)');
137
138# Now to close the file and retry.
139{
140    use autodie qw(close);
141    close(TRUNCATE_FH);
142}
143
144eval {
145    use autodie qw(truncate);
146    truncate(\*TRUNCATE_FH,0);
147};
148
149isa_ok($@, 'autodie::exception', 'Truncating freshly closed glob (\*TRUNCATE_FH)');
150
151eval {
152    use autodie qw(truncate);
153    truncate(*TRUNCATE_FH,0);
154};
155
156isa_ok($@, 'autodie::exception', 'Truncating freshly closed glob (*TRUNCATE_FH)');
157