Convert Errno.t to Test::More. Increase the test coverage

[p5sagit/p5-mst-13.2.git] / perl.c

diff --git a/perl.c b/perl.c
index 320793d..be381b9 100644 (file)
--- a/perl.c
+++ b/perl.c
@@ -137,6 +137,22 @@ static I32 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen);
 #endif
 #endif
 
+#define CALL_BODY_EVAL(myop) \
+    if (PL_op == (myop)) \
+       PL_op = Perl_pp_entereval(aTHX); \
+    if (PL_op) \
+       CALLRUNOPS(aTHX);
+
+#define CALL_BODY_SUB(myop) \
+    if (PL_op == (myop)) \
+       PL_op = Perl_pp_entersub(aTHX); \
+    if (PL_op) \
+       CALLRUNOPS(aTHX);
+
+#define CALL_LIST_BODY(cv) \
+    PUSHMARK(PL_stack_sp); \
+    call_sv((SV*)(cv), G_EVAL|G_DISCARD);
+
 static void
 S_init_tls_and_interp(PerlInterpreter *my_perl)
 {
@@ -229,7 +245,7 @@ void
 perl_construct(pTHXx)
 {
     dVAR;
-    PERL_UNUSED_CONTEXT;
+    PERL_UNUSED_ARG(my_perl);
 #ifdef MULTIPLICITY
     init_interp();
     PL_perl_destruct_level = 1;
@@ -529,7 +545,7 @@ perl_destruct(pTHXx)
     pid_t child;
 #endif
 
-    PERL_UNUSED_CONTEXT;
+    PERL_UNUSED_ARG(my_perl);
 
     /* wait for all pseudo-forked children to finish */
     PERL_WAIT_FOR_CHILDREN;
@@ -1037,11 +1053,8 @@ perl_destruct(pTHXx)
     if (!specialWARN(PL_compiling.cop_warnings))
        PerlMemShared_free(PL_compiling.cop_warnings);
     PL_compiling.cop_warnings = NULL;
-    if (!specialCopIO(PL_compiling.cop_io))
-       SvREFCNT_dec(PL_compiling.cop_io);
-    PL_compiling.cop_io = NULL;
-    Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints);
-    PL_compiling.cop_hints = NULL;
+    Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash);
+    PL_compiling.cop_hints_hash = NULL;
     CopFILE_free(&PL_compiling);
     CopSTASH_free(&PL_compiling);
 
@@ -1441,7 +1454,7 @@ perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env)
     int ret;
     dJMPENV;
 
-    PERL_UNUSED_VAR(my_perl);
+    PERL_UNUSED_ARG(my_perl);
 
 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
 #ifdef IAMSUID
@@ -2281,7 +2294,7 @@ perl_run(pTHXx)
     int ret = 0;
     dJMPENV;
 
-    PERL_UNUSED_CONTEXT;
+    PERL_UNUSED_ARG(my_perl);
 
     oldscope = PL_scopestack_ix;
 #ifdef VMS
@@ -2609,7 +2622,7 @@ Perl_call_sv(pTHX_ SV *sv, I32 flags)
 
     if (!(flags & G_EVAL)) {
        CATCH_SET(TRUE);
-       call_body((OP*)&myop, FALSE);
+       CALL_BODY_SUB((OP*)&myop);
        retval = PL_stack_sp - (PL_stack_base + oldmark);
        CATCH_SET(oldcatch);
     }
@@ -2624,7 +2637,7 @@ Perl_call_sv(pTHX_ SV *sv, I32 flags)
        switch (ret) {
        case 0:
  redo_body:
-           call_body((OP*)&myop, FALSE);
+           CALL_BODY_SUB((OP*)&myop);
            retval = PL_stack_sp - (PL_stack_base + oldmark);
            if (!(flags & G_KEEPERR))
                sv_setpvn(ERRSV,"",0);
@@ -2672,20 +2685,6 @@ Perl_call_sv(pTHX_ SV *sv, I32 flags)
     return retval;
 }
 
