regen/mk_invlists.pl: Fix bug when 2 ident tables
[perl.git] / win32 / win32io.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
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