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" | |
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 | ||
20 | typedef 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 | ||
28 | PerlIOWin32 *fdtable[256]; | |
29 | IV max_open_fd = -1; | |
30 | ||
31 | IV | |
5833650d | 32 | PerlIOWin32_popped(pTHX_ PerlIO *f) |
a8c08ecd NIS |
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 | ||
44 | IV | |
5833650d | 45 | PerlIOWin32_fileno(pTHX_ PerlIO *f) |
a8c08ecd NIS |
46 | { |
47 | return PerlIOSelf(f,PerlIOWin32)->fd; | |
48 | } | |
49 | ||
50 | IV | |
5833650d | 51 | PerlIOWin32_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg) |
a8c08ecd | 52 | { |
5833650d | 53 | IV code = PerlIOBase_pushed(aTHX_ f,mode,arg); |
a8c08ecd NIS |
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 | ||
63 | PerlIO * | |
64 | 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) | |
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) | |
5833650d | 72 | (*PerlIOBase(f)->tab->Close)(aTHX_ f); |
a8c08ecd NIS |
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 | ||
207 | SSize_t | |
5833650d | 208 | PerlIOWin32_read(pTHX_ PerlIO *f, void *vbuf, Size_t count) |
a8c08ecd NIS |
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 | ||
234 | SSize_t | |
5833650d | 235 | PerlIOWin32_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count) |
a8c08ecd NIS |
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 | ||
250 | IV | |
5833650d | 251 | PerlIOWin32_seek(pTHX_ PerlIO *f, Off_t offset, int whence) |
a8c08ecd NIS |
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 | ||
268 | Off_t | |
5833650d | 269 | PerlIOWin32_tell(pTHX_ PerlIO *f) |
a8c08ecd NIS |
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 | ||
281 | IV | |
5833650d | 282 | PerlIOWin32_close(pTHX_ PerlIO *f) |
a8c08ecd NIS |
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 | 297 | PerlIO * |
af9603a6 | 298 | PerlIOWin32_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *params, int flags) |
8cf8f3d1 | 299 | { |
aa98ed8a NIS |
300 | PerlIOWin32 *os = PerlIOSelf(f,PerlIOWin32); |
301 | HANDLE proc = GetCurrentProcess(); | |
302 | HANDLE new; | |
303 | if (DuplicateHandle(proc, os->h, proc, &new, 0, FALSE, DUPLICATE_SAME_ACCESS)) | |
304 | { | |
305 | char mode[8]; | |
306 | int fd = win32_open_osfhandle((long) new, PerlIOUnix_oflags(PerlIO_modestr(o,mode))); | |
307 | if (fd >= 0) | |
308 | { | |
af9603a6 | 309 | f = PerlIOBase_dup(aTHX_ f, o, params, flags); |
aa98ed8a NIS |
310 | if (f) |
311 | { | |
312 | PerlIOWin32 *fs = PerlIOSelf(f,PerlIOWin32); | |
313 | fs->h = new; | |
314 | fs->fd = fd; | |
315 | fs->refcnt = 1; | |
316 | fdtable[fd] = fs; | |
317 | if (fd > max_open_fd) | |
318 | max_open_fd = fd; | |
319 | } | |
320 | else | |
321 | { | |
322 | win32_close(fd); | |
323 | } | |
324 | } | |
325 | else | |
326 | { | |
327 | CloseHandle(new); | |
328 | } | |
329 | } | |
330 | return f; | |
8cf8f3d1 NIS |
331 | } |
332 | ||
a8c08ecd NIS |
333 | PerlIO_funcs PerlIO_win32 = { |
334 | "win32", | |
335 | sizeof(PerlIOWin32), | |
336 | PERLIO_K_RAW, | |
337 | PerlIOWin32_pushed, | |
338 | PerlIOWin32_popped, | |
339 | PerlIOWin32_open, | |
340 | NULL, /* getarg */ | |
341 | PerlIOWin32_fileno, | |
8cf8f3d1 | 342 | PerlIOWin32_dup, |
a8c08ecd NIS |
343 | PerlIOWin32_read, |
344 | PerlIOBase_unread, | |
345 | PerlIOWin32_write, | |
346 | PerlIOWin32_seek, | |
347 | PerlIOWin32_tell, | |
348 | PerlIOWin32_close, | |
349 | PerlIOBase_noop_ok, /* flush */ | |
350 | PerlIOBase_noop_fail, /* fill */ | |
351 | PerlIOBase_eof, | |
352 | PerlIOBase_error, | |
353 | PerlIOBase_clearerr, | |
354 | PerlIOBase_setlinebuf, | |
355 | NULL, /* get_base */ | |
356 | NULL, /* get_bufsiz */ | |
357 | NULL, /* get_ptr */ | |
358 | NULL, /* get_cnt */ | |
359 | NULL, /* set_ptrcnt */ | |
360 | }; | |
361 | ||
362 | ||
5833650d | 363 |