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