text: #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;
   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)
      {
       SETERRNO(EINVAL,LIB$_INVARG);
       return NULL;
      }
     if (!(access & GENERIC_WRITE))
      share = FILE_SHARE_READ;
     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;
       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;
     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
  
  