PERL_IMPLICIT_SYS (almost) works - something odd with "signal"

p4raw-id: //depot/perlio@7983

8 files changed, 115 insertions, 34 deletions

diff --git a/iperlsys.h b/iperlsys.h
index a7bd2b5e2f..66d2b8ebb0 100644
--- a/iperlsys.h
+++ b/iperlsys.h
@@ -902,6 +902,7 @@ typedef int		(*LPProcSpawnvp)(struct IPerlProc*, int, const char*,
 			    const char*const*);
 typedef int		(*LPProcASpawn)(struct IPerlProc*, void*, void**, void**);
 #endif
+typedef int		(*LPProcLastHost)(struct IPerlProc*);
 
 struct IPerlProc
 {
@@ -940,6 +941,7 @@ struct IPerlProc
     LPProcSpawnvp	pSpawnvp;
     LPProcASpawn	pASpawn;
 #endif
+    LPProcLastHost      pLastHost;
 };
 
 struct IPerlProcInfo
@@ -1019,6 +1021,8 @@ struct IPerlProcInfo
 #define PerlProc_aspawn(m,c,a)						\
 	(*PL_Proc->pASpawn)(PL_Proc, (m), (c), (a))
 #endif
+#define PerlProc_lasthost()						\
+	(*PL_Proc->pLastHost)(PL_Proc)
 
 #else	/* PERL_IMPLICIT_SYS */
 
diff --git a/perl.c b/perl.c
index 0ebd935941..f1cda0e829 100644
--- a/perl.c
+++ b/perl.c
@@ -788,6 +788,8 @@ perl_free(pTHXx)
 #else
 #  if defined(PERL_IMPLICIT_SYS) && defined(WIN32)
     void *host = w32_internal_host;
+    if (PerlProc_lasthost())
+	PerlIO_cleanup();     
     PerlMem_free(aTHXx);
     win32_delete_internal_host(host);
 #  else
diff --git a/perlio.c b/perlio.c
index b0517e394f..d6b3b0841a 100644
--- a/perlio.c
+++ b/perlio.c
@@ -28,6 +28,12 @@
 #define PERL_IN_PERLIO_C
 #include "perl.h"
 
+#undef PerlMemShared_calloc
+#define PerlMemShared_calloc(x,y) calloc(x,y)
+#undef PerlMemShared_free
+#define PerlMemShared_free(x) free(x)
+
+
 #ifndef PERLIO_LAYERS
 int
 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
@@ -211,11 +217,12 @@ PerlIO *_perlio      = NULL;
 #define PERLIO_TABLE_SIZE 64
 
 PerlIO *
-PerlIO_allocate(void)
+PerlIO_allocate(pTHX)
 {
  /* Find a free slot in the table, allocating new table as necessary */
- PerlIO **last = &_perlio;
+ PerlIO **last;
  PerlIO *f;
+ last = &_perlio;
  while ((f = *last))
   {
    int i;
@@ -228,21 +235,23 @@ PerlIO_allocate(void)
       }
     }
   }
- Newz('I',f,PERLIO_TABLE_SIZE,PerlIO);
+ f = PerlMemShared_calloc(PERLIO_TABLE_SIZE,sizeof(PerlIO));
  if (!f)
-  return NULL;
+  {
+   return NULL;
+  } 
  *last = f;
  return f+1;
 }
 
 void
-PerlIO_cleantable(PerlIO **tablep)
+PerlIO_cleantable(pTHX_ PerlIO **tablep)
 {
  PerlIO *table = *tablep;
  if (table)
   {
    int i;
-   PerlIO_cleantable((PerlIO **) &(table[0]));
+   PerlIO_cleantable(aTHX_ (PerlIO **) &(table[0]));
    for (i=PERLIO_TABLE_SIZE-1; i > 0; i--)
     {
      PerlIO *f = table+i;
@@ -251,7 +260,7 @@ PerlIO_cleantable(PerlIO **tablep)
        PerlIO_close(f);
       }
     }
-   Safefree(table);
+   PerlMemShared_free(table);
    *tablep = NULL;
   }
 }
@@ -260,21 +269,23 @@ HV *PerlIO_layer_hv;
 AV *PerlIO_layer_av;
 
 void
-PerlIO_cleanup(void)
+PerlIO_cleanup()
 {
- PerlIO_cleantable(&_perlio);
+ dTHX;
+ PerlIO_cleantable(aTHX_ &_perlio);
 }
 
 void
 PerlIO_pop(PerlIO *f)
 {
+ dTHX;
  PerlIOl *l = *f;
  if (l)
   {
    PerlIO_debug("PerlIO_pop f=%p %s\n",f,l->tab->name);
    (*l->tab->Popped)(f);
    *f = l->next;
-   Safefree(l);
+   PerlMemShared_free(l);
   }
 }
 
