Commit | Line | Data |
---|---|---|
18f68570 VK |
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 | #include <cewin32.h> | |
10 | ||
11 | #include <sys/stat.h> | |
12 | #include "EXTERN.h" | |
13 | #include "perl.h" | |
14 | ||
15 | #ifdef PERLIO_LAYERS | |
16 | ||
17 | #include "perliol.h" | |
18 | ||
19 | #define NO_XSLOCKS | |
20 | #include "XSUB.h" | |
21 | ||
22 | ||
23 | /* Bottom-most level for Win32 case */ | |
24 | ||
25 | typedef struct | |
26 | { | |
27 | struct _PerlIO base; /* The generic part */ | |
28 | HANDLE h; /* OS level handle */ | |
29 | IV refcnt; /* REFCNT for the "fd" this represents */ | |
30 | int fd; /* UNIX like file descriptor - index into fdtable */ | |
31 | } PerlIOWin32; | |
32 | ||
33 | PerlIOWin32 *fdtable[256]; | |
34 | IV max_open_fd = -1; | |
35 | ||
36 | IV | |
37 | PerlIOWin32_popped(pTHX_ PerlIO *f) | |
38 | { | |
39 | PerlIOWin32 *s = PerlIOSelf(f,PerlIOWin32); | |
40 | if (--s->refcnt > 0) | |
41 | { | |
42 | *f = PerlIOBase(f)->next; | |
43 | return 1; | |
44 | } | |
45 | fdtable[s->fd] = NULL; | |
46 | return 0; | |
47 | } | |
48 | ||
49 | IV | |
50 | PerlIOWin32_fileno(pTHX_ PerlIO *f) | |
51 | { | |
52 | return PerlIOSelf(f,PerlIOWin32)->fd; | |
53 | } | |
54 | ||
55 | IV | |
aebd5ec7 | 56 | PerlIOWin32_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab) |
18f68570 | 57 | { |
aebd5ec7 | 58 | IV code = PerlIOBase_pushed(aTHX_ f,mode,arg,tab); |
18f68570 VK |
59 | if (*PerlIONext(f)) |
60 | { | |
61 | PerlIOWin32 *s = PerlIOSelf(f,PerlIOWin32); | |
62 | s->fd = PerlIO_fileno(PerlIONext(f)); | |
63 | } | |
64 | PerlIOBase(f)->flags |= PERLIO_F_OPEN; | |
65 | return code; | |
66 | } | |
67 | ||
68 | PerlIO * | |
69 | 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) | |
70 | { | |
71 | const char *tmode = mode; | |
72 | HANDLE h = INVALID_HANDLE_VALUE; | |
73 | if (f) | |
74 | { | |
75 | /* Close if already open */ | |
76 | if (PerlIOBase(f)->flags & PERLIO_F_OPEN) | |
77 | (*PerlIOBase(f)->tab->Close)(aTHX_ f); | |
78 | } | |
79 | if (narg > 0) | |
80 | { | |
81 | char *path = SvPV_nolen(*args); | |
82 | DWORD access = 0; | |
83 | DWORD share = 0; | |
84 | DWORD create = -1; | |
85 | DWORD attr = FILE_ATTRIBUTE_NORMAL; | |
86 | if (*mode == '#') | |
87 | { | |
88 | /* sysopen - imode is UNIX-like O_RDONLY etc. | |
89 | - do_open has converted that back to string form in mode as well | |
90 | - perm is UNIX like permissions | |
91 | */ | |
92 | mode++; | |
93 | } | |
94 | else | |
95 | { | |
96 | /* Normal open - decode mode string */ | |
97 | } | |
98 | switch(*mode) | |
99 | { | |
100 | case 'r': | |
101 | access = GENERIC_READ; | |
102 | create = OPEN_EXISTING; | |
103 | if (*++mode == '+') | |
104 | { | |
105 | access |= GENERIC_WRITE; | |
106 | create = OPEN_ALWAYS; | |
107 | mode++; | |
108 | } | |
109 | break; | |
110 | ||
111 | case 'w': | |
112 | access = GENERIC_WRITE; | |
113 | create = TRUNCATE_EXISTING; | |
114 | if (*++mode == '+') | |
115 | { | |
116 | access |= GENERIC_READ; | |
117 | mode++; | |
118 | } | |
119 | break; | |
120 | ||
121 | case 'a': | |
122 | access = GENERIC_WRITE; | |
123 | create = OPEN_ALWAYS; | |
124 | if (*++mode == '+') | |
125 | { | |
126 | access |= GENERIC_READ; | |
127 | mode++; | |
128 | } | |
129 | break; | |
130 | } | |
131 | if (*mode == 'b') | |
132 | { | |
133 | mode++; | |
134 | } | |
135 | else if (*mode == 't') | |
136 | { | |
137 | mode++; | |
138 | } | |
139 | if (*mode || create == -1) | |
140 | { | |
141 | //FIX-ME: SETERRNO(EINVAL,LIB$_INVARG); | |
142 | XCEMessageBoxA(NULL, "NEED TO IMPLEMENT a place in ../wince/win32io.c", "Perl(developer)", 0); | |
143 | return NULL; | |
144 | } | |
145 | if (!(access & GENERIC_WRITE)) | |
146 | share = FILE_SHARE_READ; | |
147 | h = CreateFileW(path,access,share,NULL,create,attr,NULL); | |
148 | if (h == INVALID_HANDLE_VALUE) | |
149 | { | |
150 | if (create == TRUNCATE_EXISTING) | |
151 | h = CreateFileW(path,access,share,NULL,(create = OPEN_ALWAYS),attr,NULL); | |
152 | } | |
153 | } | |
154 | else | |
155 | { | |
156 | /* fd open */ | |
157 | h = INVALID_HANDLE_VALUE; | |
158 | if (fd >= 0 && fd <= max_open_fd) | |
159 | { | |
160 | PerlIOWin32 *s = fdtable[fd]; | |
161 | if (s) | |
162 | { | |
163 | s->refcnt++; | |
164 | if (!f) | |
165 | f = PerlIO_allocate(aTHX); | |
166 | *f = &s->base; | |
167 | return f; | |
168 | } | |
169 | } | |
170 | if (*mode == 'I') | |
171 | { | |
172 | mode++; | |
173 | switch(fd) | |
174 | { | |
175 | case 0: | |
176 | h = XCEGetStdHandle(STD_INPUT_HANDLE); | |
177 | break; | |
178 | case 1: | |
179 | h = XCEGetStdHandle(STD_OUTPUT_HANDLE); | |
180 | break; | |
181 | case 2: | |
182 | h = XCEGetStdHandle(STD_ERROR_HANDLE); | |
183 | break; | |
184 | } | |
185 | } | |
186 | } | |
187 | if (h != INVALID_HANDLE_VALUE) | |
188 | fd = win32_open_osfhandle((intptr_t) h, PerlIOUnix_oflags(tmode)); | |
189 | if (fd >= 0) | |
190 | { | |
191 | PerlIOWin32 *s; | |
192 | if (!f) | |
193 | f = PerlIO_allocate(aTHX); | |
194 | s = PerlIOSelf(PerlIO_push(aTHX_ f,self,tmode,PerlIOArg),PerlIOWin32); | |
195 | s->h = h; | |
196 | s->fd = fd; | |
197 | s->refcnt = 1; | |
198 | if (fd >= 0) | |
199 | { | |
200 | fdtable[fd] = s; | |
201 | if (fd > max_open_fd) | |
202 | max_open_fd = fd; | |
203 | } | |
204 | return f; | |
205 | } | |
206 | if (f) | |
207 | { | |
208 | /* FIXME: pop layers ??? */ | |
209 | } | |
210 | return NULL; | |
211 | } | |
212 | ||
213 | SSize_t | |
214 | PerlIOWin32_read(pTHX_ PerlIO *f, void *vbuf, Size_t count) | |
215 | { | |
216 | PerlIOWin32 *s = PerlIOSelf(f,PerlIOWin32); | |
217 | DWORD len; | |
218 | if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD)) | |
219 | return 0; | |
220 | if (ReadFile(s->h,vbuf,count,&len,NULL)) | |
221 | { | |
222 | return len; | |
223 | } | |
224 | else | |
225 | { | |
226 | if (GetLastError() != NO_ERROR) | |
227 | { | |
228 | PerlIOBase(f)->flags |= PERLIO_F_ERROR; | |
0ea86a10 | 229 | PerlIO_save_errno(f); |
18f68570 VK |
230 | return -1; |
231 | } | |
232 | else | |
233 | { | |
234 | if (count != 0) | |
235 | PerlIOBase(f)->flags |= PERLIO_F_EOF; | |
236 | return 0; | |
237 | } | |
238 | } | |
239 | } | |
240 | ||
241 | SSize_t | |
242 | PerlIOWin32_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count) | |
243 | { | |
244 | PerlIOWin32 *s = PerlIOSelf(f,PerlIOWin32); | |
245 | DWORD len; | |
246 | if (WriteFile(s->h,vbuf,count,&len,NULL)) | |
247 | { | |
248 | return len; | |
249 | } | |
250 | else | |
251 | { | |
252 | PerlIOBase(f)->flags |= PERLIO_F_ERROR; | |
0ea86a10 | 253 | PerlIO_save_errno(f); |
18f68570 VK |
254 | return -1; |
255 | } | |
256 | } | |
257 | ||
258 | IV | |
259 | PerlIOWin32_seek(pTHX_ PerlIO *f, Off_t offset, int whence) | |
260 | { | |
261 | static const DWORD where[3] = { FILE_BEGIN, FILE_CURRENT, FILE_END }; | |
262 | PerlIOWin32 *s = PerlIOSelf(f,PerlIOWin32); | |
263 | DWORD high = (sizeof(offset) > sizeof(DWORD)) ? (DWORD)(offset >> 32) : 0; | |
264 | DWORD low = (DWORD) offset; | |
265 | DWORD res = SetFilePointer(s->h,low,&high,where[whence]); | |
266 | if (res != 0xFFFFFFFF || GetLastError() != NO_ERROR) | |
267 | { | |
268 | return 0; | |
269 | } | |
270 | else | |
271 | { | |
272 | return -1; | |
273 | } | |
274 | } | |
275 | ||
276 | Off_t | |
277 | PerlIOWin32_tell(pTHX_ PerlIO *f) | |
278 | { | |
279 | PerlIOWin32 *s = PerlIOSelf(f,PerlIOWin32); | |
280 | DWORD high = 0; | |
281 | DWORD res = SetFilePointer(s->h,0,&high,FILE_CURRENT); | |
282 | if (res != 0xFFFFFFFF || GetLastError() != NO_ERROR) | |
283 | { | |
284 | return ((Off_t) high << 32) | res; | |
285 | } | |
286 | return (Off_t) -1; | |
287 | } | |
288 | ||
289 | IV | |
290 | PerlIOWin32_close(pTHX_ PerlIO *f) | |
291 | { | |
292 | PerlIOWin32 *s = PerlIOSelf(f,PerlIOWin32); | |
293 | if (s->refcnt == 1) | |
294 | { | |
f4257e4d | 295 | IV code = 0; |
814ffeea | 296 | #if 0 |
f4257e4d | 297 | /* This does not do pipes etc. correctly */ |
814ffeea | 298 | if (!CloseHandle(s->h)) |
18f68570 VK |
299 | { |
300 | s->h = INVALID_HANDLE_VALUE; | |
301 | return -1; | |
302 | } | |
814ffeea VK |
303 | #else |
304 | PerlIOBase(f)->flags &= ~PERLIO_F_OPEN; | |
305 | return win32_close(s->fd); | |
306 | #endif | |
18f68570 | 307 | } |
18f68570 VK |
308 | return 0; |
309 | } | |
310 | ||
311 | PerlIO * | |
312 | PerlIOWin32_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *params, int flags) | |
313 | { | |
314 | PerlIOWin32 *os = PerlIOSelf(f,PerlIOWin32); | |
315 | HANDLE proc = GetCurrentProcess(); | |
814ffeea VK |
316 | HANDLE new; |
317 | if (DuplicateHandle(proc, os->h, proc, &new, 0, FALSE, DUPLICATE_SAME_ACCESS)) | |
18f68570 VK |
318 | { |
319 | char mode[8]; | |
320 | int fd = win32_open_osfhandle((intptr_t) new, PerlIOUnix_oflags(PerlIO_modestr(o,mode))); | |
814ffeea | 321 | if (fd >= 0) |
18f68570 VK |
322 | { |
323 | f = PerlIOBase_dup(aTHX_ f, o, params, flags); | |
814ffeea | 324 | if (f) |
18f68570 VK |
325 | { |
326 | PerlIOWin32 *fs = PerlIOSelf(f,PerlIOWin32); | |
327 | fs->h = new; | |
328 | fs->fd = fd; | |
329 | fs->refcnt = 1; | |
330 | fdtable[fd] = fs; | |
331 | if (fd > max_open_fd) | |
332 | max_open_fd = fd; | |
333 | } | |
334 | else | |
335 | { | |
336 | win32_close(fd); | |
337 | } | |
338 | } | |
339 | else | |
340 | { | |
341 | CloseHandle(new); | |
342 | } | |
343 | } | |
344 | return f; | |
345 | } | |
346 | ||
347 | PerlIO_funcs PerlIO_win32 = { | |
216db7ee | 348 | sizeof(PerlIO_funcs), |
18f68570 VK |
349 | "win32", |
350 | sizeof(PerlIOWin32), | |
351 | PERLIO_K_RAW, | |
352 | PerlIOWin32_pushed, | |
353 | PerlIOWin32_popped, | |
354 | PerlIOWin32_open, | |
216db7ee | 355 | PerlIOBase_binmode, |
18f68570 VK |
356 | NULL, /* getarg */ |
357 | PerlIOWin32_fileno, | |
358 | PerlIOWin32_dup, | |
359 | PerlIOWin32_read, | |
360 | PerlIOBase_unread, | |
361 | PerlIOWin32_write, | |
362 | PerlIOWin32_seek, | |
363 | PerlIOWin32_tell, | |
364 | PerlIOWin32_close, | |
365 | PerlIOBase_noop_ok, /* flush */ | |
366 | PerlIOBase_noop_fail, /* fill */ | |
367 | PerlIOBase_eof, | |
368 | PerlIOBase_error, | |
369 | PerlIOBase_clearerr, | |
370 | PerlIOBase_setlinebuf, | |
371 | NULL, /* get_base */ | |
372 | NULL, /* get_bufsiz */ | |
373 | NULL, /* get_ptr */ | |
374 | NULL, /* get_cnt */ | |
375 | NULL, /* set_ptrcnt */ | |
376 | }; | |
377 | ||
18f68570 | 378 | #endif |
814ffeea | 379 |