[perl5.git] / win32 / win32ceio.c

#define PERL_NO_GET_CONTEXT
#define WIN32_LEAN_AND_MEAN
#define WIN32IO_IS_STDIO
#include <tchar.h>
#ifdef __GNUC__
#define Win32_Winsock
#endif
#include <windows.h>
#include <cewin32.h>

#include <sys/stat.h>
#include "EXTERN.h"
#include "perl.h"

#ifdef PERLIO_LAYERS

#include "perliol.h"

#define NO_XSLOCKS
#include "XSUB.h"


/* Bottom-most level for Win32 case */

typedef struct
{
 struct _PerlIO base;       /* The generic part */
 HANDLE		h;          /* OS level handle */
 IV		refcnt;     /* REFCNT for the "fd" this represents */
 int		fd;         /* UNIX like file descriptor - index into fdtable */
} PerlIOWin32;

PerlIOWin32 *fdtable[256];
IV max_open_fd = -1;

IV
PerlIOWin32_popped(pTHX_ PerlIO *f)
{
 PerlIOWin32 *s = PerlIOSelf(f,PerlIOWin32);
 if (--s->refcnt > 0)
  {
   *f = PerlIOBase(f)->next;
   return 1;
  }
 fdtable[s->fd] = NULL;
 return 0;
}

IV
PerlIOWin32_fileno(pTHX_ PerlIO *f)
{
 return PerlIOSelf(f,PerlIOWin32)->fd;
}

IV
PerlIOWin32_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
{
 IV code = PerlIOBase_pushed(aTHX_ f,mode,arg,tab);
 if (*PerlIONext(f))
  {
   PerlIOWin32 *s = PerlIOSelf(f,PerlIOWin32);
   s->fd     = PerlIO_fileno(PerlIONext(f));
  }
 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
 return code;
}

PerlIO *
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)
{
 const char *tmode = mode;
 HANDLE h = INVALID_HANDLE_VALUE;
 if (f)
  {
   /* Close if already open */
   if (PerlIOBase(f)->flags & PERLIO_F_OPEN)
    (*PerlIOBase(f)->tab->Close)(aTHX_ f);
  }
 if (narg > 0)
  {
   char *path = SvPV_nolen(*args);
   DWORD  access = 0;
   DWORD  share  = 0;
   DWORD  create = -1;
   DWORD  attr   = FILE_ATTRIBUTE_NORMAL;
   if (*mode == '#')
    {
     /* sysopen - imode is UNIX-like O_RDONLY etc.
        - do_open has converted that back to string form in mode as well
        - perm is UNIX like permissions
      */
     mode++;
    }
   else
    {
     /* Normal open - decode mode string */
    }
   switch(*mode)
    {
     case 'r':
      access  = GENERIC_READ;
      create  = OPEN_EXISTING;
      if (*++mode == '+')
       {
        access |= GENERIC_WRITE;
        create  = OPEN_ALWAYS;
        mode++;
       }
      break;

     case 'w':
      access  = GENERIC_WRITE;
      create  = TRUNCATE_EXISTING;
      if (*++mode == '+')
       {
        access |= GENERIC_READ;
        mode++;
       }
      break;

     case 'a':
      access = GENERIC_WRITE;
      create  = OPEN_ALWAYS;
      if (*++mode == '+')
       {
        access |= GENERIC_READ;
        mode++;
       }
      break;
    }
   if (*mode == 'b')
    {
     mode++;
    }
   else if (*mode == 't')
    {
     mode++;
    }
   if (*mode || create == -1)
    {
     //FIX-ME: SETERRNO(EINVAL,LIB$_INVARG);
     XCEMessageBoxA(NULL, "NEED TO IMPLEMENT a place in ../wince/win32io.c", "Perl(developer)", 0);
     return NULL;
    }
   if (!(access & GENERIC_WRITE))
    share = FILE_SHARE_READ;
   h = CreateFileW(path,access,share,NULL,create,attr,NULL);
   if (h == INVALID_HANDLE_VALUE)
    {
     if (create == TRUNCATE_EXISTING)
      h = CreateFileW(path,access,share,NULL,(create = OPEN_ALWAYS),attr,NULL);
    }
  }
 else
  {
   /* fd open */
   h = INVALID_HANDLE_VALUE;
   if (fd >= 0 && fd <= max_open_fd)
    {
     PerlIOWin32 *s = fdtable[fd];
     if (s)
      {
       s->refcnt++;
       if (!f)
        f = PerlIO_allocate(aTHX);
       *f = &s->base;
       return f;
      }
    }
   if (*mode == 'I')
    {
     mode++;
     switch(fd)
      {
       case 0:
        h = XCEGetStdHandle(STD_INPUT_HANDLE);
        break;
       case 1:
        h = XCEGetStdHandle(STD_OUTPUT_HANDLE);
        break;
       case 2:
        h = XCEGetStdHandle(STD_ERROR_HANDLE);
        break;
      }
    }
  }
 if (h != INVALID_HANDLE_VALUE)
  fd = win32_open_osfhandle((intptr_t) h, PerlIOUnix_oflags(tmode));
 if (fd >= 0)
  {
   PerlIOWin32 *s;
   if (!f)
    f = PerlIO_allocate(aTHX);
   s = PerlIOSelf(PerlIO_push(aTHX_ f,self,tmode,PerlIOArg),PerlIOWin32);
   s->h      = h;
   s->fd     = fd;
   s->refcnt = 1;
   if (fd >= 0)
    {
     fdtable[fd] = s;
     if (fd > max_open_fd)
      max_open_fd = fd;
    }
   return f;
  }
 if (f)
  {
   /* FIXME: pop layers ??? */
  }
 return NULL;
}

