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      PerlIO_save_errno(f);
 230      return -1;
 231     }
 232    else
 233     {
 234      if (count != 0)
 235       PerlIOBase(f)->flags |= PERLIO_F_EOF;
 236      return 0;
 237     }
 238   }
 239 }
 240
 241 SSize_t
 242 PerlIOWin32_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
 243 {
 244  PerlIOWin32 *s = PerlIOSelf(f,PerlIOWin32);
 245  DWORD len;
 246  if (WriteFile(s->h,vbuf,count,&len,NULL))
 247   {
 248    return len;
 249   }
 250  else
 251   {
 252    PerlIOBase(f)->flags |= PERLIO_F_ERROR;
 253    PerlIO_save_errno(f);
 254    return -1;
 255   }
 256 }
 257
 258 IV
 259 PerlIOWin32_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
 260 {
 261  static const DWORD where[3] = { FILE_BEGIN, FILE_CURRENT, FILE_END };
 262  PerlIOWin32 *s = PerlIOSelf(f,PerlIOWin32);
 263  DWORD high = (sizeof(offset) > sizeof(DWORD)) ? (DWORD)(offset >> 32) : 0;
 264  DWORD low  = (DWORD) offset;
 265  DWORD res  = SetFilePointer(s->h,low,&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,&high,FILE_CURRENT);
 282  if (res != 0xFFFFFFFF || GetLastError() != NO_ERROR)
 283   {
 284    return ((Off_t) high << 32) | res;
 285   }
 286  return (Off_t) -1;
 287 }
 288
 289 IV
 290 PerlIOWin32_close(pTHX_ PerlIO *f)
 291 {
 292  PerlIOWin32 *s = PerlIOSelf(f,PerlIOWin32);
 293  if (s->refcnt == 1)
 294   {
 295    IV code = 0;
 296 #if 0
 297    /* This does not do pipes etc. correctly */
 298    if (!CloseHandle(s->h))
 299     {
 300      s->h = INVALID_HANDLE_VALUE;
 301      return -1;
 302     }
 303 #else
 304     PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
 305     return win32_close(s->fd);
 306 #endif
 307   }
 308  return 0;
 309 }
 310
 311 PerlIO *
 312 PerlIOWin32_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *params, int flags)
 313 {
 314  PerlIOWin32 *os = PerlIOSelf(f,PerlIOWin32);
 315  HANDLE proc = GetCurrentProcess();
 316  HANDLE new;
 317  if (DuplicateHandle(proc, os->h, proc, &new, 0, FALSE,  DUPLICATE_SAME_ACCESS))
 318   {
 319    char mode[8];
 320    int fd = win32_open_osfhandle((intptr_t) new, PerlIOUnix_oflags(PerlIO_modestr(o,mode)));
 321    if (fd >= 0)
 322     {
 323      f = PerlIOBase_dup(aTHX_ f, o, params, flags);
 324      if (f)
 325       {
 326        PerlIOWin32 *fs = PerlIOSelf(f,PerlIOWin32);
 327        fs->h  = new;
 328        fs->fd = fd;
 329        fs->refcnt = 1;
 330        fdtable[fd] = fs;
 331        if (fd > max_open_fd)
 332         max_open_fd = fd;
 333       }
 334      else
 335       {
 336        win32_close(fd);
 337       }
 338     }
 339    else
 340     {
 341      CloseHandle(new);
 342     }
 343   }
 344  return f;
 345 }
 346
 347 PerlIO_funcs PerlIO_win32 = {
 348  sizeof(PerlIO_funcs),
 349  "win32",
 350  sizeof(PerlIOWin32),
 351  PERLIO_K_RAW,
 352  PerlIOWin32_pushed,
 353  PerlIOWin32_popped,
 354  PerlIOWin32_open,
 355  PerlIOBase_binmode,
 356  NULL,                 /* getarg */
 357  PerlIOWin32_fileno,
 358  PerlIOWin32_dup,
 359  PerlIOWin32_read,
 360  PerlIOBase_unread,
 361  PerlIOWin32_write,
 362  PerlIOWin32_seek,
 363  PerlIOWin32_tell,
 364  PerlIOWin32_close,
 365  PerlIOBase_noop_ok,   /* flush */
 366  PerlIOBase_noop_fail, /* fill */
 367  PerlIOBase_eof,
 368  PerlIOBase_error,
 369  PerlIOBase_clearerr,
 370  PerlIOBase_setlinebuf,
 371  NULL, /* get_base */
 372  NULL, /* get_bufsiz */
 373  NULL, /* get_ptr */
 374  NULL, /* get_cnt */
 375  NULL, /* set_ptrcnt */
 376 };
 377
 378 #endif
 379