Mercurial > repo
comparison perl-5.22.2/win32/win32io.c @ 8045:a16537d2fe07
<xfix> tar xf perl-5.22.2.tar.gz # Ah, whatever, I\'m doing it anyway
author | HackBot |
---|---|
date | Sat, 14 May 2016 14:54:38 +0000 |
parents | |
children |
comparison
equal
deleted
inserted
replaced
8044:711c038a7dce | 8045:a16537d2fe07 |
---|---|
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" | |
13 | |
14 #ifdef PERLIO_LAYERS | |
15 | |
16 #include "perliol.h" | |
17 | |
18 #define NO_XSLOCKS | |
19 #include "XSUB.h" | |
20 | |
21 | |
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 | |
36 PerlIOWin32_popped(pTHX_ PerlIO *f) | |
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 | |
49 PerlIOWin32_fileno(pTHX_ PerlIO *f) | |
50 { | |
51 return PerlIOSelf(f,PerlIOWin32)->fd; | |
52 } | |
53 | |
54 IV | |
55 PerlIOWin32_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab) | |
56 { | |
57 IV code = PerlIOBase_pushed(aTHX_ f,mode,arg,tab); | |
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 | |
65 Perl_ck_warner_d(aTHX_ | |
66 packWARN(WARN_EXPERIMENTAL__WIN32_PERLIO), | |
67 "PerlIO layer ':win32' is experimental"); | |
68 | |
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) | |
81 (*PerlIOBase(f)->tab->Close)(aTHX_ f); | |
82 } | |
83 if (narg > 0) | |
84 { | |
85 char *path = SvPV_nolen(*args); | |
86 DWORD access = 0; | |
87 /* CRT uses _SH_DENYNO for open(), this the Win32 equivelent */ | |
88 DWORD share = FILE_SHARE_READ | FILE_SHARE_WRITE; | |
89 DWORD create = -1; | |
90 DWORD attr = FILE_ATTRIBUTE_NORMAL; | |
91 if (stricmp(path, "/dev/null")==0) | |
92 path = "NUL"; | |
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 } | |
146 if (*mode || create == -1) | |
147 { | |
148 SETERRNO(EINVAL,LIB$_INVARG); | |
149 return NULL; | |
150 } | |
151 h = CreateFile(path,access,share,NULL,create,attr,NULL); | |
152 if (h == INVALID_HANDLE_VALUE) | |
153 { | |
154 if (create == TRUNCATE_EXISTING) | |
155 h = CreateFile(path,access,share,NULL,(create = OPEN_ALWAYS),attr,NULL); | |
156 } | |
157 } | |
158 else | |
159 { | |
160 /* fd open */ | |
161 h = INVALID_HANDLE_VALUE; | |
162 if (fd >= 0 && fd <= max_open_fd) | |
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 } | |
173 } | |
174 if (*mode == 'I') | |
175 { | |
176 mode++; | |
177 switch(fd) | |
178 { | |
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; | |
188 } | |
189 } | |
190 } | |
191 if (h != INVALID_HANDLE_VALUE) | |
192 fd = win32_open_osfhandle((intptr_t) h, PerlIOUnix_oflags(tmode)); | |
193 if (fd >= 0) | |
194 { | |
195 PerlIOWin32 *s; | |
196 if (!f) | |
197 f = PerlIO_allocate(aTHX); | |
198 s = PerlIOSelf(PerlIO_push(aTHX_ f,self,tmode,PerlIOArg),PerlIOWin32); | |
199 s->h = h; | |
200 s->fd = fd; | |
201 s->refcnt = 1; | |
202 if (fd >= 0) | |
203 { | |
204 fdtable[fd] = s; | |
205 if (fd > max_open_fd) | |
206 max_open_fd = fd; | |
207 } | |
208 return f; | |
209 } | |
210 if (f) | |
211 { | |
212 /* FIXME: pop layers ??? */ | |
213 } | |
214 return NULL; | |
215 } | |
216 | |
217 SSize_t | |
218 PerlIOWin32_read(pTHX_ PerlIO *f, void *vbuf, Size_t count) | |
219 { | |
220 PerlIOWin32 *s = PerlIOSelf(f,PerlIOWin32); | |
221 DWORD len; | |
222 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD)) | |
223 return 0; | |
224 if (ReadFile(s->h,vbuf,count,&len,NULL)) | |
225 { | |
226 return len; | |
227 } | |
228 else | |
229 { | |
230 if (GetLastError() != NO_ERROR) | |
231 { | |
232 PerlIOBase(f)->flags |= PERLIO_F_ERROR; | |
233 PerlIO_save_errno(f); | |
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 | |
246 PerlIOWin32_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count) | |
247 { | |
248 PerlIOWin32 *s = PerlIOSelf(f,PerlIOWin32); | |
249 DWORD len; | |
250 if (WriteFile(s->h,vbuf,count,&len,NULL)) | |
251 { | |
252 return len; | |
253 } | |
254 else | |
255 { | |
256 PerlIOBase(f)->flags |= PERLIO_F_ERROR; | |
257 PerlIO_save_errno(f); | |
258 return -1; | |
259 } | |
260 } | |
261 | |
262 IV | |
263 PerlIOWin32_seek(pTHX_ PerlIO *f, Off_t offset, int whence) | |
264 { | |
265 static const DWORD where[3] = { FILE_BEGIN, FILE_CURRENT, FILE_END }; | |
266 PerlIOWin32 *s = PerlIOSelf(f,PerlIOWin32); | |
267 #if Off_t_size >= 8 | |
268 DWORD high = (DWORD)(offset >> 32); | |
269 #else | |
270 DWORD high = 0; | |
271 #endif | |
272 DWORD low = (DWORD) offset; | |
273 DWORD res = SetFilePointer(s->h,(LONG)low,(LONG *)&high,where[whence]); | |
274 if (res != 0xFFFFFFFF || GetLastError() != NO_ERROR) | |
275 { | |
276 return 0; | |
277 } | |
278 else | |
279 { | |
280 return -1; | |
281 } | |
282 } | |
283 | |
284 Off_t | |
285 PerlIOWin32_tell(pTHX_ PerlIO *f) | |
286 { | |
287 PerlIOWin32 *s = PerlIOSelf(f,PerlIOWin32); | |
288 DWORD high = 0; | |
289 DWORD res = SetFilePointer(s->h,0,(LONG *)&high,FILE_CURRENT); | |
290 if (res != 0xFFFFFFFF || GetLastError() != NO_ERROR) | |
291 { | |
292 #if Off_t_size >= 8 | |
293 return ((Off_t) high << 32) | res; | |
294 #else | |
295 return res; | |
296 #endif | |
297 } | |
298 return (Off_t) -1; | |
299 } | |
300 | |
301 IV | |
302 PerlIOWin32_close(pTHX_ PerlIO *f) | |
303 { | |
304 PerlIOWin32 *s = PerlIOSelf(f,PerlIOWin32); | |
305 if (s->refcnt == 1) | |
306 { | |
307 IV code = 0; | |
308 #if 0 | |
309 /* This does not do pipes etc. correctly */ | |
310 if (!CloseHandle(s->h)) | |
311 { | |
312 s->h = INVALID_HANDLE_VALUE; | |
313 return -1; | |
314 } | |
315 #else | |
316 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN; | |
317 return win32_close(s->fd); | |
318 #endif | |
319 } | |
320 return 0; | |
321 } | |
322 | |
323 PerlIO * | |
324 PerlIOWin32_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *params, int flags) | |
325 { | |
326 PerlIOWin32 *os = PerlIOSelf(f,PerlIOWin32); | |
327 HANDLE proc = GetCurrentProcess(); | |
328 HANDLE new_h; | |
329 if (DuplicateHandle(proc, os->h, proc, &new_h, 0, FALSE, DUPLICATE_SAME_ACCESS)) | |
330 { | |
331 char mode[8]; | |
332 int fd = win32_open_osfhandle((intptr_t) new_h, PerlIOUnix_oflags(PerlIO_modestr(o,mode))); | |
333 if (fd >= 0) | |
334 { | |
335 f = PerlIOBase_dup(aTHX_ f, o, params, flags); | |
336 if (f) | |
337 { | |
338 PerlIOWin32 *fs = PerlIOSelf(f,PerlIOWin32); | |
339 fs->h = new_h; | |
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 { | |
353 CloseHandle(new_h); | |
354 } | |
355 } | |
356 return f; | |
357 } | |
358 | |
359 PERLIO_FUNCS_DECL(PerlIO_win32) = { | |
360 sizeof(PerlIO_funcs), | |
361 "win32", | |
362 sizeof(PerlIOWin32), | |
363 PERLIO_K_RAW, | |
364 PerlIOWin32_pushed, | |
365 PerlIOWin32_popped, | |
366 PerlIOWin32_open, | |
367 PerlIOBase_binmode, | |
368 NULL, /* getarg */ | |
369 PerlIOWin32_fileno, | |
370 PerlIOWin32_dup, | |
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 | |
390 #endif | |
391 |