SSize_t
PerlIOWin32_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
{
 PerlIOWin32 *s = PerlIOSelf(f,PerlIOWin32);
 DWORD len;
 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
  return 0;
 if (ReadFile(s->h,vbuf,count,&len,NULL))
  {
   return len;
  }
 else
  {
   if (GetLastError() != NO_ERROR)
    {
     PerlIOBase(f)->flags |= PERLIO_F_ERROR;
     PerlIO_save_errno(f);
     return -1;
    }
   else
    {
     if (count != 0)
      PerlIOBase(f)->flags |= PERLIO_F_EOF;
     return 0;
    }
  }
}

SSize_t
PerlIOWin32_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
{
 PerlIOWin32 *s = PerlIOSelf(f,PerlIOWin32);
 DWORD len;
 if (WriteFile(s->h,vbuf,count,&len,NULL))
  {
   return len;
  }
 else
  {
   PerlIOBase(f)->flags |= PERLIO_F_ERROR;
   PerlIO_save_errno(f);
   return -1;
  }
}

IV
PerlIOWin32_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
{
 static const DWORD where[3] = { FILE_BEGIN, FILE_CURRENT, FILE_END };
 PerlIOWin32 *s = PerlIOSelf(f,PerlIOWin32);
 DWORD high = (sizeof(offset) > sizeof(DWORD)) ? (DWORD)(offset >> 32) : 0;
 DWORD low  = (DWORD) offset;
 DWORD res  = SetFilePointer(s->h,low,&high,where[whence]);
 if (res != 0xFFFFFFFF || GetLastError() != NO_ERROR)
  {
   return 0;
  }
 else
  {
   return -1;
  }
}

Off_t
PerlIOWin32_tell(pTHX_ PerlIO *f)
{
 PerlIOWin32 *s = PerlIOSelf(f,PerlIOWin32);
 DWORD high = 0;
 DWORD res  = SetFilePointer(s->h,0,&high,FILE_CURRENT);
 if (res != 0xFFFFFFFF || GetLastError() != NO_ERROR)
  {
   return ((Off_t) high << 32) | res;
  }
 return (Off_t) -1;
}

IV
PerlIOWin32_close(pTHX_ PerlIO *f)
{
 PerlIOWin32 *s = PerlIOSelf(f,PerlIOWin32);
 if (s->refcnt == 1)
  {
   IV code = 0;
#if 0
   /* This does not do pipes etc. correctly */
   if (!CloseHandle(s->h))
    {
     s->h = INVALID_HANDLE_VALUE;
     return -1;
    }
#else
    PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
    return win32_close(s->fd);
#endif
  }
 return 0;
}

