This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Bump Data::Dumper version
[perl5.git] / win32 / win32io.c
CommitLineData
a8c08ecd
NIS
1#define PERL_NO_GET_CONTEXT
2#define WIN32_LEAN_AND_MEAN
3#define WIN32IO_IS_STDIO
4#include <tchar.h>
5#ifdef __GNUC__
6#define Win32_Winsock
7#endif
8#include <windows.h>
9
10#include <sys/stat.h>
11#include "EXTERN.h"
12#include "perl.h"
57143e73
NIS
13
14#ifdef PERLIO_LAYERS
15
0c4128ad 16#include "perliol.h"
a8c08ecd
NIS
17
18#define NO_XSLOCKS
19#include "XSUB.h"
20
57143e73 21
a8c08ecd
NIS
22/* Bottom-most level for Win32 case */
23
24typedef struct
25{
26 struct _PerlIO base; /* The generic part */
27 HANDLE h; /* OS level handle */
28 IV refcnt; /* REFCNT for the "fd" this represents */
29 int fd; /* UNIX like file descriptor - index into fdtable */
30} PerlIOWin32;
31
32PerlIOWin32 *fdtable[256];
33IV max_open_fd = -1;
34
35IV
5833650d 36PerlIOWin32_popped(pTHX_ PerlIO *f)
a8c08ecd
NIS
37{
38 PerlIOWin32 *s = PerlIOSelf(f,PerlIOWin32);
39 if (--s->refcnt > 0)
40 {
41 *f = PerlIOBase(f)->next;
42 return 1;
43 }
44 fdtable[s->fd] = NULL;
45 return 0;
46}
47
48IV
5833650d 49PerlIOWin32_fileno(pTHX_ PerlIO *f)
a8c08ecd
NIS
50{
51 return PerlIOSelf(f,PerlIOWin32)->fd;
52}
53
54IV
2dc2558e 55PerlIOWin32_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
a8c08ecd 56{
2dc2558e 57 IV code = PerlIOBase_pushed(aTHX_ f,mode,arg,tab);
a8c08ecd
NIS
58 if (*PerlIONext(f))
59 {
60 PerlIOWin32 *s = PerlIOSelf(f,PerlIOWin32);
61 s->fd = PerlIO_fileno(PerlIONext(f));
62 }
63 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
7ac92924
TC
64
65 Perl_ck_warner_d(aTHX_
1604cfb0
MS
66 packWARN(WARN_EXPERIMENTAL__WIN32_PERLIO),
67 "PerlIO layer ':win32' is experimental");
7ac92924 68
a8c08ecd
NIS
69 return code;
70}
71
72PerlIO *
73PerlIOWin32_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers, IV n, const char *mode, int fd, int imode, int perm, PerlIO *f, int narg, SV **args)
74{
75 const char *tmode = mode;
76 HANDLE h = INVALID_HANDLE_VALUE;
77 if (f)
78 {
79 /* Close if already open */
80 if (PerlIOBase(f)->flags & PERLIO_F_OPEN)
5833650d 81 (*PerlIOBase(f)->tab->Close)(aTHX_ f);
a8c08ecd
NIS
82 }
83 if (narg > 0)
84 {
85 char *path = SvPV_nolen(*args);
86 DWORD access = 0;
d40610d1
DD
87 /* CRT uses _SH_DENYNO for open(), this the Win32 equivelent */
88 DWORD share = FILE_SHARE_READ | FILE_SHARE_WRITE;
a8c08ecd
NIS
89 DWORD create = -1;
90 DWORD attr = FILE_ATTRIBUTE_NORMAL;
83b69bfd
DD
91 if (stricmp(path, "/dev/null")==0)
92 path = "NUL";
a8c08ecd
NIS
93 if (*mode == '#')
94 {
95 /* sysopen - imode is UNIX-like O_RDONLY etc.
96 - do_open has converted that back to string form in mode as well
97 - perm is UNIX like permissions
98 */
99 mode++;
100 }
101 else
102 {
103 /* Normal open - decode mode string */
104 }
105 switch(*mode)
106 {
107 case 'r':
108 access = GENERIC_READ;
109 create = OPEN_EXISTING;
110 if (*++mode == '+')
111 {
112 access |= GENERIC_WRITE;
113 create = OPEN_ALWAYS;
114 mode++;
115 }
116 break;
117
118 case 'w':
119 access = GENERIC_WRITE;
120 create = TRUNCATE_EXISTING;
121 if (*++mode == '+')
122 {
123 access |= GENERIC_READ;
124 mode++;
125 }
126 break;
127
128 case 'a':
129 access = GENERIC_WRITE;
130 create = OPEN_ALWAYS;
131 if (*++mode == '+')
132 {
133 access |= GENERIC_READ;
134 mode++;
135 }
136 break;
137 }
138 if (*mode == 'b')
139 {
140 mode++;
141 }
142 else if (*mode == 't')
143 {
144 mode++;
145 }
0c4128ad 146 if (*mode || create == -1)
a8c08ecd
NIS
147 {
148 SETERRNO(EINVAL,LIB$_INVARG);
149 return NULL;
150 }
a8c08ecd
NIS
151 h = CreateFile(path,access,share,NULL,create,attr,NULL);
152 if (h == INVALID_HANDLE_VALUE)
153 {
154 if (create == TRUNCATE_EXISTING)
0c4128ad 155 h = CreateFile(path,access,share,NULL,(create = OPEN_ALWAYS),attr,NULL);
a8c08ecd
NIS
156 }
157 }
158 else
159 {
160 /* fd open */
161 h = INVALID_HANDLE_VALUE;
ed77cbc6 162 if (inRANGE(fd, 0, max_open_fd))
a8c08ecd
NIS
163 {
164 PerlIOWin32 *s = fdtable[fd];
165 if (s)
166 {
167 s->refcnt++;
168 if (!f)
169 f = PerlIO_allocate(aTHX);
170 *f = &s->base;
171 return f;
172 }
0c4128ad
NIS
173 }
174 if (*mode == 'I')
175 {
176 mode++;
177 switch(fd)
a8c08ecd 178 {
0c4128ad
NIS
179 case 0:
180 h = GetStdHandle(STD_INPUT_HANDLE);
181 break;
182 case 1:
183 h = GetStdHandle(STD_OUTPUT_HANDLE);
184 break;
185 case 2:
186 h = GetStdHandle(STD_ERROR_HANDLE);
187 break;
a8c08ecd
NIS
188 }
189 }
190 }
191 if (h != INVALID_HANDLE_VALUE)
c623ac67 192 fd = win32_open_osfhandle((intptr_t) h, PerlIOUnix_oflags(tmode));
0c4128ad 193 if (fd >= 0)
a8c08ecd
NIS
194 {
195 PerlIOWin32 *s;
196 if (!f)
197 f = PerlIO_allocate(aTHX);
198 s = PerlIOSelf(PerlIO_push(aTHX_ f,self,tmode,PerlIOArg),PerlIOWin32);
0c4128ad
NIS
199 s->h = h;
200 s->fd = fd;
a8c08ecd 201 s->refcnt = 1;
8cf8f3d1 202 if (fd >= 0)
0c4128ad 203 {
8cf8f3d1 204 fdtable[fd] = s;
0c4128ad
NIS
205 if (fd > max_open_fd)
206 max_open_fd = fd;
8cf8f3d1 207 }
a8c08ecd
NIS
208 return f;
209 }
210 if (f)
211 {
212 /* FIXME: pop layers ??? */
213 }
214 return NULL;
215}
216
217SSize_t
5833650d 218PerlIOWin32_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
a8c08ecd
NIS
219{
220 PerlIOWin32 *s = PerlIOSelf(f,PerlIOWin32);
221 DWORD len;
222 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
223 return 0;
0c4128ad 224 if (ReadFile(s->h,vbuf,count,&len,NULL))
a8c08ecd
NIS
225 {
226 return len;
227 }
228 else
229 {
230 if (GetLastError() != NO_ERROR)
231 {
232 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
0ea86a10 233 PerlIO_save_errno(f);
a8c08ecd
NIS
234 return -1;
235 }
236 else
237 {
238 if (count != 0)
239 PerlIOBase(f)->flags |= PERLIO_F_EOF;
240 return 0;
241 }
242 }
243}
244
245SSize_t
5833650d 246PerlIOWin32_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
a8c08ecd
NIS
247{
248 PerlIOWin32 *s = PerlIOSelf(f,PerlIOWin32);
249 DWORD len;
0c4128ad 250 if (WriteFile(s->h,vbuf,count,&len,NULL))
a8c08ecd
NIS
251 {
252 return len;
253 }
254 else
255 {
256 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
0ea86a10 257 PerlIO_save_errno(f);
a8c08ecd
NIS
258 return -1;
259 }
260}
261
262IV
5833650d 263PerlIOWin32_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
a8c08ecd
NIS
264{
265 static const DWORD where[3] = { FILE_BEGIN, FILE_CURRENT, FILE_END };
266 PerlIOWin32 *s = PerlIOSelf(f,PerlIOWin32);
3caf316a
SH
267#if Off_t_size >= 8
268 DWORD high = (DWORD)(offset >> 32);
269#else
270 DWORD high = 0;
271#endif
a8c08ecd 272 DWORD low = (DWORD) offset;
8d3a710f 273 DWORD res = SetFilePointer(s->h,(LONG)low,(LONG *)&high,where[whence]);
a8c08ecd
NIS
274 if (res != 0xFFFFFFFF || GetLastError() != NO_ERROR)
275 {
276 return 0;
277 }
278 else
279 {
280 return -1;
281 }
282}
283
284Off_t
5833650d 285PerlIOWin32_tell(pTHX_ PerlIO *f)
a8c08ecd
NIS
286{
287 PerlIOWin32 *s = PerlIOSelf(f,PerlIOWin32);
288 DWORD high = 0;
8d3a710f 289 DWORD res = SetFilePointer(s->h,0,(LONG *)&high,FILE_CURRENT);
a8c08ecd
NIS
290 if (res != 0xFFFFFFFF || GetLastError() != NO_ERROR)
291 {
3caf316a 292#if Off_t_size >= 8
a8c08ecd 293 return ((Off_t) high << 32) | res;
3caf316a
SH
294#else
295 return res;
296#endif
a8c08ecd
NIS
297 }
298 return (Off_t) -1;
299}
300
301IV
5833650d 302PerlIOWin32_close(pTHX_ PerlIO *f)
a8c08ecd
NIS
303{
304 PerlIOWin32 *s = PerlIOSelf(f,PerlIOWin32);
305 if (s->refcnt == 1)
306 {
86e05cf2 307 IV code = 0;
755e7759 308#if 0
86e05cf2 309 /* This does not do pipes etc. correctly */
755e7759 310 if (!CloseHandle(s->h))
a8c08ecd
NIS
311 {
312 s->h = INVALID_HANDLE_VALUE;
313 return -1;
314 }
755e7759
NIS
315#else
316 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
317 return win32_close(s->fd);
318#endif
a8c08ecd 319 }
a8c08ecd
NIS
320 return 0;
321}
322
8cf8f3d1 323PerlIO *
af9603a6 324PerlIOWin32_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *params, int flags)
8cf8f3d1 325{
aa98ed8a
NIS
326 PerlIOWin32 *os = PerlIOSelf(f,PerlIOWin32);
327 HANDLE proc = GetCurrentProcess();
f76b679e
SH
328 HANDLE new_h;
329 if (DuplicateHandle(proc, os->h, proc, &new_h, 0, FALSE, DUPLICATE_SAME_ACCESS))
aa98ed8a
NIS
330 {
331 char mode[8];
f76b679e 332 int fd = win32_open_osfhandle((intptr_t) new_h, PerlIOUnix_oflags(PerlIO_modestr(o,mode)));
86e05cf2 333 if (fd >= 0)
aa98ed8a 334 {
af9603a6 335 f = PerlIOBase_dup(aTHX_ f, o, params, flags);
86e05cf2 336 if (f)
aa98ed8a
NIS
337 {
338 PerlIOWin32 *fs = PerlIOSelf(f,PerlIOWin32);
f76b679e 339 fs->h = new_h;
aa98ed8a
NIS
340 fs->fd = fd;
341 fs->refcnt = 1;
342 fdtable[fd] = fs;
343 if (fd > max_open_fd)
344 max_open_fd = fd;
345 }
346 else
347 {
348 win32_close(fd);
349 }
350 }
351 else
352 {
f76b679e 353 CloseHandle(new_h);
aa98ed8a
NIS
354 }
355 }
356 return f;
8cf8f3d1
NIS
357}
358
27da23d5 359PERLIO_FUNCS_DECL(PerlIO_win32) = {
2dc2558e 360 sizeof(PerlIO_funcs),
a8c08ecd
NIS
361 "win32",
362 sizeof(PerlIOWin32),
363 PERLIO_K_RAW,
364 PerlIOWin32_pushed,
365 PerlIOWin32_popped,
366 PerlIOWin32_open,
86e05cf2 367 PerlIOBase_binmode,
a8c08ecd
NIS
368 NULL, /* getarg */
369 PerlIOWin32_fileno,
8cf8f3d1 370 PerlIOWin32_dup,
a8c08ecd
NIS
371 PerlIOWin32_read,
372 PerlIOBase_unread,
373 PerlIOWin32_write,
374 PerlIOWin32_seek,
375 PerlIOWin32_tell,
376 PerlIOWin32_close,
377 PerlIOBase_noop_ok, /* flush */
378 PerlIOBase_noop_fail, /* fill */
379 PerlIOBase_eof,
380 PerlIOBase_error,
381 PerlIOBase_clearerr,
382 PerlIOBase_setlinebuf,
383 NULL, /* get_base */
384 NULL, /* get_bufsiz */
385 NULL, /* get_ptr */
386 NULL, /* get_cnt */
387 NULL, /* set_ptrcnt */
388};
389
57143e73 390#endif
5833650d 391