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