Re: UNTIE method

Message-Id: <200008301726.SAA01114@mikado.tiuk.ti.com>

p4raw-id: //depot/perl@6925

2 files changed, 31 insertions, 4 deletions

diff --git a/pp_sys.c b/pp_sys.c
index a95c43c945..371c4a38ff 100644
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -808,16 +808,28 @@ PP(pp_untie)
     SV *sv = POPs;
     char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) ? 'P' : 'q';
 
-    if (ckWARN(WARN_UNTIE)) {
         MAGIC * mg ;
         if ((mg = SvTIED_mg(sv, how))) {
-            if (mg && SvREFCNT(SvRV(mg->mg_obj)) > 1)  
+	SV *obj = SvRV(mg->mg_obj);
+	GV *gv;
+	CV *cv = NULL;
+        if (ckWARN(WARN_UNTIE)) {
+	    if (mg && SvREFCNT(obj) > 1)
 		Perl_warner(aTHX_ WARN_UNTIE,
 		    "untie attempted while %"UVuf" inner references still exist",
-		    (UV)SvREFCNT(SvRV(mg->mg_obj)) - 1 ) ;
+		    (UV)SvREFCNT(obj) - 1 ) ;
+        }
+	if ((gv = gv_fetchmethod_autoload(SvSTASH(obj), "UNTIE", FALSE)) &&
+            isGV(gv) && (cv = GvCV(gv))) {
+	    PUSHMARK(SP);
+	    XPUSHs(SvTIED_obj((SV*)gv, mg));
+	    PUTBACK;
+	    ENTER;
+	    call_sv((SV *)cv, G_VOID);
+	    LEAVE;
+	    SPAGAIN;
         }
     }
- 
     sv_unmagic(sv, how);
     RETPUSHYES;
 }
diff --git a/t/op/tie.t b/t/op/tie.t
index 696a9265fb..cbf92c6d27 100755
--- a/t/op/tie.t
+++ b/t/op/tie.t
@@ -44,6 +44,21 @@ untie %h;
 EXPECT
 ########
 
+# standard behaviour, without any extra references
+use Tie::Hash ;
+{package Tie::HashUntie;
+ use base 'Tie::StdHash';
+ sub UNTIE
+  {
+   warn "Untied\n";
+  }
+}
+tie %h, Tie::HashUntie;
+untie %h;
+EXPECT
+Untied
+########
+
 # standard behaviour, with 1 extra reference
 use Tie::Hash ;
 $a = tie %h, Tie::StdHash;