Encode is actually version 2.37 from CPAN.
[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  return code;
65 }
66
67 PerlIO *
68 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)
69 {
70  const char *tmode = mode;
71  HANDLE h = INVALID_HANDLE_VALUE;
72  if (f)
73   {
74    /* Close if already open */
75    if (PerlIOBase(f)->flags & PERLIO_F_OPEN)
76     (*PerlIOBase(f)->tab->Close)(aTHX_ f);
77   }
78  if (narg > 0)
79   {
80    char *path = SvPV_nolen(*args);
81    DWORD  access = 0;
82    DWORD  share  = 0;
83    DWORD  create = -1;
84    DWORD  attr   = FILE_ATTRIBUTE_NORMAL;
85    if (*mode == '#')
86     {
87      /* sysopen - imode is UNIX-like O_RDONLY etc.
88         - do_open has converted that back to string form in mode as well
89         - perm is UNIX like permissions
90       */
91      mode++;
92     }
93    else
94     {
95      /* Normal open - decode mode string */
96     }
97    switch(*mode)
98     {
99      case 'r':
100       access  = GENERIC_READ;
101       create  = OPEN_EXISTING;
102       if (*++mode == '+')
103        {
104         access |= GENERIC_WRITE;
105         create  = OPEN_ALWAYS;
106         mode++;
107        }
108       break;
109
110      case 'w':
111       access  = GENERIC_WRITE;
112       create  = TRUNCATE_EXISTING;
113       if (*++mode == '+')
114        {
115         access |= GENERIC_READ;
116         mode++;
117        }
118       break;
119
120      case 'a':
121       access = GENERIC_WRITE;
122       create  = OPEN_ALWAYS;
123       if (*++mode == '+')
124        {
125         access |= GENERIC_READ;
126         mode++;
127        }
128       break;
129     }
130    if (*mode == 'b')
131     {
132      mode++;
133     }
134    else if (*mode == 't')
135     {
136      mode++;
137     }
138    if (*mode || create == -1)
139     {
140      SETERRNO(EINVAL,LIB$_INVARG);
141      return NULL;
142     }
143    if (!(access & GENERIC_WRITE))
144     share = FILE_SHARE_READ;
145    h = CreateFile(path,access,share,NULL,create,attr,NULL);
146    if (h == INVALID_HANDLE_VALUE)
147     {
148      if (create == TRUNCATE_EXISTING)
149       h = CreateFile(path,access,share,NULL,(create = OPEN_ALWAYS),attr,NULL);
150     }
151   }
152  else
153   {
154    /* fd open */
155    h = INVALID_HANDLE_VALUE;
156    if (fd >= 0 && fd <= max_open_fd)
157     {
158      PerlIOWin32 *s = fdtable[fd];
159      if (s)
160       {
161        s->refcnt++;
162        if (!f)
163         f = PerlIO_allocate(aTHX);
164        *f = &s->base;
165        return f;
166       }
167     }
168    if (*mode == 'I')
169     {
170      mode++;
171      switch(fd)
172       {
173        case 0:
174         h = GetStdHandle(STD_INPUT_HANDLE);
175         break;
176        case 1:
177         h = GetStdHandle(STD_OUTPUT_HANDLE);
178         break;
179        case 2:
180         h = GetStdHandle(STD_ERROR_HANDLE);
181         break;
182       }
183     }
184   }
185  if (h != INVALID_HANDLE_VALUE)
186   fd = win32_open_osfhandle((intptr_t) h, PerlIOUnix_oflags(tmode));
187  if (fd >= 0)
188   {
189    PerlIOWin32 *s;
190    if (!f)
191     f = PerlIO_allocate(aTHX);
192    s = PerlIOSelf(PerlIO_push(aTHX_ f,self,tmode,PerlIOArg),PerlIOWin32);
193    s->h      = h;
194    s->fd     = fd;
195    s->refcnt = 1;
196    if (fd >= 0)
197     {
198      fdtable[fd] = s;
199      if (fd > max_open_fd)
200       max_open_fd = fd;
201     }
202    return f;
203   }
204  if (f)
205   {
206    /* FIXME: pop layers ??? */
207   }
208  return NULL;
209 }
210
211 SSize_t
212 PerlIOWin32_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
213 {
214  PerlIOWin32 *s = PerlIOSelf(f,PerlIOWin32);
215  DWORD len;
216  if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
217   return 0;
218  if (ReadFile(s->h,vbuf,count,&len,NULL))
219   {
220    return len;
221   }
222  else
223   {
224    if (GetLastError() != NO_ERROR)
225     {
226      PerlIOBase(f)->flags |= PERLIO_F_ERROR;
227      return -1;
228     }
229    else
230     {
231      if (count != 0)
232       PerlIOBase(f)->flags |= PERLIO_F_EOF;
233      return 0;
234     }
235   }
236 }
237
238 SSize_t
239 PerlIOWin32_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
240 {
241  PerlIOWin32 *s = PerlIOSelf(f,PerlIOWin32);
242  DWORD len;
243  if (WriteFile(s->h,vbuf,count,&len,NULL))
244   {
245    return len;
246   }
247  else
248   {
249    PerlIOBase(f)->flags |= PERLIO_F_ERROR;
250    return -1;
251   }
252 }
253
254 IV
255 PerlIOWin32_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
256 {
257  static const DWORD where[3] = { FILE_BEGIN, FILE_CURRENT, FILE_END };
258  PerlIOWin32 *s = PerlIOSelf(f,PerlIOWin32);
259 #if Off_t_size >= 8
260  DWORD high = (DWORD)(offset >> 32);
261 #else
262  DWORD high = 0;
263 #endif
264  DWORD low  = (DWORD) offset;
265  DWORD res  = SetFilePointer(s->h,(LONG)low,(LONG *)&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,(LONG *)&high,FILE_CURRENT);
282  if (res != 0xFFFFFFFF || GetLastError() != NO_ERROR)
283   {
284 #if Off_t_size >= 8
285    return ((Off_t) high << 32) | res;
286 #else
287    return res;
288 #endif
289   }
290  return (Off_t) -1;
291 }
292
293 IV
294 PerlIOWin32_close(pTHX_ PerlIO *f)
295 {
296  PerlIOWin32 *s = PerlIOSelf(f,PerlIOWin32);
297  if (s->refcnt == 1)
298   {
299    IV code = 0; 
300 #if 0
301    /* This does not do pipes etc. correctly */  
302    if (!CloseHandle(s->h))
303     {
304      s->h = INVALID_HANDLE_VALUE;
305      return -1;
306     }
307 #else
308     PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
309     return win32_close(s->fd);
310 #endif
311   }
312  return 0;
313 }
314
315 PerlIO *
316 PerlIOWin32_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *params, int flags)
317 {
318  PerlIOWin32 *os = PerlIOSelf(f,PerlIOWin32);
319  HANDLE proc = GetCurrentProcess();
320  HANDLE new;
321  if (DuplicateHandle(proc, os->h, proc, &new, 0, FALSE,  DUPLICATE_SAME_ACCESS))
322   {
323    char mode[8];
324    int fd = win32_open_osfhandle((intptr_t) new, PerlIOUnix_oflags(PerlIO_modestr(o,mode)));
325    if (fd >= 0)
326     {
327      f = PerlIOBase_dup(aTHX_ f, o, params, flags);
328      if (f)
329       {
330        PerlIOWin32 *fs = PerlIOSelf(f,PerlIOWin32);
331        fs->h  = new;
332        fs->fd = fd;
333        fs->refcnt = 1;
334        fdtable[fd] = fs;
335        if (fd > max_open_fd)
336         max_open_fd = fd;
337       }
338      else
339       {
340        win32_close(fd);
341       }
342     }
343    else
344     {
345      CloseHandle(new);
346     }
347   }
348  return f;
349 }
350
351 PERLIO_FUNCS_DECL(PerlIO_win32) = {
352  sizeof(PerlIO_funcs),
353  "win32",
354  sizeof(PerlIOWin32),
355  PERLIO_K_RAW,
356  PerlIOWin32_pushed,
357  PerlIOWin32_popped,
358  PerlIOWin32_open,
359  PerlIOBase_binmode,
360  NULL,                 /* getarg */
361  PerlIOWin32_fileno,
362  PerlIOWin32_dup,
363  PerlIOWin32_read,
364  PerlIOBase_unread,
365  PerlIOWin32_write,
366  PerlIOWin32_seek,
367  PerlIOWin32_tell,
368  PerlIOWin32_close,
369  PerlIOBase_noop_ok,   /* flush */
370  PerlIOBase_noop_fail, /* fill */
371  PerlIOBase_eof,
372  PerlIOBase_error,
373  PerlIOBase_clearerr,
374  PerlIOBase_setlinebuf,
375  NULL, /* get_base */
376  NULL, /* get_bufsiz */
377  NULL, /* get_ptr */
378  NULL, /* get_cnt */
379  NULL, /* set_ptrcnt */
380 };
381
382 #endif
383