This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Fix gross win32 build issues
[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"
0c4128ad 13#include "perliol.h"
a8c08ecd
NIS
14
15#define NO_XSLOCKS
16#include "XSUB.h"
17
18/* Bottom-most level for Win32 case */
19
20typedef struct
21{
22 struct _PerlIO base; /* The generic part */
23 HANDLE h; /* OS level handle */
24 IV refcnt; /* REFCNT for the "fd" this represents */
25 int fd; /* UNIX like file descriptor - index into fdtable */
26} PerlIOWin32;
27
28PerlIOWin32 *fdtable[256];
29IV max_open_fd = -1;
30
31IV
32PerlIOWin32_popped(PerlIO *f)
33{
34 PerlIOWin32 *s = PerlIOSelf(f,PerlIOWin32);
35 if (--s->refcnt > 0)
36 {
37 *f = PerlIOBase(f)->next;
38 return 1;
39 }
40 fdtable[s->fd] = NULL;
41 return 0;
42}
43
44IV
45PerlIOWin32_fileno(PerlIO *f)
46{
47 return PerlIOSelf(f,PerlIOWin32)->fd;
48}
49
50IV
51PerlIOWin32_pushed(PerlIO *f, const char *mode, SV *arg)
52{
53 IV code = PerlIOBase_pushed(f,mode,arg);
54 if (*PerlIONext(f))
55 {
56 PerlIOWin32 *s = PerlIOSelf(f,PerlIOWin32);
57 s->fd = PerlIO_fileno(PerlIONext(f));
58 }
59 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
60 return code;
61}
62
63PerlIO *
64PerlIOWin32_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)
65{
66 const char *tmode = mode;
67 HANDLE h = INVALID_HANDLE_VALUE;
68 if (f)
69 {
70 /* Close if already open */
71 if (PerlIOBase(f)->flags & PERLIO_F_OPEN)
72 (*PerlIOBase(f)->tab->Close)(f);
73 }
74 if (narg > 0)
75 {
76 char *path = SvPV_nolen(*args);
77 DWORD access = 0;
78 DWORD share = 0;
79 DWORD create = -1;
80 DWORD attr = FILE_ATTRIBUTE_NORMAL;
81 if (*mode == '#')
82 {
83 /* sysopen - imode is UNIX-like O_RDONLY etc.
84 - do_open has converted that back to string form in mode as well
85 - perm is UNIX like permissions
86 */
87 mode++;
88 }
89 else
90 {
91 /* Normal open - decode mode string */
92 }
93 switch(*mode)
94 {
95 case 'r':
96 access = GENERIC_READ;
97 create = OPEN_EXISTING;
98 if (*++mode == '+')
99 {
100 access |= GENERIC_WRITE;
101 create = OPEN_ALWAYS;
102 mode++;
103 }
104 break;
105
106 case 'w':
107 access = GENERIC_WRITE;
108 create = TRUNCATE_EXISTING;
109 if (*++mode == '+')
110 {
111 access |= GENERIC_READ;
112 mode++;
113 }
114 break;
115
116 case 'a':
117 access = GENERIC_WRITE;
118 create = OPEN_ALWAYS;
119 if (*++mode == '+')
120 {
121 access |= GENERIC_READ;
122 mode++;
123 }
124 break;
125 }
126 if (*mode == 'b')
127 {
128 mode++;
129 }
130 else if (*mode == 't')
131 {
132 mode++;
133 }
0c4128ad 134 if (*mode || create == -1)
a8c08ecd
NIS
135 {
136 SETERRNO(EINVAL,LIB$_INVARG);
137 return NULL;
138 }
139 if (!(access & GENERIC_WRITE))
140 share = FILE_SHARE_READ;
141 h = CreateFile(path,access,share,NULL,create,attr,NULL);
142 if (h == INVALID_HANDLE_VALUE)
143 {
144 if (create == TRUNCATE_EXISTING)
0c4128ad 145 h = CreateFile(path,access,share,NULL,(create = OPEN_ALWAYS),attr,NULL);
a8c08ecd
NIS
146 }
147 }
148 else
149 {
150 /* fd open */
151 h = INVALID_HANDLE_VALUE;
152 if (fd >= 0 && fd <= max_open_fd)
153 {
154 PerlIOWin32 *s = fdtable[fd];
155 if (s)
156 {
157 s->refcnt++;
158 if (!f)
159 f = PerlIO_allocate(aTHX);
160 *f = &s->base;
161 return f;
162 }
0c4128ad
NIS
163 }
164 if (*mode == 'I')
165 {
166 mode++;
167 switch(fd)
a8c08ecd 168 {
0c4128ad
NIS
169 case 0:
170 h = GetStdHandle(STD_INPUT_HANDLE);
171 break;
172 case 1:
173 h = GetStdHandle(STD_OUTPUT_HANDLE);
174 break;
175 case 2:
176 h = GetStdHandle(STD_ERROR_HANDLE);
177 break;
a8c08ecd
NIS
178 }
179 }
180 }
181 if (h != INVALID_HANDLE_VALUE)
0c4128ad
NIS
182 fd = win32_open_osfhandle((long) h, PerlIOUnix_oflags(tmode));
183 if (fd >= 0)
a8c08ecd
NIS
184 {
185 PerlIOWin32 *s;
186 if (!f)
187 f = PerlIO_allocate(aTHX);
188 s = PerlIOSelf(PerlIO_push(aTHX_ f,self,tmode,PerlIOArg),PerlIOWin32);
0c4128ad
NIS
189 s->h = h;
190 s->fd = fd;
a8c08ecd 191 s->refcnt = 1;
8cf8f3d1 192 if (fd >= 0)
0c4128ad 193 {
8cf8f3d1 194 fdtable[fd] = s;
0c4128ad
NIS
195 if (fd > max_open_fd)
196 max_open_fd = fd;
8cf8f3d1 197 }
a8c08ecd
NIS
198 return f;
199 }
200 if (f)
201 {
202 /* FIXME: pop layers ??? */
203 }
204 return NULL;
205}
206
207SSize_t
208PerlIOWin32_read(PerlIO *f, void *vbuf, Size_t count)
209{
210 PerlIOWin32 *s = PerlIOSelf(f,PerlIOWin32);
211 DWORD len;
212 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
213 return 0;
0c4128ad 214 if (ReadFile(s->h,vbuf,count,&len,NULL))
a8c08ecd
NIS
215 {
216 return len;
217 }
218 else
219 {
220 if (GetLastError() != NO_ERROR)
221 {
222 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
223 return -1;
224 }
225 else
226 {
227 if (count != 0)
228 PerlIOBase(f)->flags |= PERLIO_F_EOF;
229 return 0;
230 }
231 }
232}
233
234SSize_t
235PerlIOWin32_write(PerlIO *f, const void *vbuf, Size_t count)
236{
237 PerlIOWin32 *s = PerlIOSelf(f,PerlIOWin32);
238 DWORD len;
0c4128ad 239 if (WriteFile(s->h,vbuf,count,&len,NULL))
a8c08ecd
NIS
240 {
241 return len;
242 }
243 else
244 {
245 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
246 return -1;
247 }
248}
249
250IV
251PerlIOWin32_seek(PerlIO *f, Off_t offset, int whence)
252{
253 static const DWORD where[3] = { FILE_BEGIN, FILE_CURRENT, FILE_END };
254 PerlIOWin32 *s = PerlIOSelf(f,PerlIOWin32);
255 DWORD high = (sizeof(offset) > sizeof(DWORD)) ? (DWORD)(offset >> 32) : 0;
256 DWORD low = (DWORD) offset;
257 DWORD res = SetFilePointer(s->h,low,&high,where[whence]);
258 if (res != 0xFFFFFFFF || GetLastError() != NO_ERROR)
259 {
260 return 0;
261 }
262 else
263 {
264 return -1;
265 }
266}
267
268Off_t
269PerlIOWin32_tell(PerlIO *f)
270{
271 PerlIOWin32 *s = PerlIOSelf(f,PerlIOWin32);
272 DWORD high = 0;
273 DWORD res = SetFilePointer(s->h,0,&high,FILE_CURRENT);
274 if (res != 0xFFFFFFFF || GetLastError() != NO_ERROR)
275 {
276 return ((Off_t) high << 32) | res;
277 }
278 return (Off_t) -1;
279}
280
281IV
282PerlIOWin32_close(PerlIO *f)
283{
284 PerlIOWin32 *s = PerlIOSelf(f,PerlIOWin32);
285 if (s->refcnt == 1)
286 {
287 if (CloseHandle(s->h))
288 {
289 s->h = INVALID_HANDLE_VALUE;
290 return -1;
291 }
292 }
293 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
294 return 0;
295}
296
8cf8f3d1
NIS
297PerlIO *
298PerlIOWin32_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *params)
299{
300 /* Almost certainly needs more work */
301 return PerlIOBase_dup(aTHX_ f, o, params);
302}
303
a8c08ecd
NIS
304PerlIO_funcs PerlIO_win32 = {
305 "win32",
306 sizeof(PerlIOWin32),
307 PERLIO_K_RAW,
308 PerlIOWin32_pushed,
309 PerlIOWin32_popped,
310 PerlIOWin32_open,
311 NULL, /* getarg */
312 PerlIOWin32_fileno,
8cf8f3d1 313 PerlIOWin32_dup,
a8c08ecd
NIS
314 PerlIOWin32_read,
315 PerlIOBase_unread,
316 PerlIOWin32_write,
317 PerlIOWin32_seek,
318 PerlIOWin32_tell,
319 PerlIOWin32_close,
320 PerlIOBase_noop_ok, /* flush */
321 PerlIOBase_noop_fail, /* fill */
322 PerlIOBase_eof,
323 PerlIOBase_error,
324 PerlIOBase_clearerr,
325 PerlIOBase_setlinebuf,
326 NULL, /* get_base */
327 NULL, /* get_bufsiz */
328 NULL, /* get_ptr */
329 NULL, /* get_cnt */
330 NULL, /* set_ptrcnt */
331};
332
333