From: Nick Ing-Simmons <nik@tiuk.ti.com>
Date: Sat, 17 Jan 1998 12:01:53 +0000 (+0000)
Subject: Permit tie ?foo,$object
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=6b05c17a079e3919ac102e3343b897f03d975d7b;p=p5sagit%2Fp5-mst-13.2.git

Permit tie ?foo,$object
tidy up dead #ifdef ORIGINAL_TIE)
Remove 'P' magic from hash, before adding new one in dbm_open like tie does.

p4raw-id: //depot/ansiperl@427
---

diff --git a/pp_sys.c b/pp_sys.c
index 67cae15..4893913 100644
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -516,68 +516,48 @@ PP(pp_tie)
     SV **mark = stack_base + ++*markstack_ptr;	/* reuse in entersub */
     I32 markoff = mark - stack_base - 1;
     char *methname;
-#ifdef ORIGINAL_TIE
-    BINOP myop;
-    bool oldcatch = CATCH_GET;
-#endif
-
-    varsv = mark[0];
-    if (SvTYPE(varsv) == SVt_PVHV)
-	methname = "TIEHASH";
-    else if (SvTYPE(varsv) == SVt_PVAV)
-	methname = "TIEARRAY";
-    else if (SvTYPE(varsv) == SVt_PVGV)
-	methname = "TIEHANDLE";
-    else
-	methname = "TIESCALAR";
-
-    stash = gv_stashsv(mark[1], FALSE);
-    if (!stash || !(gv = gv_fetchmethod(stash, methname)))
-	DIE("Can't locate object method \"%s\" via package \"%s\"",
-		methname, SvPV(mark[1],na));
-
-#ifdef ORIGINAL_TIE
-    Zero(&myop, 1, BINOP);
-    myop.op_last = (OP *) &myop;
-    myop.op_next = Nullop;
-    myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
-    CATCH_SET(TRUE);
+    int how = 'P';
 
-    ENTER;
-    SAVEOP();
-    op = (OP *) &myop;
-    if (PERLDB_SUB && curstash != debstash)
-	op->op_private |= OPpENTERSUB_DB;
-
-    XPUSHs((SV*)GvCV(gv));
-    PUTBACK;
+    varsv = mark[0];  
+    switch(SvTYPE(varsv)) {
+	case SVt_PVHV:
+	    methname = "TIEHASH";
+	    break;
+	case SVt_PVAV:
+	    methname = "TIEARRAY";
+	    break;
+	case SVt_PVGV:
+	    methname = "TIEHANDLE";
+	    how = 'q';
+	    break;
+	default:
+	    methname = "TIESCALAR";
+	    how = 'q';
+	    break;
+    }
 
-    if (op = pp_entersub(ARGS))
-        runops();
+    if (sv_isobject(mark[1])) {
+	ENTER;
+	perl_call_method(methname, G_SCALAR);
+    } 
+    else {
+	/* Not clear why we don't call perl_call_method here too.
+	 * perhaps to get different error message ?
+	 */
+	stash = gv_stashsv(mark[1], FALSE);
+	if (!stash || !(gv = gv_fetchmethod(stash, methname))) {
+	    DIE("Can't locate object method \"%s\" via package \"%s\"",
+		 methname, SvPV(mark[1],na));                   
+	}
+	ENTER;
+	perl_call_sv((SV*)GvCV(gv), G_SCALAR);
+    }
     SPAGAIN;
 
-    CATCH_SET(oldcatch);
-#else
-    ENTER;
-    perl_call_sv((SV*)GvCV(gv), G_SCALAR);
-    SPAGAIN;
-#endif	
     sv = TOPs;
     if (sv_isobject(sv)) {
-	if (SvTYPE(varsv) == SVt_PVHV || SvTYPE(varsv) == SVt_PVAV) {
-	    sv_unmagic(varsv, 'P');            
-#ifdef DEBUGGING
-	if (SvTYPE(varsv) == SVt_PVAV) {
-	    AV *av = (AV *) varsv; 
-	    av_undef(av);
-	}
-#endif
-	    sv_magic(varsv, sv, 'P', Nullch, 0);
-	}
-	else {
-	    sv_unmagic(varsv, 'q');
-	    sv_magic(varsv, sv, 'q', Nullch, 0);
-	}
+	sv_unmagic(varsv, how);            
+	sv_magic(varsv, sv, how, Nullch, 0);
     }
     LEAVE;
     SP = stack_base + markoff;
@@ -589,10 +569,8 @@ PP(pp_untie)
 {
     djSP;
     SV * sv ;
-
     sv = POPs;          
 
-
     if (dowarn) {
         MAGIC * mg ;
         if (SvMAGICAL(sv)) {
@@ -632,7 +610,6 @@ PP(pp_tied)
             RETURN ;
 	}
     }
-
     RETPUSHUNDEF;
 }
 
@@ -644,10 +621,6 @@ PP(pp_dbmopen)
     HV* stash;
     GV *gv;
     SV *sv;
-#ifdef ORIGINAL_TIE
-    BINOP myop;
-    bool oldcatch = CATCH_GET;
-#endif	
 
     hv = (HV*)POPs;
 
@@ -662,24 +635,9 @@ PP(pp_dbmopen)
 	    DIE("No dbm on this machine");
     }
 
-#ifdef ORIGINAL_TIE
-    Zero(&myop, 1, BINOP);
-    myop.op_last = (OP *) &myop;
-    myop.op_next = Nullop;
-    myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
-    CATCH_SET(TRUE);
-
-    ENTER;
-    SAVEOP();
-    op = (OP *) &myop;
-    if (PERLDB_SUB && curstash != debstash)
-	op->op_private |= OPpENTERSUB_DB;
-    PUTBACK;
-    pp_pushmark(ARGS);
-#else
     ENTER;
     PUSHMARK(sp);
-#endif	
+
     EXTEND(sp, 5);
     PUSHs(sv);
     PUSHs(left);
@@ -688,51 +646,26 @@ PP(pp_dbmopen)
     else
 	PUSHs(sv_2mortal(newSViv(O_RDWR)));
     PUSHs(right);
-#ifdef ORIGINAL_TIE
-    PUSHs((SV*)GvCV(gv));
-    PUTBACK;
-
-    if (op = pp_entersub(ARGS))
-        runops();
-#else
     PUTBACK;
     perl_call_sv((SV*)GvCV(gv), G_SCALAR);
-#endif	
     SPAGAIN;
 
     if (!sv_isobject(TOPs)) {
 	sp--;
-#ifdef ORIGINAL_TIE
-	op = (OP *) &myop;
-	PUTBACK;
-	pp_pushmark(ARGS);
-#else
 	PUSHMARK(sp);
-#endif	
-
 	PUSHs(sv);
 	PUSHs(left);
 	PUSHs(sv_2mortal(newSViv(O_RDONLY)));
 	PUSHs(right);
-#ifdef ORIGINAL_TIE
-	PUSHs((SV*)GvCV(gv));
-#endif	
 	PUTBACK;
-
-#ifdef ORIGINAL_TIE
-	if (op = pp_entersub(ARGS))
-	    runops();
-#else
 	perl_call_sv((SV*)GvCV(gv), G_SCALAR);
-#endif	
 	SPAGAIN;
     }
 
-#ifdef ORIGINAL_TIE
-    CATCH_SET(oldcatch);
-#endif	
-    if (sv_isobject(TOPs))
+    if (sv_isobject(TOPs)) {
+	sv_unmagic((SV *) hv, 'P');            
 	sv_magic((SV*)hv, TOPs, 'P', Nullch, 0);
+    }
     LEAVE;
     RETURN;
 }