This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
https://perl5.git.perl.org / perl5.git / blobdiff
? search:
summary | shortlog | log | commit | commitdiff | tree
raw | inline | side by side
Hexadecimal float sprintf, for perl #122219
[perl5.git] / win32 / win32io.c
diff --git a/win32/win32io.c b/win32/win32io.c
index e75919f..0483602 100644 (file)
--- a/win32/win32io.c
+++ b/win32/win32io.c
@@ -10,11 +10,15 @@
 #include <sys/stat.h>
 #include "EXTERN.h"
 #include "perl.h"
-#include "perllio.h"
+
+#ifdef PERLIO_LAYERS
+
+#include "perliol.h"
 
 #define NO_XSLOCKS
 #include "XSUB.h"
 
+
 /* Bottom-most level for Win32 case */
 
 typedef struct
@@ -29,7 +33,7 @@ PerlIOWin32 *fdtable[256];
 IV max_open_fd = -1;
 
 IV
-PerlIOWin32_popped(PerlIO *f)
+PerlIOWin32_popped(pTHX_ PerlIO *f)
 {
  PerlIOWin32 *s = PerlIOSelf(f,PerlIOWin32);
  if (--s->refcnt > 0)
@@ -42,21 +46,26 @@ PerlIOWin32_popped(PerlIO *f)
 }
 
 IV
-PerlIOWin32_fileno(PerlIO *f)
+PerlIOWin32_fileno(pTHX_ PerlIO *f)
 {
  return PerlIOSelf(f,PerlIOWin32)->fd;
 }
 
 IV
-PerlIOWin32_pushed(PerlIO *f, const char *mode, SV *arg)
+PerlIOWin32_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
 {
- IV code = PerlIOBase_pushed(f,mode,arg);
+ IV code = PerlIOBase_pushed(aTHX_ f,mode,arg,tab);
  if (*PerlIONext(f))
   {
    PerlIOWin32 *s = PerlIOSelf(f,PerlIOWin32);
    s->fd     = PerlIO_fileno(PerlIONext(f));
   }
  PerlIOBase(f)->flags |= PERLIO_F_OPEN;
+
+ Perl_ck_warner_d(aTHX_
+                 packWARN(WARN_EXPERIMENTAL__WIN32_PERLIO),
+                 "PerlIO layer ':win32' is experimental");
+
  return code;
 }
 
@@ -69,7 +78,7 @@ PerlIOWin32_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers, IV n, const ch
   {
    /* Close if already open */
    if (PerlIOBase(f)->flags & PERLIO_F_OPEN)
-    (*PerlIOBase(f)->tab->Close)(f);
+    (*PerlIOBase(f)->tab->Close)(aTHX_ f);
   }
  if (narg > 0)
   {
@@ -131,7 +140,7 @@ PerlIOWin32_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers, IV n, const ch
     {
      mode++;
     }
-   if (*mode || oflags == -1)
+   if (*mode || create == -1)
     {
      SETERRNO(EINVAL,LIB$_INVARG);
      return NULL;
@@ -142,7 +151,7 @@ PerlIOWin32_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers, IV n, const ch
    if (h == INVALID_HANDLE_VALUE)
     {
      if (create == TRUNCATE_EXISTING)
-      h = CreateFile(path,access,share = OPEN_ALWAYS,NULL,create,attr,NULL);
+      h = CreateFile(path,access,share,NULL,(create = OPEN_ALWAYS),attr,NULL);
     }
   }
  else
@@ -160,32 +169,41 @@ PerlIOWin32_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers, IV n, const ch
        *f = &s->base;
        return f;
       }
-     if (*mode == 'I')
+    }
+   if (*mode == 'I')
+    {
+     mode++;
+     switch(fd)
       {
-       mode++;
-       switch(fd)
-        {
-         case 0:
-          h = GetStandardHandle(STD_INPUT_HANDLE);
-          break;
-         case 1:
-          h = GetStandardHandle(STD_OUTPUT_HANDLE);
-          break;
-         case 2:
-          h = GetStandardHandle(STD_ERROR_HANDLE);
-          break;
-        }
+       case 0:
+        h = GetStdHandle(STD_INPUT_HANDLE);
+        break;
+       case 1:
+        h = GetStdHandle(STD_OUTPUT_HANDLE);
+        break;
+       case 2:
+        h = GetStdHandle(STD_ERROR_HANDLE);
+        break;
       }
     }
   }
  if (h != INVALID_HANDLE_VALUE)
+  fd = win32_open_osfhandle((intptr_t) h, PerlIOUnix_oflags(tmode));
+ if (fd >= 0)
   {
    PerlIOWin32 *s;
    if (!f)
     f = PerlIO_allocate(aTHX);
    s = PerlIOSelf(PerlIO_push(aTHX_ f,self,tmode,PerlIOArg),PerlIOWin32);
-   s->ioh    = h;
+   s->h      = h;
+   s->fd     = fd;
    s->refcnt = 1;
+   if (fd >= 0)
+    {
+     fdtable[fd] = s;
+     if (fd > max_open_fd)
+      max_open_fd = fd;
+    }
    return f;
   }
  if (f)
@@ -196,13 +214,13 @@ PerlIOWin32_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers, IV n, const ch
 }
 
 SSize_t
