From: Nick Ing-Simmons <nik@tiuk.ti.com>
Date: Sun, 25 Mar 2001 20:58:15 +0000 (+0000)
Subject: Add destruct time hook to PerlIO (for work-in-process implementing
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=13621cfb31449eed71b690b723c2463019b1b277;p=p5sagit%2Fp5-mst-13.2.git

Add destruct time hook to PerlIO (for work-in-process implementing
layers in perl code. In such cases layers need to be popped before
we loose the ability to run perl code.)
Also back-out "PerlIO::object" hook - it isn't going to work like that...

p4raw-id: //depot/perlio@9346
---

diff --git a/perl.c b/perl.c
index b3637fc..41ffdaa 100644
--- a/perl.c
+++ b/perl.c
@@ -395,6 +395,7 @@ perl_destruct(pTHXx)
     LEAVE;
     FREETMPS;
 
+
     /* We must account for everything.  */
 
     /* Destroy the main CV and syntax tree */
@@ -409,6 +410,13 @@ perl_destruct(pTHXx)
     PL_main_cv = Nullcv;
     PL_dirty = TRUE;
 
+    /* Tell PerlIO we are about to tear things apart in case
+       we have layers which are using resources that should
+       be cleaned up now.
+     */
+
+    PerlIO_destruct(aTHX);
+
     if (PL_sv_objcount) {
 	/*
 	 * Try to destruct global references.  We do this first so that the
diff --git a/perlio.c b/perlio.c
index 94b7c17..d33c0cb 100644
--- a/perlio.c
+++ b/perlio.c
@@ -93,6 +93,11 @@ PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
  return -1;
 }
 
+void
+PerlIO_destruct(pTHX)
+{
+}
+
 int
 PerlIO_binmode(pTHX_ PerlIO *fp, int iotype, int mode, const char *names)
 {
@@ -313,6 +318,37 @@ PerlIO_cleanup()
 }
 
 void
+PerlIO_destruct(pTHX)
+{
+ PerlIO **table = &_perlio;
+ PerlIO *f;
+ while ((f = *table))
+  {
+   int i;
+   table = (PerlIO **)(f++);
+   for (i=1; i < PERLIO_TABLE_SIZE; i++)
+    {
+     PerlIO *x = f;
+     PerlIOl *l;
+     while ((l = *x))
+      {
+       if (l->tab->kind & PERLIO_K_DESTRUCT)
+        {
+         PerlIO_debug("Destruct popping %s\n",l->tab->name);
+         PerlIO_flush(x);
+         PerlIO_pop(aTHX_ x);
+        }
+       else
+        {
+         x = PerlIONext(x);
+        }
+      }
+     f++;
+    }
+  }
+}
+
+void
 PerlIO_pop(pTHX_ PerlIO *f)
 {
  PerlIOl *l = *f;
@@ -888,11 +924,11 @@ PerlIO_resolve_layers(pTHX_ const char *layers,const char *mode,int narg, SV **a
   PerlIO_stdstreams(aTHX);
  if (narg)
   {
-   if (SvROK(*args))
+   if (SvROK(*args) && !sv_isobject(*args))
     {
-     if (sv_isobject(*args))
+     if (SvTYPE(SvRV(*args)) < SVt_PVAV)
       {
-       SV *handler = PerlIO_find_layer(aTHX_ "object",6);
+       SV *handler = PerlIO_find_layer(aTHX_ "Scalar",6);
        if (handler)
         {
          def    = newAV();
@@ -903,21 +939,7 @@ PerlIO_resolve_layers(pTHX_ const char *layers,const char *mode,int narg, SV **a
       }
      else
       {
-       if (SvTYPE(SvRV(*args)) < SVt_PVAV)
-        {
-         SV *handler = PerlIO_find_layer(aTHX_ "Scalar",6);
-         if (handler)
-          {
-           def    = newAV();
-           av_push(def,handler);
-           av_push(def,&PL_sv_undef);
-           incdef = 0;
-          }
-        }
-       else
-        {
-         Perl_croak(aTHX_ "Unsupported reference arg to open()");
-        }
+       Perl_croak(aTHX_ "Unsupported reference arg to open()");
       }
     }
   }
diff --git a/perlio.h b/perlio.h
index ce28c8d..cd722a1 100644
--- a/perlio.h
+++ b/perlio.h
@@ -327,6 +327,8 @@ 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_destruct(pTHX);
+
 #ifndef PERLIO_IS_STDIO
 
 extern void PerlIO_cleanup(void);
diff --git a/perliol.h b/perliol.h
index 449ea89..d4604e2 100644
--- a/perliol.h
+++ b/perliol.h
@@ -46,6 +46,7 @@ struct _PerlIO_funcs
 #define PERLIO_K_FASTGETS	0x00000008
 #define PERLIO_K_DUMMY		0x00000010
 #define PERLIO_K_UTF8		0x00008000
+#define PERLIO_K_DESTRUCT	0x00010000
 
 /*--------------------------------------------------------------------------------------*/
 struct _PerlIO