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