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