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 (file)
--- 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;
 }