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 #include "perllio.h"
  14
  15 #define NO_XSLOCKS
  16 #include "XSUB.h"
  17
  18 /* Bottom-most level for Win32 case */
  19
  20 typedef struct
  21 {
  22  struct _PerlIO base;       /* The generic part */
  23  HANDLE         h;          /* OS level handle */
  24  IV             refcnt;     /* REFCNT for the "fd" this represents */
  25  int            fd;         /* UNIX like file descriptor - index into fdtable */
  26 } PerlIOWin32;
  27
  28 PerlIOWin32 *fdtable[256];
  29 IV max_open_fd = -1;
  30
  31 IV
  32 PerlIOWin32_popped(PerlIO *f)
  33 {
  34  PerlIOWin32 *s = PerlIOSelf(f,PerlIOWin32);
  35  if (--s->refcnt > 0)
  36   {
  37    *f = PerlIOBase(f)->next;
  38    return 1;
  39   }
  40  fdtable[s->fd] = NULL;
  41  return 0;
  42 }
  43
  44 IV
  45 PerlIOWin32_fileno(PerlIO *f)
  46 {
  47  return PerlIOSelf(f,PerlIOWin32)->fd;
  48 }
  49
  50 IV
  51 PerlIOWin32_pushed(PerlIO *f, const char *mode, SV *arg)
  52 {
  53  IV code = PerlIOBase_pushed(f,mode,arg);
  54  if (*PerlIONext(f))
  55   {
  56    PerlIOWin32 *s = PerlIOSelf(f,PerlIOWin32);
  57    s->fd     = PerlIO_fileno(PerlIONext(f));
  58   }
  59  PerlIOBase(f)->flags |= PERLIO_F_OPEN;
  60  return code;
  61 }
  62
  63 PerlIO *
  64 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)
  65 {
  66  const char *tmode = mode;
  67  HANDLE h = INVALID_HANDLE_VALUE;
  68  if (f)
  69   {
  70    /* Close if already open */
  71    if (PerlIOBase(f)->flags & PERLIO_F_OPEN)
  72     (*PerlIOBase(f)->tab->Close)(f);
  73   }
  74  if (narg > 0)
  75   {
  76    char *path = SvPV_nolen(*args);
  77    DWORD  access = 0;
  78    DWORD  share  = 0;
  79    DWORD  create = -1;
  80    DWORD  attr   = FILE_ATTRIBUTE_NORMAL;
  81    if (*mode == '#')
  82     {
  83      /* sysopen - imode is UNIX-like O_RDONLY etc.
  84         - do_open has converted that back to string form in mode as well
  85         - perm is UNIX like permissions
  86       */
  87      mode++;
  88     }
  89    else
  90     {
  91      /* Normal open - decode mode string */
  92     }
  93    switch(*mode)
  94     {
  95      case 'r':
  96       access  = GENERIC_READ;
  97       create  = OPEN_EXISTING;
  98       if (*++mode == '+')
  99        {
 100         access |= GENERIC_WRITE;
 101         create  = OPEN_ALWAYS;
 102         mode++;
 103        }
 104       break;
 105
 106      case 'w':
 107       access  = GENERIC_WRITE;
 108       create  = TRUNCATE_EXISTING;
 109       if (*++mode == '+')
 110        {
 111         access |= GENERIC_READ;
 112         mode++;
 113        }
 114       break;
 115
 116      case 'a':
 117       access = GENERIC_WRITE;
 118       create  = OPEN_ALWAYS;
 119       if (*++mode == '+')
 120        {
 121         access |= GENERIC_READ;
 122         mode++;
 123        }
 124       break;
 125     }
 126    if (*mode == 'b')
 127     {
 128      mode++;
 129     }
 130    else if (*mode == 't')
 131     {
 132      mode++;
 133     }
 134    if (*mode || oflags == -1)
 135     {
 136      SETERRNO(EINVAL,LIB$_INVARG);
 137      return NULL;
 138     }
 139    if (!(access & GENERIC_WRITE))
 140     share = FILE_SHARE_READ;
 141    h = CreateFile(path,access,share,NULL,create,attr,NULL);
 142    if (h == INVALID_HANDLE_VALUE)
 143     {
 144      if (create == TRUNCATE_EXISTING)
 145       h = CreateFile(path,access,share = OPEN_ALWAYS,NULL,create,attr,NULL);
 146     }
 147   }
 148  else
 149   {
 150    /* fd open */
 151    h = INVALID_HANDLE_VALUE;
 152    if (fd >= 0 && fd <= max_open_fd)
 153     {
 154      PerlIOWin32 *s = fdtable[fd];
 155      if (s)
 156       {
 157        s->refcnt++;
 158        if (!f)
 159         f = PerlIO_allocate(aTHX);
 160        *f = &s->base;
 161        return f;
 162       }
 163      if (*mode == 'I')
 164       {
 165        mode++;
 166        switch(fd)
 167         {
 168          case 0:
 169           h = GetStandardHandle(STD_INPUT_HANDLE);
 170           break;
 171          case 1:
 172           h = GetStandardHandle(STD_OUTPUT_HANDLE);
 173           break;
 174          case 2:
 175           h = GetStandardHandle(STD_ERROR_HANDLE);
 176           break;
 177         }
 178       }
 179     }
 180   }
 181  if (h != INVALID_HANDLE_VALUE)
 182   {
 183    PerlIOWin32 *s;
 184    if (!f)
 185     f = PerlIO_allocate(aTHX);
 186    s = PerlIOSelf(PerlIO_push(aTHX_ f,self,tmode,PerlIOArg),PerlIOWin32);
 187    s->ioh    = h;
 188    s->refcnt = 1;
 189    return f;
 190   }
 191  if (f)
 192   {
 193    /* FIXME: pop layers ??? */
 194   }
 195  return NULL;
 196 }
 197
 198 SSize_t
 199 PerlIOWin32_read(PerlIO *f, void *vbuf, Size_t count)
 200 {
 201  PerlIOWin32 *s = PerlIOSelf(f,PerlIOWin32);
 202  DWORD len;
 203  if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
 204   return 0;
 205  if (ReadFile(s->h,vbuf,count,&len,NULL)
 206   {
 207    return len;
 208   }
 209  else
 210   {
 211    if (GetLastError() != NO_ERROR)
 212     {
 213      PerlIOBase(f)->flags |= PERLIO_F_ERROR;
 214      return -1;
 215     }
 216    else
 217     {
 218      if (count != 0)
 219       PerlIOBase(f)->flags |= PERLIO_F_EOF;
 220      return 0;
 221     }
 222   }
 223 }
 224
 225 SSize_t
 226 PerlIOWin32_write(PerlIO *f, const void *vbuf, Size_t count)
 227 {
 228  PerlIOWin32 *s = PerlIOSelf(f,PerlIOWin32);
 229  DWORD len;
 230  if (WriteFile(s->h,vbuf,count,&len,NULL)
 231   {
 232    return len;
 233   }
 234  else
 235   {
 236    PerlIOBase(f)->flags |= PERLIO_F_ERROR;
 237    return -1;
 238   }
 239 }
 240
 241 IV
 242 PerlIOWin32_seek(PerlIO *f, Off_t offset, int whence)
 243 {
 244  static const DWORD where[3] = { FILE_BEGIN, FILE_CURRENT, FILE_END };
 245  PerlIOWin32 *s = PerlIOSelf(f,PerlIOWin32);
 246  DWORD high = (sizeof(offset) > sizeof(DWORD)) ? (DWORD)(offset >> 32) : 0;
 247  DWORD low  = (DWORD) offset;
 248  DWORD res  = SetFilePointer(s->h,low,&high,where[whence]);
 249  if (res != 0xFFFFFFFF || GetLastError() != NO_ERROR)
 250   {
 251    return 0;
 252   }
 253  else
 254   {
 255    return -1;
 256   }
 257 }
 258
 259 Off_t
 260 PerlIOWin32_tell(PerlIO *f)
 261 {
 262  PerlIOWin32 *s = PerlIOSelf(f,PerlIOWin32);
 263  DWORD high = 0;
 264  DWORD res  = SetFilePointer(s->h,0,&high,FILE_CURRENT);
 265  if (res != 0xFFFFFFFF || GetLastError() != NO_ERROR)
 266   {
 267    return ((Off_t) high << 32) | res;
 268   }
 269  return (Off_t) -1;
 270 }
 271
 272 IV
 273 PerlIOWin32_close(PerlIO *f)
 274 {
 275  PerlIOWin32 *s = PerlIOSelf(f,PerlIOWin32);
 276  if (s->refcnt == 1)
 277   {
 278    if (CloseHandle(s->h))
 279     {
 280      s->h = INVALID_HANDLE_VALUE;
 281      return -1;
 282     }
 283   }
 284  PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
 285  return 0;
 286 }
 287
 288 PerlIO_funcs PerlIO_win32 = {
 289  "win32",
 290  sizeof(PerlIOWin32),
 291  PERLIO_K_RAW,
 292  PerlIOWin32_pushed,
 293  PerlIOWin32_popped,
 294  PerlIOWin32_open,
 295  NULL,                 /* getarg */
 296  PerlIOWin32_fileno,
 297  PerlIOWin32_read,
 298  PerlIOBase_unread,
 299  PerlIOWin32_write,
 300  PerlIOWin32_seek,
 301  PerlIOWin32_tell,
 302  PerlIOWin32_close,
 303  PerlIOBase_noop_ok,   /* flush */
 304  PerlIOBase_noop_fail, /* fill */
 305  PerlIOBase_eof,
 306  PerlIOBase_error,
 307  PerlIOBase_clearerr,
 308  PerlIOBase_setlinebuf,
 309  NULL, /* get_base */
 310  NULL, /* get_bufsiz */
 311  NULL, /* get_ptr */
 312  NULL, /* get_cnt */
 313  NULL, /* set_ptrcnt */
 314 };
 315
 316