Regenerate META.yml
[p5sagit/p5-mst-13.2.git] / win32 / win32ceio.c
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      return -1;
230     }
231    else
232     {
233      if (count != 0)
234       PerlIOBase(f)->flags |= PERLIO_F_EOF;
235      return 0;
236     }
237   }
238 }
239
240 SSize_t
241 PerlIOWin32_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
242 {
243  PerlIOWin32 *s = PerlIOSelf(f,PerlIOWin32);
244  DWORD len;
245  if (WriteFile(s->h,vbuf,count,&len,NULL))
246   {
247    return len;
248   }
249  else
250   {
251    PerlIOBase(f)->flags |= PERLIO_F_ERROR;
252    return -1;
253   }
254 }
255
256 IV
257 PerlIOWin32_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
258 {
259  static const DWORD where[3] = { FILE_BEGIN, FILE_CURRENT, FILE_END };
260  PerlIOWin32 *s = PerlIOSelf(f,PerlIOWin32);
261  DWORD high = (sizeof(offset) > sizeof(DWORD)) ? (DWORD)(offset >> 32) : 0;
262  DWORD low  = (DWORD) offset;
263  DWORD res  = SetFilePointer(s->h,low,&high,where[whence]);
264  if (res != 0xFFFFFFFF || GetLastError() != NO_ERROR)
265   {
266    return 0;
267   }
268  else
269   {
270    return -1;
271   }
272 }
273
274 Off_t
275 PerlIOWin32_tell(pTHX_ PerlIO *f)
276 {
277  PerlIOWin32 *s = PerlIOSelf(f,PerlIOWin32);
278  DWORD high = 0;
279  DWORD res  = SetFilePointer(s->h,0,&high,FILE_CURRENT);
280  if (res != 0xFFFFFFFF || GetLastError() != NO_ERROR)
281   {
282    return ((Off_t) high << 32) | res;
283   }
284  return (Off_t) -1;
285 }
286
287 IV
288 PerlIOWin32_close(pTHX_ PerlIO *f)
289 {
290  PerlIOWin32 *s = PerlIOSelf(f,PerlIOWin32);
291  if (s->refcnt == 1)
292   {
293    IV code = 0;
294 #if 0
295    /* This does not do pipes etc. correctly */
296    if (!CloseHandle(s->h))
297     {
298      s->h = INVALID_HANDLE_VALUE;
299      return -1;
300     }
301 #else
302     PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
303     return win32_close(s->fd);
304 #endif
305   }
306  return 0;
307 }
308
309 PerlIO *
310 PerlIOWin32_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *params, int flags)
311 {
312  PerlIOWin32 *os = PerlIOSelf(f,PerlIOWin32);
313  HANDLE proc = GetCurrentProcess();
314  HANDLE new;
315  if (DuplicateHandle(proc, os->h, proc, &new, 0, FALSE,  DUPLICATE_SAME_ACCESS))
316   {
317    char mode[8];
318    int fd = win32_open_osfhandle((intptr_t) new, PerlIOUnix_oflags(PerlIO_modestr(o,mode)));
319    if (fd >= 0)
320     {
321      f = PerlIOBase_dup(aTHX_ f, o, params, flags);
322      if (f)
323       {
324        PerlIOWin32 *fs = PerlIOSelf(f,PerlIOWin32);
325        fs->h  = new;
326        fs->fd = fd;
327        fs->refcnt = 1;
328        fdtable[fd] = fs;
329        if (fd > max_open_fd)
330         max_open_fd = fd;
331       }
332      else
333       {
334        win32_close(fd);
335       }
336     }
337    else
338     {
339      CloseHandle(new);
340     }
341   }
342  return f;
343 }
344
345 PerlIO_funcs PerlIO_win32 = {
346  sizeof(PerlIO_funcs),
347  "win32",
348  sizeof(PerlIOWin32),
349  PERLIO_K_RAW,
350  PerlIOWin32_pushed,
351  PerlIOWin32_popped,
352  PerlIOWin32_open,
353  PerlIOBase_binmode,
354  NULL,                 /* getarg */
355  PerlIOWin32_fileno,
356  PerlIOWin32_dup,
357  PerlIOWin32_read,
358  PerlIOBase_unread,
359  PerlIOWin32_write,
360  PerlIOWin32_seek,
361  PerlIOWin32_tell,
362  PerlIOWin32_close,
363  PerlIOBase_noop_ok,   /* flush */
364  PerlIOBase_noop_fail, /* fill */
365  PerlIOBase_eof,
366  PerlIOBase_error,
367  PerlIOBase_clearerr,
368  PerlIOBase_setlinebuf,
369  NULL, /* get_base */
370  NULL, /* get_bufsiz */
371  NULL, /* get_ptr */
372  NULL, /* get_cnt */
373  NULL, /* set_ptrcnt */
374 };
375
376 #endif
377