This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Following 33291, on VMS we need to use the same prototypes other platforms
[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;
64 return code;
65}
66
67PerlIO *
68PerlIOWin32_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)
69{
70 const char *tmode = mode;
71 HANDLE h = INVALID_HANDLE_VALUE;
72 if (f)
73 {
74 /* Close if already open */
75 if (PerlIOBase(f)->flags & PERLIO_F_OPEN)
5833650d 76 (*PerlIOBase(f)->tab->Close)(aTHX_ f);
a8c08ecd
NIS
77 }
78 if (narg > 0)
79 {
80 char *path = SvPV_nolen(*args);
81 DWORD access = 0;
82 DWORD share = 0;
83 DWORD create = -1;
84 DWORD attr = FILE_ATTRIBUTE_NORMAL;
85 if (*mode == '#')
86 {
87 /* sysopen - imode is UNIX-like O_RDONLY etc.
88 - do_open has converted that back to string form in mode as well
89 - perm is UNIX like permissions
90 */
91 mode++;
92 }
93 else
94 {
95 /* Normal open - decode mode string */
96 }
97 switch(*mode)
98 {
99 case 'r':
100 access = GENERIC_READ;
101 create = OPEN_EXISTING;
102 if (*++mode == '+')
103 {
104 access |= GENERIC_WRITE;
105 create = OPEN_ALWAYS;
106 mode++;
107 }
108 break;
109
110 case 'w':
111 access = GENERIC_WRITE;
112 create = TRUNCATE_EXISTING;
113 if (*++mode == '+')
114 {
115 access |= GENERIC_READ;
116 mode++;
117 }
118 break;
119
120 case 'a':
121 access = GENERIC_WRITE;
122 create = OPEN_ALWAYS;
123 if (*++mode == '+')
124 {
125 access |= GENERIC_READ;
126 mode++;
127 }
128 break;
129 }
130 if (*mode == 'b')
131 {
132 mode++;
133 }
134 else if (*mode == 't')
135 {
136 mode++;
137 }
0c4128ad 138 if (*mode || create == -1)
a8c08ecd
NIS
139 {
140 SETERRNO(EINVAL,LIB$_INVARG);
141 return NULL;
142 }
143 if (!(access & GENERIC_WRITE))
144 share = FILE_SHARE_READ;
145 h = CreateFile(path,access,share,NULL,create,attr,NULL);
146 if (h == INVALID_HANDLE_VALUE)
147 {
148 if (create == TRUNCATE_EXISTING)
0c4128ad 149 h = CreateFile(path,access,share,NULL,(create = OPEN_ALWAYS),attr,NULL);
a8c08ecd
NIS
150 }
151 }
152 else
153 {
154 /* fd open */
155 h = INVALID_HANDLE_VALUE;
156 if (fd >= 0 && fd <= max_open_fd)
157 {
158 PerlIOWin32 *s = fdtable[fd];
159 if (s)
160 {
161 s->refcnt++;
162 if (!f)
163 f = PerlIO_allocate(aTHX);
164 *f = &s->base;
165 return f;
166 }
0c4128ad
NIS
167 }
168 if (*mode == 'I')
169 {
170 mode++;
171 switch(fd)
a8c08ecd 172 {
0c4128ad
NIS
173 case 0:
174 h = GetStdHandle(STD_INPUT_HANDLE);
175 break;
176 case 1:
177 h = GetStdHandle(STD_OUTPUT_HANDLE);
178 break;
179 case 2:
180 h = GetStdHandle(STD_ERROR_HANDLE);
181 break;
a8c08ecd
NIS
182 }
183 }
184 }
185 if (h != INVALID_HANDLE_VALUE)
c623ac67 186 fd = win32_open_osfhandle((intptr_t) h, PerlIOUnix_oflags(tmode));
0c4128ad 187 if (fd >= 0)
a8c08ecd
NIS
188 {
189 PerlIOWin32 *s;
190 if (!f)
191 f = PerlIO_allocate(aTHX);
192 s = PerlIOSelf(PerlIO_push(aTHX_ f,self,tmode,PerlIOArg),PerlIOWin32);
0c4128ad
NIS
193 s->h = h;
194 s->fd = fd;
a8c08ecd 195 s->refcnt = 1;
8cf8f3d1 196 if (fd >= 0)
0c4128ad 197 {
8cf8f3d1 198 fdtable[fd] = s;
0c4128ad
NIS
199 if (fd > max_open_fd)
200 max_open_fd = fd;
8cf8f3d1 201 }
a8c08ecd
NIS
202 return f;
203 }
204 if (f)
205 {
206 /* FIXME: pop layers ??? */
207 }
208 return NULL;
209}
210
211SSize_t
5833650d 212PerlIOWin32_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
a8c08ecd
NIS
213{
214 PerlIOWin32 *s = PerlIOSelf(f,PerlIOWin32);
215 DWORD len;
216 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
217 return 0;
0c4128ad 218 if (ReadFile(s->h,vbuf,count,&len,NULL))
a8c08ecd
NIS
219 {
220 return len;
221 }
222 else
223 {
224 if (GetLastError() != NO_ERROR)
225 {
226 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
227 return -1;
228 }
229 else
230 {
231 if (count != 0)
232 PerlIOBase(f)->flags |= PERLIO_F_EOF;
233 return 0;
234 }
235 }
236}
237
238SSize_t
5833650d 239PerlIOWin32_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
a8c08ecd
NIS
240{
241 PerlIOWin32 *s = PerlIOSelf(f,PerlIOWin32);
242 DWORD len;
0c4128ad 243 if (WriteFile(s->h,vbuf,count,&len,NULL))
a8c08ecd
NIS
244 {
245 return len;
246 }
247 else
248 {
249 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
250 return -1;
251 }
252}
253
254IV
5833650d 255PerlIOWin32_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
a8c08ecd
NIS
256{
257 static const DWORD where[3] = { FILE_BEGIN, FILE_CURRENT, FILE_END };
258 PerlIOWin32 *s = PerlIOSelf(f,PerlIOWin32);
259 DWORD high = (sizeof(offset) > sizeof(DWORD)) ? (DWORD)(offset >> 32) : 0;
260 DWORD low = (DWORD) offset;
8d3a710f 261 DWORD res = SetFilePointer(s->h,(LONG)low,(LONG *)&high,where[whence]);
a8c08ecd
NIS
262 if (res != 0xFFFFFFFF || GetLastError() != NO_ERROR)
263 {
264 return 0;
265 }
266 else
267 {
268 return -1;
269 }
270}
271
272Off_t
5833650d 273PerlIOWin32_tell(pTHX_ PerlIO *f)
a8c08ecd
NIS
274{
275 PerlIOWin32 *s = PerlIOSelf(f,PerlIOWin32);
276 DWORD high = 0;
8d3a710f 277 DWORD res = SetFilePointer(s->h,0,(LONG *)&high,FILE_CURRENT);
a8c08ecd
NIS
278 if (res != 0xFFFFFFFF || GetLastError() != NO_ERROR)
279 {
280 return ((Off_t) high << 32) | res;
281 }
282 return (Off_t) -1;
283}
284
285IV
5833650d 286PerlIOWin32_close(pTHX_ PerlIO *f)
a8c08ecd
NIS
287{
288 PerlIOWin32 *s = PerlIOSelf(f,PerlIOWin32);
289 if (s->refcnt == 1)
290 {
86e05cf2 291 IV code = 0;
755e7759 292#if 0
86e05cf2 293 /* This does not do pipes etc. correctly */
755e7759 294 if (!CloseHandle(s->h))
a8c08ecd
NIS
295 {
296 s->h = INVALID_HANDLE_VALUE;
297 return -1;
298 }
755e7759
NIS
299#else
300 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
301 return win32_close(s->fd);
302#endif
a8c08ecd 303 }
a8c08ecd
NIS
304 return 0;
305}
306
8cf8f3d1 307PerlIO *
af9603a6 308PerlIOWin32_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *params, int flags)
8cf8f3d1 309{
aa98ed8a
NIS
310 PerlIOWin32 *os = PerlIOSelf(f,PerlIOWin32);
311 HANDLE proc = GetCurrentProcess();
86e05cf2 312 HANDLE new;
aa98ed8a
NIS
313 if (DuplicateHandle(proc, os->h, proc, &new, 0, FALSE, DUPLICATE_SAME_ACCESS))
314 {
315 char mode[8];
c623ac67 316 int fd = win32_open_osfhandle((intptr_t) new, PerlIOUnix_oflags(PerlIO_modestr(o,mode)));
86e05cf2 317 if (fd >= 0)
aa98ed8a 318 {
af9603a6 319 f = PerlIOBase_dup(aTHX_ f, o, params, flags);
86e05cf2 320 if (f)
aa98ed8a
NIS
321 {
322 PerlIOWin32 *fs = PerlIOSelf(f,PerlIOWin32);
323 fs->h = new;
324 fs->fd = fd;
325 fs->refcnt = 1;
326 fdtable[fd] = fs;
327 if (fd > max_open_fd)
328 max_open_fd = fd;
329 }
330 else
331 {
332 win32_close(fd);
333 }
334 }
335 else
336 {
337 CloseHandle(new);
338 }
339 }
340 return f;
8cf8f3d1
NIS
341}
342
27da23d5 343PERLIO_FUNCS_DECL(PerlIO_win32) = {
2dc2558e 344 sizeof(PerlIO_funcs),
a8c08ecd
NIS
345 "win32",
346 sizeof(PerlIOWin32),
347 PERLIO_K_RAW,
348 PerlIOWin32_pushed,
349 PerlIOWin32_popped,
350 PerlIOWin32_open,
86e05cf2 351 PerlIOBase_binmode,
a8c08ecd
NIS
352 NULL, /* getarg */
353 PerlIOWin32_fileno,
8cf8f3d1 354 PerlIOWin32_dup,
a8c08ecd
NIS
355 PerlIOWin32_read,
356 PerlIOBase_unread,
357 PerlIOWin32_write,
358 PerlIOWin32_seek,
359 PerlIOWin32_tell,
360 PerlIOWin32_close,
361 PerlIOBase_noop_ok, /* flush */
362 PerlIOBase_noop_fail, /* fill */
363 PerlIOBase_eof,
364 PerlIOBase_error,
365 PerlIOBase_clearerr,
366 PerlIOBase_setlinebuf,
367 NULL, /* get_base */
368 NULL, /* get_bufsiz */
369 NULL, /* get_ptr */
370 NULL, /* get_cnt */
371 NULL, /* set_ptrcnt */
372};
373
57143e73 374#endif
5833650d 375