This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[PATCH: perl@11564] introducing perlivp
[perl5.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 #include "perliol.h"
14
15 #define NO_XSLOCKS
16 #include "XSUB.h"
17
18 /* Bottom-most level for Win32 case */
19
20 typedef struct
21 {
22  struct _PerlIO base;       /* The generic part */
23  HANDLE         h;          /* OS level handle */
24  IV             refcnt;     /* REFCNT for the "fd" this represents */
25  int            fd;         /* UNIX like file descriptor - index into fdtable */
26 } PerlIOWin32;
27
28 PerlIOWin32 *fdtable[256];
29 IV max_open_fd = -1;
30
31 IV
32 PerlIOWin32_popped(PerlIO *f)
33 {
34  PerlIOWin32 *s = PerlIOSelf(f,PerlIOWin32);
35  if (--s->refcnt > 0)
36   {
37    *f = PerlIOBase(f)->next;
38    return 1;
39   }
40  fdtable[s->fd] = NULL;
41  return 0;
42 }
43
44 IV
45 PerlIOWin32_fileno(PerlIO *f)
46 {
47  return PerlIOSelf(f,PerlIOWin32)->fd;
48 }
49
50 IV
51 PerlIOWin32_pushed(PerlIO *f, const char *mode, SV *arg)
52 {
53  IV code = PerlIOBase_pushed(f,mode,arg);
54  if (*PerlIONext(f))
55   {
56    PerlIOWin32 *s = PerlIOSelf(f,PerlIOWin32);
57    s->fd     = PerlIO_fileno(PerlIONext(f));
58   }
59  PerlIOBase(f)->flags |= PERLIO_F_OPEN;
60  return code;
61 }
62
63 PerlIO *
64 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)
65 {
66  const char *tmode = mode;
67  HANDLE h = INVALID_HANDLE_VALUE;
68  if (f)
69   {
70    /* Close if already open */
71    if (PerlIOBase(f)->flags & PERLIO_F_OPEN)
72     (*PerlIOBase(f)->tab->Close)(f);
73   }
74  if (narg > 0)
75   {
76    char *path = SvPV_nolen(*args);
77    DWORD  access = 0;
78    DWORD  share  = 0;
79    DWORD  create = -1;
80    DWORD  attr   = FILE_ATTRIBUTE_NORMAL;
81    if (*mode == '#')
82     {
83      /* sysopen - imode is UNIX-like O_RDONLY etc.
84         - do_open has converted that back to string form in mode as well
85         - perm is UNIX like permissions
86       */
87      mode++;
88     }
89    else
90     {
91      /* Normal open - decode mode string */
92     }
93    switch(*mode)
94     {
95      case 'r':
96       access  = GENERIC_READ;
97       create  = OPEN_EXISTING;
98       if (*++mode == '+')
99        {
100         access |= GENERIC_WRITE;
101         create  = OPEN_ALWAYS;
102         mode++;
103        }
104       break;
105
106      case 'w':
107       access  = GENERIC_WRITE;
108       create  = TRUNCATE_EXISTING;
109       if (*++mode == '+')
110        {
111         access |= GENERIC_READ;
112         mode++;
113        }
114       break;
115
116      case 'a':
117       access = GENERIC_WRITE;
118       create  = OPEN_ALWAYS;
119       if (*++mode == '+')
120        {
121         access |= GENERIC_READ;
122         mode++;
123        }
124       break;
125     }
126    if (*mode == 'b')
127     {
128      mode++;
129     }
130    else if (*mode == 't')
131     {
132      mode++;
133     }
134    if (*mode || create == -1)
135     {
136      SETERRNO(EINVAL,LIB$_INVARG);
137      return NULL;
138     }
139    if (!(access & GENERIC_WRITE))
140     share = FILE_SHARE_READ;
141    h = CreateFile(path,access,share,NULL,create,attr,NULL);
142    if (h == INVALID_HANDLE_VALUE)
143     {
144      if (create == TRUNCATE_EXISTING)
145       h = CreateFile(path,access,share,NULL,(create = OPEN_ALWAYS),attr,NULL);
146     }
147   }
148  else
149   {
150    /* fd open */
151    h = INVALID_HANDLE_VALUE;
152    if (fd >= 0 && fd <= max_open_fd)
153     {
154      PerlIOWin32 *s = fdtable[fd];
155      if (s)
156       {
157        s->refcnt++;
158        if (!f)
159         f = PerlIO_allocate(aTHX);
160        *f = &s->base;
161        return f;
162       }
163     }
164    if (*mode == 'I')
165     {
166      mode++;
167      switch(fd)
168       {
169        case 0:
170         h = GetStdHandle(STD_INPUT_HANDLE);
171         break;
172        case 1:
173         h = GetStdHandle(STD_OUTPUT_HANDLE);
174         break;
175        case 2:
176         h = GetStdHandle(STD_ERROR_HANDLE);
177         break;
178       }
179     }
180   }
181  if (h != INVALID_HANDLE_VALUE)
182   fd = win32_open_osfhandle((long) h, PerlIOUnix_oflags(tmode));
183  if (fd >= 0)
184   {
185    PerlIOWin32 *s;
186    if (!f)
187     f = PerlIO_allocate(aTHX);
188    s = PerlIOSelf(PerlIO_push(aTHX_ f,self,tmode,PerlIOArg),PerlIOWin32);
189    s->h      = h;
190    s->fd     = fd;
191    s->refcnt = 1;
192    if (fd >= 0) 
193     {
194      fdtable[fd] = s; 
195      if (fd > max_open_fd)
196       max_open_fd = fd;
197     } 
198    return f;
199   }
200  if (f)
201   {
202    /* FIXME: pop layers ??? */
203   }
204  return NULL;
205 }
206
207 SSize_t
208 PerlIOWin32_read(PerlIO *f, void *vbuf, Size_t count)
209 {
210  PerlIOWin32 *s = PerlIOSelf(f,PerlIOWin32);
211  DWORD len;
212  if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
213   return 0;
214  if (ReadFile(s->h,vbuf,count,&len,NULL))
215   {
216    return len;
217   }
218  else
219   {
220    if (GetLastError() != NO_ERROR)
221     {
222      PerlIOBase(f)->flags |= PERLIO_F_ERROR;
223      return -1;
224     }
225    else
226     {
227      if (count != 0)
228       PerlIOBase(f)->flags |= PERLIO_F_EOF;
229      return 0;
230     }
231   }
232 }
233
234 SSize_t
235 PerlIOWin32_write(PerlIO *f, const void *vbuf, Size_t count)
236 {
237  PerlIOWin32 *s = PerlIOSelf(f,PerlIOWin32);
238  DWORD len;
239  if (WriteFile(s->h,vbuf,count,&len,NULL))
240   {
241    return len;
242   }
243  else
244   {
245    PerlIOBase(f)->flags |= PERLIO_F_ERROR;
246    return -1;
247   }
248 }
249
250 IV
251 PerlIOWin32_seek(PerlIO *f, Off_t offset, int whence)
252 {
253  static const DWORD where[3] = { FILE_BEGIN, FILE_CURRENT, FILE_END };
254  PerlIOWin32 *s = PerlIOSelf(f,PerlIOWin32);
255  DWORD high = (sizeof(offset) > sizeof(DWORD)) ? (DWORD)(offset >> 32) : 0;
256  DWORD low  = (DWORD) offset;
257  DWORD res  = SetFilePointer(s->h,low,&high,where[whence]);
258  if (res != 0xFFFFFFFF || GetLastError() != NO_ERROR)
259   {
260    return 0;
261   }
262  else
263   {
264    return -1;
265   }
266 }
267
268 Off_t
269 PerlIOWin32_tell(PerlIO *f)
270 {
271  PerlIOWin32 *s = PerlIOSelf(f,PerlIOWin32);
272  DWORD high = 0;
273  DWORD res  = SetFilePointer(s->h,0,&high,FILE_CURRENT);
274  if (res != 0xFFFFFFFF || GetLastError() != NO_ERROR)
275   {
276    return ((Off_t) high << 32) | res;
277   }
278  return (Off_t) -1;
279 }
280
281 IV
282 PerlIOWin32_close(PerlIO *f)
283 {
284  PerlIOWin32 *s = PerlIOSelf(f,PerlIOWin32);
285  if (s->refcnt == 1)
286   {
287    if (CloseHandle(s->h))
288     {
289      s->h = INVALID_HANDLE_VALUE;
290      return -1;
291     }
292   }
293  PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
294  return 0;
295 }
296
297 PerlIO_funcs PerlIO_win32 = {
298  "win32",
299  sizeof(PerlIOWin32),
300  PERLIO_K_RAW,
301  PerlIOWin32_pushed,
302  PerlIOWin32_popped,
303  PerlIOWin32_open,
304  NULL,                 /* getarg */
305  PerlIOWin32_fileno,
306  PerlIOWin32_read,
307  PerlIOBase_unread,
308  PerlIOWin32_write,
309  PerlIOWin32_seek,
310  PerlIOWin32_tell,
311  PerlIOWin32_close,
312  PerlIOBase_noop_ok,   /* flush */
313  PerlIOBase_noop_fail, /* fill */
314  PerlIOBase_eof,
315  PerlIOBase_error,
316  PerlIOBase_clearerr,
317  PerlIOBase_setlinebuf,
318  NULL, /* get_base */
319  NULL, /* get_bufsiz */
320  NULL, /* get_ptr */
321  NULL, /* get_cnt */
322  NULL, /* set_ptrcnt */
323 };
324
325