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 "perliol.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(pTHX_ 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(pTHX_ PerlIO *f)
  46 {
  47  return PerlIOSelf(f,PerlIOWin32)->fd;
  48 }
  49
  50 IV
  51 PerlIOWin32_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg)
  52 {
  53  IV code = PerlIOBase_pushed(aTHX_ 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)(aTHX_ 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 || create == -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,NULL,(create = OPEN_ALWAYS),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     }
 164    if (*mode == 'I')
 165     {
 166      mode++;
 167      switch(fd)
 168       {
 169        case 0:
 170         h = GetStdHandle(STD_INPUT_HANDLE);
 171         break;
 172        case 1:
 173         h = GetStdHandle(STD_OUTPUT_HANDLE);
 174         break;
 175        case 2:
 176         h = GetStdHandle(STD_ERROR_HANDLE);
 177         break;
 178       }
 179     }
 180   }
 181  if (h != INVALID_HANDLE_VALUE)
 182   fd = win32_open_osfhandle((long) h, PerlIOUnix_oflags(tmode));
 183  if (fd >= 0)
 184   {
 185    PerlIOWin32 *s;
 186    if (!f)
 187     f = PerlIO_allocate(aTHX);
 188    s = PerlIOSelf(PerlIO_push(aTHX_ f,self,tmode,PerlIOArg),PerlIOWin32);
 189    s->h      = h;
 190    s->fd     = fd;
 191    s->refcnt = 1;
 192    if (fd >= 0)
 193     {
 194      fdtable[fd] = s;
 195      if (fd > max_open_fd)
 196       max_open_fd = fd;
 197     }
 198    return f;
 199   }
 200  if (f)
 201   {
 202    /* FIXME: pop layers ??? */
 203   }
 204  return NULL;
 205 }
 206
 207 SSize_t
 208 PerlIOWin32_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
 209 {
 210  PerlIOWin32 *s = PerlIOSelf(f,PerlIOWin32);
 211  DWORD len;
 212  if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
 213   return 0;
 214  if (ReadFile(s->h,vbuf,count,&len,NULL))
 215   {
 216    return len;
 217   }
 218  else
 219   {
 220    if (GetLastError() != NO_ERROR)
 221     {
 222      PerlIOBase(f)->flags |= PERLIO_F_ERROR;
 223      return -1;
 224     }
 225    else
 226     {
 227      if (count != 0)
 228       PerlIOBase(f)->flags |= PERLIO_F_EOF;
 229      return 0;
 230     }
 231   }
 232 }
 233
 234 SSize_t
 235 PerlIOWin32_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
 236 {
 237  PerlIOWin32 *s = PerlIOSelf(f,PerlIOWin32);
 238  DWORD len;
 239  if (WriteFile(s->h,vbuf,count,&len,NULL))
 240   {
 241    return len;
 242   }
 243  else
 244   {
 245    PerlIOBase(f)->flags |= PERLIO_F_ERROR;
 246    return -1;
 247   }
 248 }
 249
 250 IV
 251 PerlIOWin32_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
 252 {
 253  static const DWORD where[3] = { FILE_BEGIN, FILE_CURRENT, FILE_END };
 254  PerlIOWin32 *s = PerlIOSelf(f,PerlIOWin32);
 255  DWORD high = (sizeof(offset) > sizeof(DWORD)) ? (DWORD)(offset >> 32) : 0;
 256  DWORD low  = (DWORD) offset;
 257  DWORD res  = SetFilePointer(s->h,low,&high,where[whence]);
 258  if (res != 0xFFFFFFFF || GetLastError() != NO_ERROR)
 259   {
 260    return 0;
 261   }
 262  else
 263   {
 264    return -1;
 265   }
 266 }
 267
 268 Off_t
 269 PerlIOWin32_tell(pTHX_ PerlIO *f)
 270 {
 271  PerlIOWin32 *s = PerlIOSelf(f,PerlIOWin32);
 272  DWORD high = 0;
 273  DWORD res  = SetFilePointer(s->h,0,&high,FILE_CURRENT);
 274  if (res != 0xFFFFFFFF || GetLastError() != NO_ERROR)
 275   {
 276    return ((Off_t) high << 32) | res;
 277   }
 278  return (Off_t) -1;
 279 }
 280
 281 IV
 282 PerlIOWin32_close(pTHX_ PerlIO *f)
 283 {
 284  PerlIOWin32 *s = PerlIOSelf(f,PerlIOWin32);
 285  if (s->refcnt == 1)
 286   {
 287    if (CloseHandle(s->h))
 288     {
 289      s->h = INVALID_HANDLE_VALUE;
 290      return -1;
 291     }
 292   }
 293  PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
 294  return 0;
 295 }
 296
 297 PerlIO *
 298 PerlIOWin32_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *params, int flags)
 299 {
 300  PerlIOWin32 *os = PerlIOSelf(f,PerlIOWin32);
 301  HANDLE proc = GetCurrentProcess();
 302  HANDLE new;
 303  if (DuplicateHandle(proc, os->h, proc, &new, 0, FALSE,  DUPLICATE_SAME_ACCESS))
 304   {
 305    char mode[8];
 306    int fd = win32_open_osfhandle((long) new, PerlIOUnix_oflags(PerlIO_modestr(o,mode)));
 307    if (fd >= 0)
 308     {
 309      f = PerlIOBase_dup(aTHX_ f, o, params, flags);
 310      if (f)
 311       {
 312        PerlIOWin32 *fs = PerlIOSelf(f,PerlIOWin32);
 313        fs->h  = new;
 314        fs->fd = fd;
 315        fs->refcnt = 1;
 316        fdtable[fd] = fs;
 317        if (fd > max_open_fd)
 318         max_open_fd = fd;
 319       }
 320      else
 321       {
 322        win32_close(fd);
 323       }
 324     }
 325    else
 326     {
 327      CloseHandle(new);
 328     }
 329   }
 330  return f;
 331 }
 332
 333 PerlIO_funcs PerlIO_win32 = {
 334  "win32",
 335  sizeof(PerlIOWin32),
 336  PERLIO_K_RAW,
 337  PerlIOWin32_pushed,
 338  PerlIOWin32_popped,
 339  PerlIOWin32_open,
 340  NULL,                 /* getarg */
 341  PerlIOWin32_fileno,
 342  PerlIOWin32_dup,
 343  PerlIOWin32_read,
 344  PerlIOBase_unread,
 345  PerlIOWin32_write,
 346  PerlIOWin32_seek,
 347  PerlIOWin32_tell,
 348  PerlIOWin32_close,
 349  PerlIOBase_noop_ok,   /* flush */
 350  PerlIOBase_noop_fail, /* fill */
 351  PerlIOBase_eof,
 352  PerlIOBase_error,
 353  PerlIOBase_clearerr,
 354  PerlIOBase_setlinebuf,
 355  NULL, /* get_base */
 356  NULL, /* get_bufsiz */
 357  NULL, /* get_ptr */
 358  NULL, /* get_cnt */
 359  NULL, /* set_ptrcnt */
 360 };
 361
 362
 363