Mercurial > repo
diff perl-5.22.2/win32/win32io.c @ 8045:a16537d2fe07
<xfix> tar xf perl-5.22.2.tar.gz # Ah, whatever, I\'m doing it anyway
author | HackBot |
---|---|
date | Sat, 14 May 2016 14:54:38 +0000 |
parents | |
children |
line wrap: on
line diff
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/perl-5.22.2/win32/win32io.c Sat May 14 14:54:38 2016 +0000 @@ -0,0 +1,391 @@ +#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 <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; + + Perl_ck_warner_d(aTHX_ + packWARN(WARN_EXPERIMENTAL__WIN32_PERLIO), + "PerlIO layer ':win32' is experimental"); + + 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; + /* CRT uses _SH_DENYNO for open(), this the Win32 equivelent */ + DWORD share = FILE_SHARE_READ | FILE_SHARE_WRITE; + DWORD create = -1; + DWORD attr = FILE_ATTRIBUTE_NORMAL; + if (stricmp(path, "/dev/null")==0) + path = "NUL"; + 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) + { + SETERRNO(EINVAL,LIB$_INVARG); + return NULL; + } + h = CreateFile(path,access,share,NULL,create,attr,NULL); + if (h == INVALID_HANDLE_VALUE) + { + if (create == TRUNCATE_EXISTING) + h = CreateFile(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 = GetStdHandle(STD_INPUT_HANDLE); + break; + case 1: + h = GetStdHandle(STD_OUTPUT_HANDLE); + break; + case 2: + h = GetStdHandle(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); +#if Off_t_size >= 8 + DWORD high = (DWORD)(offset >> 32); +#else + DWORD high = 0; +#endif + DWORD low = (DWORD) offset; + DWORD res = SetFilePointer(s->h,(LONG)low,(LONG *)&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,(LONG *)&high,FILE_CURRENT); + if (res != 0xFFFFFFFF || GetLastError() != NO_ERROR) + { +#if Off_t_size >= 8 + return ((Off_t) high << 32) | res; +#else + return res; +#endif + } + 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_h; + if (DuplicateHandle(proc, os->h, proc, &new_h, 0, FALSE, DUPLICATE_SAME_ACCESS)) + { + char mode[8]; + int fd = win32_open_osfhandle((intptr_t) new_h, 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_h; + 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_h); + } + } + return f; +} + +PERLIO_FUNCS_DECL(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 +