Mercurial > repo

comparison perl-5.22.2/win32/win32ceio.c @ 8045:a16537d2fe07

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
<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 #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
56 PerlIOWin32_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
57 {
58 IV code = PerlIOBase_pushed(aTHX_ f,mode,arg,tab);
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;
229 PerlIO_save_errno(f);
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;
253 PerlIO_save_errno(f);
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 {
295 IV code = 0;
296 #if 0
297 /* This does not do pipes etc. correctly */
298 if (!CloseHandle(s->h))
299 {
300 s->h = INVALID_HANDLE_VALUE;
301 return -1;
302 }
303 #else
304 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
305 return win32_close(s->fd);
306 #endif
307 }
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();
316 HANDLE new;
317 if (DuplicateHandle(proc, os->h, proc, &new, 0, FALSE, DUPLICATE_SAME_ACCESS))
318 {
319 char mode[8];
320 int fd = win32_open_osfhandle((intptr_t) new, PerlIOUnix_oflags(PerlIO_modestr(o,mode)));
321 if (fd >= 0)
322 {
323 f = PerlIOBase_dup(aTHX_ f, o, params, flags);
324 if (f)
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 = {
348 sizeof(PerlIO_funcs),
349 "win32",
350 sizeof(PerlIOWin32),
351 PERLIO_K_RAW,
352 PerlIOWin32_pushed,
353 PerlIOWin32_popped,
354 PerlIOWin32_open,
355 PerlIOBase_binmode,
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
378 #endif
379