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; | |
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 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 | ||
211 | SSize_t | |
5833650d | 212 | PerlIOWin32_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 | ||
238 | SSize_t | |
5833650d | 239 | PerlIOWin32_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 | ||
254 | IV | |
5833650d | 255 | PerlIOWin32_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); | |
3caf316a SH |
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 NIS |
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 NIS |
278 | { |
279 | PerlIOWin32 *s = PerlIOSelf(f,PerlIOWin32); | |
280 | DWORD high = 0; | |
8d3a710f | 281 | DWORD res = SetFilePointer(s->h,0,(LONG *)&high,FILE_CURRENT); |
a8c08ecd NIS |
282 | if (res != 0xFFFFFFFF || GetLastError() != NO_ERROR) |
283 | { | |
3caf316a | 284 | #if Off_t_size >= 8 |
a8c08ecd | 285 | return ((Off_t) high << 32) | res; |
3caf316a SH |
286 | #else |
287 | return res; | |
288 | #endif | |
a8c08ecd NIS |
289 | } |
290 | return (Off_t) -1; | |
291 | } | |
292 | ||
293 | IV | |
5833650d | 294 | PerlIOWin32_close(pTHX_ PerlIO *f) |
a8c08ecd NIS |
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 NIS |
303 | { |
304 | s->h = INVALID_HANDLE_VALUE; | |
305 | return -1; | |
306 | } | |
755e7759 NIS |
307 | #else |
308 | PerlIOBase(f)->flags &= ~PERLIO_F_OPEN; | |
309 | return win32_close(s->fd); | |
310 | #endif | |
a8c08ecd | 311 | } |
a8c08ecd NIS |
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 NIS |
318 | PerlIOWin32 *os = PerlIOSelf(f,PerlIOWin32); |
319 | HANDLE proc = GetCurrentProcess(); | |
86e05cf2 | 320 | HANDLE new; |
aa98ed8a NIS |
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 NIS |
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 NIS |
349 | } |
350 | ||
27da23d5 | 351 | PERLIO_FUNCS_DECL(PerlIO_win32) = { |
2dc2558e | 352 | sizeof(PerlIO_funcs), |
a8c08ecd NIS |
353 | "win32", |
354 | sizeof(PerlIOWin32), | |
355 | PERLIO_K_RAW, | |
356 | PerlIOWin32_pushed, | |
357 | PerlIOWin32_popped, | |
358 | PerlIOWin32_open, | |
86e05cf2 | 359 | PerlIOBase_binmode, |
a8c08ecd NIS |
360 | NULL, /* getarg */ |
361 | PerlIOWin32_fileno, | |
8cf8f3d1 | 362 | PerlIOWin32_dup, |
a8c08ecd NIS |
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 |