1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
|
From: Niko Tyni <ntyni@debian.org>
Subject: Honor TMPDIR when open()ing an anonymous temporary file
Bug-Debian: http://bugs.debian.org/528544
Bug: http://rt.perl.org/rt3/Public/Bug/Display.html?id=66452
[perl #66452]
As reported by Norbert Buchmuller <norbi@nix.hu>, opening an anonymous
temporary file with the magical open($fh, '+>', undef) ignores TMPDIR.
---
perlio.c | 20 ++++++++++++++++----
t/io/perlio.t | 15 ++++++++++++++-
2 files changed, 30 insertions(+), 5 deletions(-)
diff --git a/perlio.c b/perlio.c
index 3803247..3ce579f 100644
--- a/perlio.c
+++ b/perlio.c
@@ -5167,18 +5167,30 @@ PerlIO_tmpfile(void)
f = PerlIO_fdopen(fd, "w+b");
#else /* WIN32 */
# if defined(HAS_MKSTEMP) && ! defined(VMS) && ! defined(OS2)
- SV * const sv = newSVpvs("/tmp/PerlIO_XXXXXX");
+ int fd = -1;
+ char tempname[] = "/tmp/PerlIO_XXXXXX";
+ const char * const tmpdir = PL_tainting ? NULL : PerlEnv_getenv("TMPDIR");
+ SV * const sv = tmpdir && *tmpdir ? newSVpv(tmpdir, 0) : NULL;
/*
* I have no idea how portable mkstemp() is ... NI-S
*/
- const int fd = mkstemp(SvPVX(sv));
+ if (sv) {
+ /* if TMPDIR is set and not empty, we try that first */
+ sv_catpv(sv, tempname + 4);
+ fd = mkstemp(SvPVX(sv));
+ }
+ if (fd < 0) {
+ /* else we try /tmp */
+ fd = mkstemp(tempname);
+ }
if (fd >= 0) {
f = PerlIO_fdopen(fd, "w+");
if (f)
PerlIOBase(f)->flags |= PERLIO_F_TEMP;
- PerlLIO_unlink(SvPVX_const(sv));
+ PerlLIO_unlink(sv ? SvPVX_const(sv) : tempname);
}
- SvREFCNT_dec(sv);
+ if (sv)
+ SvREFCNT_dec(sv);
# else /* !HAS_MKSTEMP, fallback to stdio tmpfile(). */
FILE * const stdio = PerlSIO_tmpfile();
diff --git a/t/io/perlio.t b/t/io/perlio.t
index c145945..c1eebec 100755
--- a/t/io/perlio.t
+++ b/t/io/perlio.t
@@ -8,13 +8,14 @@ BEGIN {
}
}
-use Test::More tests => 37;
+use Test::More tests => 39;
use_ok('PerlIO');
my $txt = "txt$$";
my $bin = "bin$$";
my $utf = "utf$$";
+my $nonexistent = "nex$$";
my $txtfh;
my $binfh;
@@ -89,6 +90,17 @@ ok(close($utffh));
# report after STDOUT is restored
ok($status, ' re-open STDOUT');
close OLDOUT;
+
+ SKIP: {
+ skip("TMPDIR not honored on this platform", 2)
+ if !$Config{d_mkstemp}
+ || $^O eq 'VMS' || $^O eq 'MSwin32' || $^O eq 'os2';
+ local $ENV{TMPDIR} = $nonexistent;
+ ok( open(my $x,"+<",undef), 'TMPDIR honored by magic temp file via 3 arg open with undef - works if TMPDIR points to a non-existent dir');
+
+ mkdir $ENV{TMPDIR};
+ ok(open(my $x,"+<",undef), 'TMPDIR honored by magic temp file via 3 arg open with undef - works if TMPDIR points to an existent dir');
+ }
}
# in-memory open
@@ -136,5 +148,6 @@ END {
1 while unlink $txt;
1 while unlink $bin;
1 while unlink $utf;
+ rmdir $nonexistent;
}
--
tg: (daf8b46..) fixes/anon-tmpfile-dir (depends on: upstream)
|
