This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Work in progress UNIX-side edit of win32 PerLIO layer
[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"
13#include "perllio.h"
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 }
134 if (*mode || oflags == -1)
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)
145 h = CreateFile(path,access,share = OPEN_ALWAYS,NULL,create,attr,NULL);
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 }
163 if (*mode == 'I')
164 {
165 mode++;
166 switch(fd)
167 {
168 case 0:
169 h = GetStandardHandle(STD_INPUT_HANDLE);
170 break;
171 case 1:
172 h = GetStandardHandle(STD_OUTPUT_HANDLE);
173 break;
174 case 2:
175 h = GetStandardHandle(STD_ERROR_HANDLE);
176 break;
177 }
178 }
179 }
180 }
181 if (h != INVALID_HANDLE_VALUE)
182 {
183 PerlIOWin32 *s;
184 if (!f)
185 f = PerlIO_allocate(aTHX);
186 s = PerlIOSelf(PerlIO_push(aTHX_ f,self,tmode,PerlIOArg),PerlIOWin32);
187 s->ioh = h;
188 s->refcnt = 1;
189 return f;
190 }
191 if (f)
192 {
193 /* FIXME: pop layers ??? */
194 }
195 return NULL;
196}
197
198SSize_t
199PerlIOWin32_read(PerlIO *f, void *vbuf, Size_t count)
200{
201 PerlIOWin32 *s = PerlIOSelf(f,PerlIOWin32);
202 DWORD len;
203 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
204 return 0;
205 if (ReadFile(s->h,vbuf,count,&len,NULL)
206 {
207 return len;
208 }
209 else
210 {
211 if (GetLastError() != NO_ERROR)
212 {
213 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
214 return -1;
215 }
216 else
217 {
218 if (count != 0)
219 PerlIOBase(f)->flags |= PERLIO_F_EOF;
220 return 0;
221 }
222 }
223}
224
225SSize_t
226PerlIOWin32_write(PerlIO *f, const void *vbuf, Size_t count)
227{
228 PerlIOWin32 *s = PerlIOSelf(f,PerlIOWin32);
229 DWORD len;
230 if (WriteFile(s->h,vbuf,count,&len,NULL)
231 {
232 return len;
233 }
234 else
235 {
236 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
237 return -1;
238 }
239}
240
241IV
242PerlIOWin32_seek(PerlIO *f, Off_t offset, int whence)
243{
244 static const DWORD where[3] = { FILE_BEGIN, FILE_CURRENT, FILE_END };
245 PerlIOWin32 *s = PerlIOSelf(f,PerlIOWin32);
246 DWORD high = (sizeof(offset) > sizeof(DWORD)) ? (DWORD)(offset >> 32) : 0;
247 DWORD low = (DWORD) offset;
248 DWORD res = SetFilePointer(s->h,low,&high,where[whence]);
249 if (res != 0xFFFFFFFF || GetLastError() != NO_ERROR)
250 {
251 return 0;
252 }
253 else
254 {
255 return -1;
256 }
257}
258
259Off_t
260PerlIOWin32_tell(PerlIO *f)
261{
262 PerlIOWin32 *s = PerlIOSelf(f,PerlIOWin32);
263 DWORD high = 0;
264 DWORD res = SetFilePointer(s->h,0,&high,FILE_CURRENT);
265 if (res != 0xFFFFFFFF || GetLastError() != NO_ERROR)
266 {
267 return ((Off_t) high << 32) | res;
268 }
269 return (Off_t) -1;
270}
271
272IV
273PerlIOWin32_close(PerlIO *f)
274{
275 PerlIOWin32 *s = PerlIOSelf(f,PerlIOWin32);
276 if (s->refcnt == 1)
277 {
278 if (CloseHandle(s->h))
279 {
280 s->h = INVALID_HANDLE_VALUE;
281 return -1;
282 }
283 }
284 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
285 return 0;
286}
287
288PerlIO_funcs PerlIO_win32 = {
289 "win32",
290 sizeof(PerlIOWin32),
291 PERLIO_K_RAW,
292 PerlIOWin32_pushed,
293 PerlIOWin32_popped,
294 PerlIOWin32_open,
295 NULL, /* getarg */
296 PerlIOWin32_fileno,
297 PerlIOWin32_read,
298 PerlIOBase_unread,
299 PerlIOWin32_write,
300 PerlIOWin32_seek,
301 PerlIOWin32_tell,
302 PerlIOWin32_close,
303 PerlIOBase_noop_ok, /* flush */
304 PerlIOBase_noop_fail, /* fill */
305 PerlIOBase_eof,
306 PerlIOBase_error,
307 PerlIOBase_clearerr,
308 PerlIOBase_setlinebuf,
309 NULL, /* get_base */
310 NULL, /* get_bufsiz */
311 NULL, /* get_ptr */
312 NULL, /* get_cnt */
313 NULL, /* set_ptrcnt */
314};
315
316