Commit | Line | Data |
a8c08ecd |
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 |
13 | |
14 | #ifdef PERLIO_LAYERS |
15 | |
0c4128ad |
16 | #include "perliol.h" |
a8c08ecd |
17 | |
18 | #define NO_XSLOCKS |
19 | #include "XSUB.h" |
20 | |
57143e73 |
21 | |
a8c08ecd |
22 | /* Bottom-most level for Win32 case */ |
23 | |
24 | typedef 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 | |
32 | PerlIOWin32 *fdtable[256]; |
33 | IV max_open_fd = -1; |
34 | |
35 | IV |
5833650d |
36 | PerlIOWin32_popped(pTHX_ PerlIO *f) |
a8c08ecd |
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 | |
48 | IV |
5833650d |
49 | PerlIOWin32_fileno(pTHX_ PerlIO *f) |
a8c08ecd |
50 | { |
51 | return PerlIOSelf(f,PerlIOWin32)->fd; |
52 | } |
53 | |
54 | IV |
2dc2558e |
55 | PerlIOWin32_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 |
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 | |
67 | PerlIO * |
68 | PerlIOWin32_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 |
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 |
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 |
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 |
167 | } |
168 | if (*mode == 'I') |
169 | { |
170 | mode++; |
171 | switch(fd) |
a8c08ecd |
172 | { |
0c4128ad |
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 |
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 |
188 | { |
189 | PerlIOWin32 *s; |
190 | if (!f) |
191 | f = PerlIO_allocate(aTHX); |
192 | s = PerlIOSelf(PerlIO_push(aTHX_ f,self,tmode,PerlIOArg),PerlIOWin32); |
0c4128ad |
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 |
199 | if (fd > max_open_fd) |
200 | max_open_fd = fd; |
8cf8f3d1 |
201 | } |
a8c08ecd |
202 | return f; |
203 | } |
204 | if (f) |
205 | { |
206 | /* FIXME: pop layers ??? */ |
207 | } |
208 | return NULL; |
209 | } |
210 | |
211 | SSize_t |
5833650d |
212 | PerlIOWin32_read(pTHX_ PerlIO *f, void *vbuf, Size_t count) |
a8c08ecd |
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 |
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 | |
238 | SSize_t |
5833650d |
239 | PerlIOWin32_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count) |
a8c08ecd |
240 | { |
241 | PerlIOWin32 *s = PerlIOSelf(f,PerlIOWin32); |
242 | DWORD len; |
0c4128ad |
243 | if (WriteFile(s->h,vbuf,count,&len,NULL)) |
a8c08ecd |
244 | { |
245 | return len; |
246 | } |
247 | else |
248 | { |
249 | PerlIOBase(f)->flags |= PERLIO_F_ERROR; |
250 | return -1; |
251 | } |
252 | } |
253 | |
254 | IV |
5833650d |
255 | PerlIOWin32_seek(pTHX_ PerlIO *f, Off_t offset, int whence) |
a8c08ecd |
256 | { |
257 | static const DWORD where[3] = { FILE_BEGIN, FILE_CURRENT, FILE_END }; |
258 | PerlIOWin32 *s = PerlIOSelf(f,PerlIOWin32); |
3caf316a |
259 | #if Off_t_size >= 8 |
260 | DWORD high = (DWORD)(offset >> 32); |
261 | #else |
262 | DWORD high = 0; |
263 | #endif |
a8c08ecd |
264 | DWORD low = (DWORD) offset; |
8d3a710f |
265 | DWORD res = SetFilePointer(s->h,(LONG)low,(LONG *)&high,where[whence]); |
a8c08ecd |
266 | if (res != 0xFFFFFFFF || GetLastError() != NO_ERROR) |
267 | { |
268 | return 0; |
269 | } |
270 | else |
271 | { |
272 | return -1; |
273 | } |
274 | } |
275 | |
276 | Off_t |
5833650d |
277 | PerlIOWin32_tell(pTHX_ PerlIO *f) |
a8c08ecd |
278 | { |
279 | PerlIOWin32 *s = PerlIOSelf(f,PerlIOWin32); |
280 | DWORD high = 0; |
8d3a710f |
281 | DWORD res = SetFilePointer(s->h,0,(LONG *)&high,FILE_CURRENT); |
a8c08ecd |
282 | if (res != 0xFFFFFFFF || GetLastError() != NO_ERROR) |
283 | { |
3caf316a |
284 | #if Off_t_size >= 8 |
a8c08ecd |
285 | return ((Off_t) high << 32) | res; |
3caf316a |
286 | #else |
287 | return res; |
288 | #endif |
a8c08ecd |
289 | } |
290 | return (Off_t) -1; |
291 | } |
292 | |
293 | IV |
5833650d |
294 | PerlIOWin32_close(pTHX_ PerlIO *f) |
a8c08ecd |
295 | { |
296 | PerlIOWin32 *s = PerlIOSelf(f,PerlIOWin32); |
297 | if (s->refcnt == 1) |
298 | { |
86e05cf2 |
299 | IV code = 0; |
755e7759 |
300 | #if 0 |
86e05cf2 |
301 | /* This does not do pipes etc. correctly */ |
755e7759 |
302 | if (!CloseHandle(s->h)) |
a8c08ecd |
303 | { |
304 | s->h = INVALID_HANDLE_VALUE; |
305 | return -1; |
306 | } |
755e7759 |
307 | #else |
308 | PerlIOBase(f)->flags &= ~PERLIO_F_OPEN; |
309 | return win32_close(s->fd); |
310 | #endif |
a8c08ecd |
311 | } |
a8c08ecd |
312 | return 0; |
313 | } |
314 | |
8cf8f3d1 |
315 | PerlIO * |
af9603a6 |
316 | PerlIOWin32_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *params, int flags) |
8cf8f3d1 |
317 | { |
aa98ed8a |
318 | PerlIOWin32 *os = PerlIOSelf(f,PerlIOWin32); |
319 | HANDLE proc = GetCurrentProcess(); |
86e05cf2 |
320 | HANDLE new; |
aa98ed8a |
321 | if (DuplicateHandle(proc, os->h, proc, &new, 0, FALSE, DUPLICATE_SAME_ACCESS)) |
322 | { |
323 | char mode[8]; |
c623ac67 |
324 | int fd = win32_open_osfhandle((intptr_t) new, PerlIOUnix_oflags(PerlIO_modestr(o,mode))); |
86e05cf2 |
325 | if (fd >= 0) |
aa98ed8a |
326 | { |
af9603a6 |
327 | f = PerlIOBase_dup(aTHX_ f, o, params, flags); |
86e05cf2 |
328 | if (f) |
aa98ed8a |
329 | { |
330 | PerlIOWin32 *fs = PerlIOSelf(f,PerlIOWin32); |
331 | fs->h = new; |
332 | fs->fd = fd; |
333 | fs->refcnt = 1; |
334 | fdtable[fd] = fs; |
335 | if (fd > max_open_fd) |
336 | max_open_fd = fd; |
337 | } |
338 | else |
339 | { |
340 | win32_close(fd); |
341 | } |
342 | } |
343 | else |
344 | { |
345 | CloseHandle(new); |
346 | } |
347 | } |
348 | return f; |
8cf8f3d1 |
349 | } |
350 | |
27da23d5 |
351 | PERLIO_FUNCS_DECL(PerlIO_win32) = { |
2dc2558e |
352 | sizeof(PerlIO_funcs), |
a8c08ecd |
353 | "win32", |
354 | sizeof(PerlIOWin32), |
355 | PERLIO_K_RAW, |
356 | PerlIOWin32_pushed, |
357 | PerlIOWin32_popped, |
358 | PerlIOWin32_open, |
86e05cf2 |
359 | PerlIOBase_binmode, |
a8c08ecd |
360 | NULL, /* getarg */ |
361 | PerlIOWin32_fileno, |
8cf8f3d1 |
362 | PerlIOWin32_dup, |
a8c08ecd |
363 | PerlIOWin32_read, |
364 | PerlIOBase_unread, |
365 | PerlIOWin32_write, |
366 | PerlIOWin32_seek, |
367 | PerlIOWin32_tell, |
368 | PerlIOWin32_close, |
369 | PerlIOBase_noop_ok, /* flush */ |
370 | PerlIOBase_noop_fail, /* fill */ |
371 | PerlIOBase_eof, |
372 | PerlIOBase_error, |
373 | PerlIOBase_clearerr, |
374 | PerlIOBase_setlinebuf, |
375 | NULL, /* get_base */ |
376 | NULL, /* get_bufsiz */ |
377 | NULL, /* get_ptr */ |
378 | NULL, /* get_cnt */ |
379 | NULL, /* set_ptrcnt */ |
380 | }; |
381 | |
57143e73 |
382 | #endif |
5833650d |
383 | |