@@ -500,7 +511,8 @@ PerlIO_stdstreams()
 {
  if (!_perlio)
   {
-   PerlIO_allocate();
+   dTHX;
+   PerlIO_allocate(aTHX);
    PerlIO_fdopen(0,"Ir" PERLIO_STDTEXT);
    PerlIO_fdopen(1,"Iw" PERLIO_STDTEXT);
    PerlIO_fdopen(2,"Iw" PERLIO_STDTEXT);
@@ -510,8 +522,9 @@ PerlIO_stdstreams()
 PerlIO *
 PerlIO_push(PerlIO *f,PerlIO_funcs *tab,const char *mode)
 {
+ dTHX;
  PerlIOl *l = NULL;
- Newc('L',l,tab->size,char,PerlIOl);
+ l = PerlMemShared_calloc(tab->size,sizeof(char));
  if (l)
   {
    Zero(l,tab->size,char);
@@ -618,6 +631,20 @@ PerlIO__close(PerlIO *f)
  return (*PerlIOBase(f)->tab->Close)(f);
 }
 
+#undef PerlIO_fdupopen
+PerlIO *
+PerlIO_fdupopen(pTHX_ PerlIO *f)
+{
+ char buf[8];
+ int fd = PerlLIO_dup(PerlIO_fileno(f));
+ PerlIO *new = PerlIO_fdopen(fd,PerlIO_modestr(f,buf));
+ if (new)
+  {
+   Off_t posn = PerlIO_tell(f);
+   PerlIO_seek(new,posn,SEEK_SET);
+  }
+ return new; 
+}
 
 #undef PerlIO_close
 int
@@ -898,14 +925,32 @@ PerlIO_modestr(PerlIO *f,char *buf)
 {
  char *s = buf;
  IV flags = PerlIOBase(f)->flags;
- if (flags & PERLIO_F_CANREAD)
-  *s++ = 'r';
- if (flags & PERLIO_F_CANWRITE)
-  *s++ = 'w';
- if (flags & PERLIO_F_CRLF)
-  *s++ = 't';
- else
+ if (flags & PERLIO_F_APPEND)
+  {
+   *s++ = 'a';
+   if (flags & PERLIO_F_CANREAD)
+    {
+     *s++ = '+';
+    }
+  } 
+ else if (flags & PERLIO_F_CANREAD)
+  {
+   *s++ = 'r';
+   if (flags & PERLIO_F_CANWRITE)
+    *s++ = '+';
+  }
+ else if (flags & PERLIO_F_CANWRITE)
+  {
+   *s++ = 'w';
+   if (flags & PERLIO_F_CANREAD)
+    {
+     *s++ = '+';
+    }
+  }
+#if O_TEXT != O_BINARY
+ if (!(flags & PERLIO_F_CRLF))
   *s++ = 'b';
+#endif
  *s = '\0';
  return buf;
 }
@@ -1142,6 +1187,7 @@ PerlIOUnix_fileno(PerlIO *f)
 PerlIO *
 PerlIOUnix_fdopen(PerlIO_funcs *self, int fd,const char *mode)
 {
+ dTHX;
  PerlIO *f = NULL;
  if (*mode == 'I')
   mode++;
@@ -1150,7 +1196,7 @@ PerlIOUnix_fdopen(PerlIO_funcs *self, int fd,const char *mode)
    int oflags = PerlIOUnix_oflags(mode);
    if (oflags != -1)
     {
-     PerlIOUnix *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),self,mode),PerlIOUnix);
+     PerlIOUnix *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX),self,mode),PerlIOUnix);
      s->fd     = fd;
      s->oflags = oflags;
      PerlIOBase(f)->flags |= PERLIO_F_OPEN;
@@ -1170,7 +1216,7 @@ PerlIOUnix_open(PerlIO_funcs *self, const char *path,const char *mode)
    int fd = PerlLIO_open3(path,oflags,0666);
    if (fd >= 0)
     {
-     PerlIOUnix *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),self,mode),PerlIOUnix);
+     PerlIOUnix *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX),self,mode),PerlIOUnix);
      s->fd     = fd;
      s->oflags = oflags;
      PerlIOBase(f)->flags |= PERLIO_F_OPEN;
@@ -1374,7 +1420,7 @@ PerlIOStdio_fdopen(PerlIO_funcs *self, int fd,const char *mode)
     }
    if (stdio)
     {
-     PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),self,mode),PerlIOStdio);
+     PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX),self,mode),PerlIOStdio);
      s->stdio  = stdio;
     }
   }