-PerlIOWin32_read(PerlIO *f, void *vbuf, Size_t count)
+PerlIOWin32_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
 {
  PerlIOWin32 *s = PerlIOSelf(f,PerlIOWin32);
  DWORD len;
  if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
   return 0;
- if (ReadFile(s->h,vbuf,count,&len,NULL)
+ if (ReadFile(s->h,vbuf,count,&len,NULL))
   {
    return len;
   }
@@ -223,11 +241,11 @@ PerlIOWin32_read(PerlIO *f, void *vbuf, Size_t count)
 }
 
 SSize_t
-PerlIOWin32_write(PerlIO *f, const void *vbuf, Size_t count)
+PerlIOWin32_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
 {
  PerlIOWin32 *s = PerlIOSelf(f,PerlIOWin32);
  DWORD len;
- if (WriteFile(s->h,vbuf,count,&len,NULL)
+ if (WriteFile(s->h,vbuf,count,&len,NULL))
   {
    return len;
   }
@@ -239,13 +257,17 @@ PerlIOWin32_write(PerlIO *f, const void *vbuf, Size_t count)
 }
 
 IV
-PerlIOWin32_seek(PerlIO *f, Off_t offset, int whence)
+PerlIOWin32_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
 {
  static const DWORD where[3] = { FILE_BEGIN, FILE_CURRENT, FILE_END };
  PerlIOWin32 *s = PerlIOSelf(f,PerlIOWin32);
- DWORD high = (sizeof(offset) > sizeof(DWORD)) ? (DWORD)(offset >> 32) : 0;
+#if Off_t_size >= 8
+ DWORD high = (DWORD)(offset >> 32);
+#else
+ DWORD high = 0;
+#endif
  DWORD low  = (DWORD) offset;
- DWORD res  = SetFilePointer(s->h,low,&high,where[whence]);
+ DWORD res  = SetFilePointer(s->h,(LONG)low,(LONG *)&high,where[whence]);
  if (res != 0xFFFFFFFF || GetLastError() != NO_ERROR)
   {
    return 0;
@@ -257,43 +279,92 @@ PerlIOWin32_seek(PerlIO *f, Off_t offset, int whence)
 }
 
 Off_t
-PerlIOWin32_tell(PerlIO *f)
+PerlIOWin32_tell(pTHX_ PerlIO *f)
 {
  PerlIOWin32 *s = PerlIOSelf(f,PerlIOWin32);
  DWORD high = 0;
- DWORD res  = SetFilePointer(s->h,0,&high,FILE_CURRENT);
+ DWORD res  = SetFilePointer(s->h,0,(LONG *)&high,FILE_CURRENT);
  if (res != 0xFFFFFFFF || GetLastError() != NO_ERROR)
   {
+#if Off_t_size >= 8
    return ((Off_t) high << 32) | res;
+#else
+   return res;
+#endif
   }
  return (Off_t) -1;
 }
 
 IV
-PerlIOWin32_close(PerlIO *f)
+PerlIOWin32_close(pTHX_ PerlIO *f)
 {
  PerlIOWin32 *s = PerlIOSelf(f,PerlIOWin32);
  if (s->refcnt == 1)
   {
-   if (CloseHandle(s->h))
+   IV code = 0;        
+#if 0
+   /* This does not do pipes etc. correctly */ 
+   if (!CloseHandle(s->h))
     {
      s->h = INVALID_HANDLE_VALUE;
      return -1;
     }
+#else
+    PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
+    return win32_close(s->fd);
+#endif
   }
- PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
  return 0;
 }
 
-PerlIO_funcs PerlIO_win32 = {
+PerlIO *
+PerlIOWin32_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *params, int flags)
+{
+ PerlIOWin32 *os = PerlIOSelf(f,PerlIOWin32);
+ HANDLE proc = GetCurrentProcess();
+ HANDLE new_h;
+ if (DuplicateHandle(proc, os->h, proc, &new_h, 0, FALSE,  DUPLICATE_SAME_ACCESS))
+  {
+   char mode[8];
+   int fd = win32_open_osfhandle((intptr_t) new_h, PerlIOUnix_oflags(PerlIO_modestr(o,mode)));
+   if (fd >= 0)
+    {
+     f = PerlIOBase_dup(aTHX_ f, o, params, flags);
+     if (f)
+      {
+       PerlIOWin32 *fs = PerlIOSelf(f,PerlIOWin32);
+       fs->h  = new_h;
+       fs->fd = fd;
+       fs->refcnt = 1;
+       fdtable[fd] = fs;
+       if (fd > max_open_fd)
+        max_open_fd = fd;
+      }
+     else
+      {
+       win32_close(fd);
+      }
+    }
+   else
+    {
+     CloseHandle(new_h);
+    }
+  }
+ return f;
+}
+
+PERLIO_FUNCS_DECL(PerlIO_win32) = {
+ sizeof(PerlIO_funcs),
  "win32",
  sizeof(PerlIOWin32),
  PERLIO_K_RAW,
  PerlIOWin32_pushed,
  PerlIOWin32_popped,
  PerlIOWin32_open,
+ PerlIOBase_binmode,
  NULL,                 /* getarg */
  PerlIOWin32_fileno,
+ PerlIOWin32_dup,
  PerlIOWin32_read,
  PerlIOBase_unread,
  PerlIOWin32_write,
@@ -313,4 +384,5 @@ PerlIO_funcs PerlIO_win32 = {
  NULL, /* set_ptrcnt */
 };
 
+#endif
 
Unnamed repository; edit this file 'description' to name the repository.