-STATIC void
-S_call_body(pTHX_ const OP *myop, bool is_eval)
-{
-    dVAR;
-    if (PL_op == myop) {
-       if (is_eval)
-           PL_op = Perl_pp_entereval(aTHX);    /* this doesn't do a POPMARK */
-       else
-           PL_op = Perl_pp_entersub(aTHX);     /* this does */
-    }
-    if (PL_op)
-       CALLRUNOPS(aTHX);
-}
-
 /* Eval a string. The G_EVAL flag is always assumed. */
 
 /*
@@ -2739,7 +2738,7 @@ Perl_eval_sv(pTHX_ SV *sv, I32 flags)
     switch (ret) {
     case 0:
  redo_body:
-       call_body((OP*)&myop,TRUE);
+       CALL_BODY_EVAL((OP*)&myop);
        retval = PL_stack_sp - (PL_stack_base + oldmark);
        if (!(flags & G_KEEPERR))
            sv_setpvn(ERRSV,"",0);
@@ -3263,8 +3262,8 @@ Perl_moreswitches(pTHX_ char *s)
                          " DEVEL" STRINGIFY(PERL_PATCHNUM)
 #endif
                          " built for %s",
-                   vstringify(PL_patchlevel),
-                   ARCHNAME));
+                         (void*)vstringify(PL_patchlevel),
+                         ARCHNAME));
 #else /* DGUX */
 /* Adjust verbose output as in the perl that ships with the DG/UX OS from EMC */
        PerlIO_printf(PerlIO_stdout(),
@@ -3283,7 +3282,7 @@ Perl_moreswitches(pTHX_ char *s)
            PerlIO_printf(PerlIO_stdout(),
                          "\n(with %d registered patch%s, "
                          "see perl -V for more detail)",
-                         (int)LOCAL_PATCH_COUNT,
+                         LOCAL_PATCH_COUNT,
                          (LOCAL_PATCH_COUNT!=1) ? "es" : "");
 #endif
 
@@ -3669,8 +3668,8 @@ S_open_script(pTHX_ const char *scriptname, bool dosearch, SV *sv,
 
         Perl_sv_setpvf(aTHX_ cmd, "\
 %s -ne%s%s%s %s | %"SVf" %s %"SVf" %s",
-                       perl, quote, code, quote, scriptname, cpp,
-                       cpp_discard_flag, sv, CPPMINUS);
+                       perl, quote, code, quote, scriptname, (void*)cpp,
+                       cpp_discard_flag, (void*)sv, CPPMINUS);
 
        PL_doextract = FALSE;
 
@@ -5049,19 +5048,21 @@ S_incpush(pTHX_ const char *dir, bool addsubdirs, bool addoldvers, bool usesep,
 #endif
                /* .../version/archname if -d .../version/archname */
                Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PATH PERL_ARCH_FMT,
-                               libdir,
+                              (void*)libdir,
                               (int)PERL_REVISION, (int)PERL_VERSION,
                               (int)PERL_SUBVERSION, ARCHNAME);
                subdir = S_incpush_if_exists(aTHX_ subdir);
 
                /* .../version if -d .../version */
-               Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PATH, libdir,
+               Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PATH,
+                              (void*)libdir,
                               (int)PERL_REVISION, (int)PERL_VERSION,
                               (int)PERL_SUBVERSION);
                subdir = S_incpush_if_exists(aTHX_ subdir);
 
                /* .../archname if -d .../archname */
-               Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, libdir, ARCHNAME);
+               Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT,
+                              (void*)libdir, ARCHNAME);
                subdir = S_incpush_if_exists(aTHX_ subdir);
 
            }
@@ -5070,7 +5071,7 @@ S_incpush(pTHX_ const char *dir, bool addsubdirs, bool addoldvers, bool usesep,
            if (addoldvers) {
                for (incver = incverlist; *incver; incver++) {
                    /* .../xxx if -d .../xxx */
-                   Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, libdir, *incver);
+                   Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, (void *)libdir, *incver);
                    subdir = S_incpush_if_exists(aTHX_ subdir);
                }
            }
@@ -5124,7 +5125,7 @@ Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
            if (PL_madskills)
                PL_madskills |= 16384;
 #endif
-           call_list_body(cv);
+           CALL_LIST_BODY(cv);
 #ifdef PERL_MAD
            if (PL_madskills)
                PL_madskills &= ~16384;
@@ -5147,7 +5148,7 @@ Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
                while (PL_scopestack_ix > oldscope)
                    LEAVE;
                JMPENV_POP;
-               Perl_croak(aTHX_ "%"SVf"", atsv);
+               Perl_croak(aTHX_ "%"SVf"", (void*)atsv);
            }
            break;
        case 1:
@@ -5189,15 +5190,6 @@ Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
     }
 }
 
-STATIC void *
-S_call_list_body(pTHX_ CV *cv)
-{
-    dVAR;
-    PUSHMARK(PL_stack_sp);
-    call_sv((SV*)cv, G_EVAL|G_DISCARD);
-    return NULL;
-}
-
 void
 Perl_my_exit(pTHX_ U32 status)
 {