@@ -1385,10 +1431,11 @@ PerlIOStdio_fdopen(PerlIO_funcs *self, int fd,const char *mode)
 PerlIO *
 PerlIO_importFILE(FILE *stdio, int fl)
 {
+ dTHX;
  PerlIO *f = NULL;
  if (stdio)
   {
-   PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),&PerlIO_stdio,"r+"),PerlIOStdio);
+   PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX),&PerlIO_stdio,"r+"),PerlIOStdio);
    s->stdio  = stdio;
   }
  return f;
@@ -1403,7 +1450,7 @@ PerlIOStdio_open(PerlIO_funcs *self, const char *path,const char *mode)
  if (stdio)
   {
    char tmode[8];
-   PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(), self,
+   PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX), self,
                                (mode = PerlIOStdio_mode(mode,tmode))),
                                PerlIOStdio);
    s->stdio  = stdio;
@@ -2055,11 +2102,12 @@ PerlIOBuf_tell(PerlIO *f)
 IV
 PerlIOBuf_close(PerlIO *f)
 {
+ dTHX;
  IV code = PerlIOBase_close(f);
  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
  if (b->buf && b->buf != (STDCHAR *) &b->oneword)
   {
-   Safefree(b->buf);
+   PerlMemShared_free(b->buf);
   }
  b->buf = NULL;
  b->ptr = b->end = b->buf;
@@ -2102,9 +2150,10 @@ PerlIOBuf_get_base(PerlIO *f)
  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
  if (!b->buf)
   {
+   dTHX;
    if (!b->bufsiz)
     b->bufsiz = 4096;
-   New('B',b->buf,b->bufsiz,STDCHAR);
+   b->buf = PerlMemShared_calloc(b->bufsiz,sizeof(STDCHAR));
    if (!b->buf)
     {
      b->buf = (STDCHAR *)&b->oneword;
@@ -2204,7 +2253,8 @@ PerlIOPending_flush(PerlIO *f)
  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
  if (b->buf && b->buf != (STDCHAR *) &b->oneword)
   {
-   Safefree(b->buf);
+   dTHX;
+   PerlMemShared_free(b->buf);
    b->buf = NULL;
   }
  PerlIO_pop(f);
@@ -3051,7 +3101,7 @@ PerlIO_tmpfile(void)
  FILE *stdio = PerlSIO_tmpfile();
  if (stdio)
   {
-   PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),&PerlIO_stdio,"w+"),PerlIOStdio);
+   PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX),&PerlIO_stdio,"w+"),PerlIOStdio);
    s->stdio  = stdio;
   }
  return f;
diff --git a/perlio.h b/perlio.h
index b2aa0aad97..574b741c79 100644
--- a/perlio.h
+++ b/perlio.h
@@ -305,8 +305,10 @@ extern int	PerlIO_getpos		(PerlIO *,Fpos_t *);
 extern int	PerlIO_setpos		(PerlIO *,const Fpos_t *);
 #endif
 #ifndef PerlIO_fdupopen
-#define PerlIO_fdupopen(f)		(f)
-/* extern PerlIO *	PerlIO_fdupopen		(PerlIO *); */
+extern PerlIO *	PerlIO_fdupopen		(pTHX_ PerlIO *);
+#endif
+#ifndef PerlIO_modestr
+extern char *PerlIO_modestr		(PerlIO *,char *buf);
 #endif
 #ifndef PerlIO_isutf8
 extern int	PerlIO_isutf8		(PerlIO *);
@@ -318,7 +320,7 @@ extern int	PerlIO_apply_layers	(pTHX_ PerlIO *f, const char *mode, const char *n
 extern int	PerlIO_binmode		(pTHX_ PerlIO *f, int iotype, int omode, const char *names);
 #endif
 
-extern void PerlIO_cleanup(void);
+extern void PerlIO_cleanup();
 
 extern void PerlIO_debug(const char *fmt,...);
 
diff --git a/perliol.h b/perliol.h
index a2581b2664..19cf95f620 100644
--- a/perliol.h
+++ b/perliol.h
@@ -82,7 +82,7 @@ extern PerlIO_funcs PerlIO_crlf;
 extern PerlIO_funcs PerlIO_mmap;
 #endif
 
-extern PerlIO *PerlIO_allocate(void);
+extern PerlIO *PerlIO_allocate(pTHX);
 
 #if O_BINARY != O_TEXT
 #define PERLIO_STDTEXT "t"
diff --git a/sv.c b/sv.c
index 01076cbe02..6658552ec0 100644
--- a/sv.c
+++ b/sv.c
@@ -6789,7 +6789,7 @@ Perl_fp_dup(pTHX_ PerlIO *fp, char type)
 	return ret;
 
     /* create anew and remember what it is */
-    ret = PerlIO_fdupopen(fp);
+    ret = PerlIO_fdupopen(aTHX_ fp);
     ptr_table_store(PL_ptr_table, fp, ret);
     return ret;
 }