PerlIO *
PerlIOWin32_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *params, int flags)
{
 PerlIOWin32 *os = PerlIOSelf(f,PerlIOWin32);
 HANDLE proc = GetCurrentProcess();
 HANDLE new;
 if (DuplicateHandle(proc, os->h, proc, &new, 0, FALSE,  DUPLICATE_SAME_ACCESS))
  {
   char mode[8];
   int fd = win32_open_osfhandle((intptr_t) new, PerlIOUnix_oflags(PerlIO_modestr(o,mode)));
   if (fd >= 0)
    {
     f = PerlIOBase_dup(aTHX_ f, o, params, flags);
     if (f)
      {
       PerlIOWin32 *fs = PerlIOSelf(f,PerlIOWin32);
       fs->h  = new;
       fs->fd = fd;
       fs->refcnt = 1;
       fdtable[fd] = fs;
       if (fd > max_open_fd)
        max_open_fd = fd;
      }
     else
      {
       win32_close(fd);
      }
    }
   else
    {
     CloseHandle(new);
    }
  }
 return f;
}

PerlIO_funcs PerlIO_win32 = {
 sizeof(PerlIO_funcs),
 "win32",
 sizeof(PerlIOWin32),
 PERLIO_K_RAW,
 PerlIOWin32_pushed,
 PerlIOWin32_popped,
 PerlIOWin32_open,
 PerlIOBase_binmode,
 NULL,                 /* getarg */
 PerlIOWin32_fileno,
 PerlIOWin32_dup,
 PerlIOWin32_read,
 PerlIOBase_unread,
 PerlIOWin32_write,
 PerlIOWin32_seek,
 PerlIOWin32_tell,
 PerlIOWin32_close,
 PerlIOBase_noop_ok,   /* flush */
 PerlIOBase_noop_fail, /* fill */
 PerlIOBase_eof,
 PerlIOBase_error,
 PerlIOBase_clearerr,
 PerlIOBase_setlinebuf,
 NULL, /* get_base */
 NULL, /* get_bufsiz */
 NULL, /* get_ptr */
 NULL, /* get_cnt */
 NULL, /* set_ptrcnt */
};

#endif
Commit	Line	Data
18f68570 VK	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
aebd5ec7	56	PerlIOWin32_pushed(pTHX_ PerlIO f, const char mode, SV arg, PerlIO_funcs tab)
18f68570	57	{
aebd5ec7	58	IV code = PerlIOBase_pushed(aTHX_ f,mode,arg,tab);
18f68570 VK	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;
0ea86a10	229	PerlIO_save_errno(f);
18f68570 VK	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;
0ea86a10	253	PerlIO_save_errno(f);
18f68570 VK	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	{
f4257e4d	295	IV code = 0;
814ffeea	296	#if 0
f4257e4d	297	/* This does not do pipes etc. correctly */
814ffeea	298	if (!CloseHandle(s->h))
18f68570 VK	299	{
	300	s->h = INVALID_HANDLE_VALUE;
	301	return -1;
	302	}
814ffeea VK	303	#else
	304	PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
	305	return win32_close(s->fd);
	306	#endif
18f68570	307	}
18f68570 VK	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();
814ffeea VK	316	HANDLE new;
814ffeea VK	317	if (DuplicateHandle(proc, os->h, proc, &new, 0, FALSE, DUPLICATE_SAME_ACCESS))
18f68570 VK	318	{
	319	char mode[8];
	320	int fd = win32_open_osfhandle((intptr_t) new, PerlIOUnix_oflags(PerlIO_modestr(o,mode)));
814ffeea	321	if (fd >= 0)
18f68570 VK	322	{
18f68570 VK	323	f = PerlIOBase_dup(aTHX_ f, o, params, flags);
814ffeea	324	if (f)
18f68570 VK	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 = {
216db7ee	348	sizeof(PerlIO_funcs),
18f68570 VK	349	"win32",
	350	sizeof(PerlIOWin32),
	351	PERLIO_K_RAW,
	352	PerlIOWin32_pushed,
	353	PerlIOWin32_popped,
	354	PerlIOWin32_open,
216db7ee	355	PerlIOBase_binmode,
18f68570 VK	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
18f68570	378	#endif
814ffeea	379