Commit | Line | Data |
---|---|---|
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 | ||
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 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 | ||
48 | IV | |
5833650d | 49 | PerlIOWin32_fileno(pTHX_ PerlIO *f) |
a8c08ecd NIS |
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 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_ | |
66 | packWARN(WARN_EXPERIMENTAL__WIN32_PERLIO), | |
67 | "PerlIO layer ':win32' is experimental"); | |
68 | ||
a8c08ecd NIS |
69 | return code; |
70 | } | |
71 | ||
72 | PerlIO * | |
73 | 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) | |
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 | ||
217 | SSize_t | |
5833650d | 218 | PerlIOWin32_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 | ||
245 | SSize_t | |
5833650d | 246 | PerlIOWin32_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 | ||
262 | IV | |
5833650d | 263 | PerlIOWin32_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 | ||
284 | Off_t | |
5833650d | 285 | PerlIOWin32_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 | ||
301 | IV | |
5833650d | 302 | PerlIOWin32_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 | 323 | PerlIO * |
af9603a6 | 324 | PerlIOWin32_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 | 359 | PERLIO_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 |