diff --git a/t/op/fork.t b/t/op/fork.t
index 88b6b4b74c..fbcd0987fe 100755
--- a/t/op/fork.t
+++ b/t/op/fork.t
@@ -8,7 +8,9 @@ BEGIN {
     require Config; import Config;
     unless ($Config{'d_fork'}
 	    or ($^O eq 'MSWin32' and $Config{useithreads}
-		and $Config{ccflags} =~ /-DPERL_IMPLICIT_SYS/))
+		and $Config{ccflags} =~ /-DPERL_IMPLICIT_SYS/ 
+#               and !defined $Config{'useperlio'}
+               ))
     {
 	print "1..0 # Skip: no fork\n";
 	exit 0;
diff --git a/win32/perlhost.h b/win32/perlhost.h
index 28f0168cee..a260d0895d 100644
--- a/win32/perlhost.h
+++ b/win32/perlhost.h
@@ -35,6 +35,7 @@ extern int		g_do_aspawn(void *vreally, void **vmark, void **vsp);
 class CPerlHost
 {
 public:
+    /* Constructors */
     CPerlHost(void);
     CPerlHost(struct IPerlMem** ppMem, struct IPerlMem** ppMemShared,
 		 struct IPerlMem** ppMemParse, struct IPerlEnv** ppEnv,
@@ -197,8 +198,13 @@ protected:
 
     DWORD   m_dwEnvCount;
     LPSTR*  m_lppEnvList;
+    static long num_hosts;
+public:
+    inline  int LastHost(void) { return num_hosts == 1L; };
 };
 
+long CPerlHost::num_hosts = 0L;
+
 
 #define STRUCT2PTR(x, y) (CPerlHost*)(((LPBYTE)x)-offsetof(CPerlHost, y))
 
@@ -1844,6 +1850,14 @@ PerlProcASpawn(struct IPerlProc* piPerl, void *vreally, void **vmark, void **vsp
     return do_aspawn(vreally, vmark, vsp);
 }
 
+int
+PerlProcLastHost(struct IPerlProc* piPerl)
+{
+ dTHXo;
+ CPerlHost *h = (CPerlHost*)w32_internal_host;
+ return h->LastHost();
+}
+
 struct IPerlProc perlProc =
 {
     PerlProcAbort,
@@ -1879,6 +1893,7 @@ struct IPerlProc perlProc =
     PerlProcSpawn,
     PerlProcSpawnvp,
     PerlProcASpawn,
+    PerlProcLastHost
 };
 
 
@@ -1888,6 +1903,8 @@ struct IPerlProc perlProc =
 
 CPerlHost::CPerlHost(void)
 {
+    /* Construct a host from scratch */
+    InterlockedIncrement(&num_hosts);
     m_pvDir = new VDir();
     m_pVMem = new VMem();
     m_pVMemShared = new VMem();
@@ -1936,6 +1953,7 @@ CPerlHost::CPerlHost(struct IPerlMem** ppMem, struct IPerlMem** ppMemShared,
 		 struct IPerlDir** ppDir, struct IPerlSock** ppSock,
 		 struct IPerlProc** ppProc)
 {
+    InterlockedIncrement(&num_hosts);
     m_pvDir = new VDir(0);
     m_pVMem = new VMem();
     m_pVMemShared = new VMem();
@@ -1970,6 +1988,8 @@ CPerlHost::CPerlHost(struct IPerlMem** ppMem, struct IPerlMem** ppMemShared,
 
 CPerlHost::CPerlHost(CPerlHost& host)
 {
+    /* Construct a host from another host */
+    InterlockedIncrement(&num_hosts);
     m_pVMem = new VMem();
     m_pVMemShared = host.GetMemShared();
     m_pVMemParse =  host.GetMemParse();
@@ -2010,6 +2030,7 @@ CPerlHost::CPerlHost(CPerlHost& host)
 CPerlHost::~CPerlHost(void)
 {
 //  Reset();
+    InterlockedDecrement(&num_hosts);
     delete m_pvDir;
     m_pVMemParse->Release();
     m_pVMemShared->Release();