add changelog for if.pm
[perl.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      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