This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
allow spaces in -I switch argument
[perl5.git] / perl.c
diff --git a/perl.c b/perl.c
index 2ed116c..7c49f14 100644 (file)
--- a/perl.c
+++ b/perl.c
@@ -47,40 +47,42 @@ static I32 read_e_script(pTHXo_ int idx, SV *buf_sv, int maxlen);
 #endif
 
 #ifdef PERL_OBJECT
-CPerlObj*
-perl_alloc(struct IPerlMem* ipM, struct IPerlEnv* ipE,
-                struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
-                struct IPerlDir* ipD, struct IPerlSock* ipS,
-                struct IPerlProc* ipP)
-{
-    CPerlObj* pPerl = new(ipM) CPerlObj(ipM, ipE, ipStd, ipLIO, ipD, ipS, ipP);
-    if (pPerl != NULL)
-       pPerl->Init();
-
-    return pPerl;
-}
-#else
+#define perl_construct Perl_construct
+#define perl_parse     Perl_parse
+#define perl_run       Perl_run
+#define perl_destruct  Perl_destruct
+#define perl_free      Perl_free
+#endif
 
 #ifdef PERL_IMPLICIT_SYS
 PerlInterpreter *
-perl_alloc_using(struct IPerlMem* ipM, struct IPerlEnv* ipE,
+perl_alloc_using(struct IPerlMem* ipM, struct IPerlMem* ipMS,
+                struct IPerlMem* ipMP, struct IPerlEnv* ipE,
                 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
                 struct IPerlDir* ipD, struct IPerlSock* ipS,
                 struct IPerlProc* ipP)
 {
     PerlInterpreter *my_perl;
-
+#ifdef PERL_OBJECT
+    my_perl = (PerlInterpreter*)new(ipM) CPerlObj(ipM, ipMS, ipMP, ipE, ipStd,
+                                                 ipLIO, ipD, ipS, ipP);
+    PERL_SET_INTERP(my_perl);
+#else
     /* New() needs interpreter, so call malloc() instead */
     my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
     PERL_SET_INTERP(my_perl);
     Zero(my_perl, 1, PerlInterpreter);
     PL_Mem = ipM;
+    PL_MemShared = ipMS;
+    PL_MemParse = ipMP;
     PL_Env = ipE;
     PL_StdIO = ipStd;
     PL_LIO = ipLIO;
     PL_Dir = ipD;
     PL_Sock = ipS;
     PL_Proc = ipP;
+#endif
+
     return my_perl;
 }
 #else
@@ -92,10 +94,10 @@ perl_alloc(void)
     /* New() needs interpreter, so call malloc() instead */
     my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
     PERL_SET_INTERP(my_perl);
+    Zero(my_perl, 1, PerlInterpreter);
     return my_perl;
 }
 #endif /* PERL_IMPLICIT_SYS */
-#endif /* PERL_OBJECT */
 
 void
 perl_construct(pTHXx)
@@ -117,9 +119,8 @@ perl_construct(pTHXx)
 
    /* Init the real globals (and main thread)? */
     if (!PL_linestr) {
-#ifdef USE_THREADS
-
        INIT_THREADS;
+#ifdef USE_THREADS
 #ifdef ALLOC_THREAD_KEY
         ALLOC_THREAD_KEY;
 #else
@@ -235,6 +236,9 @@ perl_destruct(pTHXx)
     dTHX;
 #endif /* USE_THREADS */
 
+    /* wait for all pseudo-forked children to finish */
+    PERL_WAIT_FOR_CHILDREN;
+
 #ifdef USE_THREADS
 #ifndef FAKE_THREADS
     /* Pass 1 on any remaining threads: detach joinables, join zombies */
@@ -433,9 +437,11 @@ perl_destruct(pTHXx)
     /* startup and shutdown function lists */
     SvREFCNT_dec(PL_beginav);
     SvREFCNT_dec(PL_endav);
+    SvREFCNT_dec(PL_stopav);
     SvREFCNT_dec(PL_initav);
     PL_beginav = Nullav;
     PL_endav = Nullav;
+    PL_stopav = Nullav;
     PL_initav = Nullav;
 
     /* shortcuts just get cleared */
@@ -449,15 +455,78 @@ perl_destruct(pTHXx)
     PL_stderrgv = Nullgv;
     PL_last_in_gv = Nullgv;
     PL_replgv = Nullgv;
+    PL_debstash = Nullhv;
 
     /* reset so print() ends up where we expect */
     setdefout(Nullgv);
 
+    SvREFCNT_dec(PL_argvout_stack);
+    PL_argvout_stack = Nullav;
+
+    SvREFCNT_dec(PL_fdpid);
+    PL_fdpid = Nullav;
+    SvREFCNT_dec(PL_modglobal);
+    PL_modglobal = Nullhv;
+    SvREFCNT_dec(PL_preambleav);
+    PL_preambleav = Nullav;
+    SvREFCNT_dec(PL_subname);
+    PL_subname = Nullsv;
+    SvREFCNT_dec(PL_linestr);
+    PL_linestr = Nullsv;
+    SvREFCNT_dec(PL_pidstatus);
+    PL_pidstatus = Nullhv;
+    SvREFCNT_dec(PL_toptarget);
+    PL_toptarget = Nullsv;
+    SvREFCNT_dec(PL_bodytarget);
+    PL_bodytarget = Nullsv;
+    PL_formtarget = Nullsv;
+
+    /* clear utf8 character classes */
+    SvREFCNT_dec(PL_utf8_alnum);
+    SvREFCNT_dec(PL_utf8_alnumc);
+    SvREFCNT_dec(PL_utf8_ascii);
+    SvREFCNT_dec(PL_utf8_alpha);
+    SvREFCNT_dec(PL_utf8_space);
+    SvREFCNT_dec(PL_utf8_cntrl);
+    SvREFCNT_dec(PL_utf8_graph);
+    SvREFCNT_dec(PL_utf8_digit);
+    SvREFCNT_dec(PL_utf8_upper);
+    SvREFCNT_dec(PL_utf8_lower);
+    SvREFCNT_dec(PL_utf8_print);
+    SvREFCNT_dec(PL_utf8_punct);
+    SvREFCNT_dec(PL_utf8_xdigit);
+    SvREFCNT_dec(PL_utf8_mark);
+    SvREFCNT_dec(PL_utf8_toupper);
+    SvREFCNT_dec(PL_utf8_tolower);
+    PL_utf8_alnum      = Nullsv;
+    PL_utf8_alnumc     = Nullsv;
+    PL_utf8_ascii      = Nullsv;
+    PL_utf8_alpha      = Nullsv;
+    PL_utf8_space      = Nullsv;
+    PL_utf8_cntrl      = Nullsv;
+    PL_utf8_graph      = Nullsv;
+    PL_utf8_digit      = Nullsv;
+    PL_utf8_upper      = Nullsv;
+    PL_utf8_lower      = Nullsv;
+    PL_utf8_print      = Nullsv;
+    PL_utf8_punct      = Nullsv;
+    PL_utf8_xdigit     = Nullsv;
+    PL_utf8_mark       = Nullsv;
+    PL_utf8_toupper    = Nullsv;
+    PL_utf8_totitle    = Nullsv;
+    PL_utf8_tolower    = Nullsv;
+
+    if (!specialWARN(PL_compiling.cop_warnings))
+       SvREFCNT_dec(PL_compiling.cop_warnings);
+    PL_compiling.cop_warnings = Nullsv;
+
     /* Prepare to destruct main symbol table.  */
 
     hv = PL_defstash;
     PL_defstash = 0;
     SvREFCNT_dec(hv);
+    SvREFCNT_dec(PL_curstname);
+    PL_curstname = Nullsv;
 
     /* clear queued errors */
     SvREFCNT_dec(PL_errors);
@@ -528,8 +597,6 @@ perl_destruct(pTHXx)
     sv_free_arenas();
 
     /* No SVs have survived, need to clean out */
-    PL_linestr = NULL;
-    PL_pidstatus = Nullhv;
     Safefree(PL_origfilename);
     Safefree(PL_archpat_auto);
     Safefree(PL_reg_start_tmp);
@@ -660,6 +727,8 @@ setuid perl scripts securely.\n");
                env, xsinit);
     switch (ret) {
     case 0:
+       if (PL_stopav)
+           call_list(oldscope, PL_stopav);
        return 0;
     case 1:
        STATUS_ALL_FAILURE;
@@ -670,8 +739,8 @@ setuid perl scripts securely.\n");
            LEAVE;
        FREETMPS;
        PL_curstash = PL_defstash;
-       if (PL_endav && !PL_minus_c)
-           call_list(oldscope, PL_endav);
+       if (PL_stopav)
+           call_list(oldscope, PL_stopav);
        return STATUS_NATIVE_EXPORT;
     case 3:
        PerlIO_printf(Perl_error_log, "panic: top_env\n");
@@ -771,18 +840,18 @@ S_parse_body(pTHX_ va_list args)
            if (!*++s && (s=argv[1]) != Nullch) {
                argc--,argv++;
            }
-           while (s && isSPACE(*s))
-               ++s;
            if (s && *s) {
-               char *e, *p;
-               for (e = s; *e && !isSPACE(*e); e++) ;
-               p = savepvn(s, e-s);
+               char *p;
+               STRLEN len = strlen(s);
+               p = savepvn(s, len);
                incpush(p, TRUE);
-               sv_catpv(sv,"-I");
-               sv_catpv(sv,p);
-               sv_catpv(sv," ");
+               sv_catpvn(sv, "-I", 2);
+               sv_catpvn(sv, p, len);
+               sv_catpvn(sv, " ", 1);
                Safefree(p);
-           }   /* XXX else croak? */
+           }
+           else
+               Perl_croak(aTHX_ "No argument specified for -I");
            break;
        case 'P':
            forbid_setid("-P");
@@ -893,7 +962,8 @@ print \"  \\@INC:\\n    @INC\\n\";");
 #ifndef SECURE_INTERNAL_GETENV
         !PL_tainting &&
 #endif
-                        (s = PerlEnv_getenv("PERL5OPT"))) {
+       (s = PerlEnv_getenv("PERL5OPT")))
+    {
        while (isSPACE(*s))
            s++;
        if (*s == '-' && *(s+1) == 'T')
@@ -1018,7 +1088,7 @@ print \"  \\@INC:\\n    @INC\\n\";");
                       PL_origfilename);
        }
     }
-    PL_curcop->cop_line = 0;
+    CopLINE_set(PL_curcop, 0);
     PL_curstash = PL_defstash;
     PL_preprocess = FALSE;
     if (PL_e_script) {
@@ -1033,8 +1103,11 @@ print \"  \\@INC:\\n    @INC\\n\";");
     if (PL_do_undump)
        my_unexec();
 
-    if (isWARN_ONCE)
+    if (isWARN_ONCE) {
+       SAVECOPFILE(PL_curcop);
+       SAVECOPLINE(PL_curcop);
        gv_check(PL_defstash);
+    }
 
     LEAVE;
     FREETMPS;
@@ -1107,8 +1180,8 @@ S_run_body(pTHX_ va_list args)
     if (!PL_restartop) {
        DEBUG_x(dump_all());
        DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
-       DEBUG_S(PerlIO_printf(Perl_debug_log, "main thread is 0x%lx\n",
-                             (unsigned long) thr));
+       DEBUG_S(PerlIO_printf(Perl_debug_log, "main thread is 0x%"UVxf"\n",
+                             PTR2UV(thr)));
 
        if (PL_minus_c) {
            PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename);
@@ -1334,7 +1407,7 @@ Perl_call_sv(pTHX_ SV *sv, I32 flags)
            /* my_exit() was called */
            PL_curstash = PL_defstash;
            FREETMPS;
-           if (PL_statusvalue)
+           if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
                Perl_croak(aTHX_ "Callback called exit");
            my_exit_jump();
            /* NOTREACHED */
@@ -1458,7 +1531,7 @@ Perl_eval_sv(pTHX_ SV *sv, I32 flags)
        /* my_exit() was called */
        PL_curstash = PL_defstash;
        FREETMPS;
-       if (PL_statusvalue)
+       if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
            Perl_croak(aTHX_ "Callback called exit");
        my_exit_jump();
        /* NOTREACHED */
@@ -1589,7 +1662,7 @@ Perl_moreswitches(pTHX_ char *s)
     case '0':
     {
        dTHR;
-       rschar = scan_oct(s, 4, &numlen);
+       rschar = (U32)scan_oct(s, 4, &numlen);
        SvREFCNT_dec(PL_nrs);
        if (rschar & ~((U8)~0))
            PL_nrs = &PL_sv_undef;
@@ -1674,14 +1747,23 @@ Perl_moreswitches(pTHX_ char *s)
            ++s;
        if (*s) {
            char *e, *p;
-           for (e = s; *e && !isSPACE(*e); e++) ;
-           p = savepvn(s, e-s);
-           incpush(p, TRUE);
-           Safefree(p);
-           s = e;
+           p = s;
+           /* ignore trailing spaces (possibly followed by other switches) */
+           do {
+               for (e = p; *e && !isSPACE(*e); e++) ;
+               p = e;
+               while (isSPACE(*p))
+                   p++;
+           } while (*p && *p != '-');
+           e = savepvn(s, e-s);
+           incpush(e, TRUE);
+           Safefree(e);
+           s = p;
+           if (*s == '-')
+               s++;
        }
        else
-           Perl_croak(aTHX_ "No space allowed after -I");
+           Perl_croak(aTHX_ "No argument specified for -I");
        return s;
     case 'l':
        PL_minus_l = TRUE;
@@ -1691,7 +1773,7 @@ Perl_moreswitches(pTHX_ char *s)
        if (isDIGIT(*s)) {
            PL_ors = savepv("\n");
            PL_orslen = 1;
-           *PL_ors = scan_oct(s, 3 + (*s == '0'), &numlen);
+           *PL_ors = (char)scan_oct(s, 3 + (*s == '0'), &numlen);
            s += numlen;
        }
        else {
@@ -1734,7 +1816,7 @@ Perl_moreswitches(pTHX_ char *s)
                sv_catpv(sv,    "})");
            }
            s += strlen(s);
-           if (PL_preambleav == NULL)
+           if (!PL_preambleav)
                PL_preambleav = newAV();
            av_push(PL_preambleav, sv);
        }
@@ -1778,7 +1860,7 @@ Perl_moreswitches(pTHX_ char *s)
 #if defined(LOCAL_PATCH_COUNT)
        if (LOCAL_PATCH_COUNT > 0)
            printf("\n(with %d registered patch%s, see perl -V for more detail)",
-               LOCAL_PATCH_COUNT, (LOCAL_PATCH_COUNT!=1) ? "es" : "");
+               (int)LOCAL_PATCH_COUNT, (LOCAL_PATCH_COUNT!=1) ? "es" : "");
 #endif
 
        printf("\n\nCopyright 1987-1999, Larry Wall\n");
@@ -2017,7 +2099,7 @@ S_init_main_stash(pTHX)
     sv_grow(ERRSV, 240);       /* Preallocate - for immediate signals. */
     sv_setpvn(ERRSV, "", 0);
     PL_curstash = PL_defstash;
-    PL_compiling.cop_stash = PL_defstash;
+    CopSTASH_set(&PL_compiling, PL_defstash);
     PL_debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
     PL_globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
     /* We must init $/ before switches are processed. */
@@ -2052,7 +2134,7 @@ S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript)
        }
     }
 
-    PL_curcop->cop_filegv = gv_fetchfile(PL_origfilename);
+    CopFILE_set(PL_curcop, PL_origfilename);
     if (strEQ(PL_origfilename,"-"))
        scriptname = "";
     if (*fdscript >= 0) {
@@ -2071,7 +2153,7 @@ S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript)
            Perl_sv_catpvf(aTHX_ cpp, "%s/", BIN_EXP);
        sv_catpv(cpp, cpp_cfg);
 
-       sv_catpv(sv,"-I");
+       sv_catpvn(sv, "-I", 2);
        sv_catpv(sv,PRIVLIB_EXP);
 
 #ifdef MSDOS
@@ -2166,7 +2248,7 @@ sed %s -e \"/^[^#]/b\" \
 #ifdef DOSUID
 #ifndef IAMSUID                /* in case script is not readable before setuid */
        if (PL_euid &&
-           PerlLIO_stat(SvPVX(GvSV(PL_curcop->cop_filegv)),&PL_statbuf) >= 0 &&
+           PerlLIO_stat(CopFILE(PL_curcop),&PL_statbuf) >= 0 &&
            PL_statbuf.st_mode & (S_ISUID|S_ISGID))
        {
            /* try again */
@@ -2176,7 +2258,7 @@ sed %s -e \"/^[^#]/b\" \
 #endif
 #endif
        Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
-         SvPVX(GvSV(PL_curcop->cop_filegv)), Strerror(errno));
+                  CopFILE(PL_curcop), Strerror(errno));
     }
 }
 
@@ -2191,13 +2273,15 @@ sed %s -e \"/^[^#]/b\" \
 STATIC int
 S_fd_on_nosuid_fs(pTHX_ int fd)
 {
-    int on_nosuid  = 0;
-    int check_okay = 0;
+    int check_okay = 0; /* able to do all the required sys/libcalls */
+    int on_nosuid  = 0; /* the fd is on a nosuid fs */
 /*
- * Preferred order: fstatvfs(), fstatfs(), getmntent().
+ * Preferred order: fstatvfs(), fstatfs(), ustat()+getmnt(), getmntent().
  * fstatvfs() is UNIX98.
- * fstatfs() is BSD.
- * getmntent() is O(number-of-mounted-filesystems) and can hang.
+ * fstatfs() is 4.3 BSD.
+ * ustat()+getmnt() is pre-4.3 BSD.
+ * getmntent() is O(number-of-mounted-filesystems) and can hang on
+ * an irrelevant filesystem while trying to reach the right one.
  */
 
 #   ifdef HAS_FSTATVFS
@@ -2205,24 +2289,45 @@ S_fd_on_nosuid_fs(pTHX_ int fd)
     check_okay = fstatvfs(fd, &stfs) == 0;
     on_nosuid  = check_okay && (stfs.f_flag  & ST_NOSUID);
 #   else
-#       if defined(HAS_FSTATFS) && defined(HAS_STRUCT_STATFS_FLAGS)
+#       ifdef PERL_MOUNT_NOSUID
+#           if defined(HAS_FSTATFS) && \
+              defined(HAS_STRUCT_STATFS) && \
+              defined(HAS_STRUCT_STATFS_F_FLAGS)
     struct statfs  stfs;
     check_okay = fstatfs(fd, &stfs)  == 0;
-#           undef PERL_MOUNT_NOSUID
-#           if !defined(PERL_MOUNT_NOSUID) && defined(MNT_NOSUID)
-#              define PERL_MOUNT_NOSUID MNT_NOSUID
-#           endif
-#           if !defined(PERL_MOUNT_NOSUID) && defined(MS_NOSUID)
-#              define PERL_MOUNT_NOSUID MS_NOSUID
-#           endif
-#           if !defined(PERL_MOUNT_NOSUID) && defined(M_NOSUID)
-#              define PERL_MOUNT_NOSUID M_NOSUID
-#           endif
-#           ifdef PERL_MOUNT_NOSUID
     on_nosuid  = check_okay && (stfs.f_flags & PERL_MOUNT_NOSUID);
-#           endif
+#           else
+#               if defined(HAS_FSTAT) && \
+                  defined(HAS_USTAT) && \
+                  defined(HAS_GETMNT) && \
+                  defined(HAS_STRUCT_FS_DATA) && \
+                  defined(NOSTAT_ONE)
+    struct stat fdst;
+    if (fstat(fd, &fdst) == 0) {
+       struct ustat us;
+       if (ustat(fdst.st_dev, &us) == 0) {
+           struct fs_data fsd;
+           /* NOSTAT_ONE here because we're not examining fields which
+            * vary between that case and STAT_ONE. */
+            if (getmnt((int*)0, &fsd, (int)0, NOSTAT_ONE, us.f_fname) == 0) {
+               size_t cmplen = sizeof(us.f_fname);
+               if (sizeof(fsd.fd_req.path) < cmplen)
+                   cmplen = sizeof(fsd.fd_req.path);
+               if (strnEQ(fsd.fd_req.path, us.f_fname, cmplen) &&
+                   fdst.st_dev == fsd.fd_req.dev) {
+                       check_okay = 1;
+                       on_nosuid = fsd.fd_req.flags & PERL_MOUNT_NOSUID;
+                   }
+               }
+           }
+       }
+    }
+#               endif /* fstat+ustat+getmnt */
+#           endif /* fstatfs */
 #       else
-#           if defined(HAS_GETMNTENT) && defined(HAS_HASMNTOPT) && defined(MNTOPT_NOSUID)
+#           if defined(HAS_GETMNTENT) && \
+              defined(HAS_HASMNTOPT) && \
+              defined(MNTOPT_NOSUID)
     FILE               *mtab = fopen("/etc/mtab", "r");
     struct mntent      *entry;
     struct stat                stb, fsb;
@@ -2242,11 +2347,12 @@ S_fd_on_nosuid_fs(pTHX_ int fd)
     }
     if (mtab)
        fclose(mtab);
-#           endif /* mntent */
-#       endif /* statfs */
+#           endif /* getmntent+hasmntopt */
+#       endif /* PERL_MOUNT_NOSUID: fstatfs or fstat+ustat+statfs */
 #   endif /* statvfs */
+
     if (!check_okay) 
-       Perl_croak(aTHX_ "Can't check filesystem of script \"%s\"", PL_origfilename);
+       Perl_croak(aTHX_ "Can't check filesystem of script \"%s\" for nosuid", PL_origfilename);
     return on_nosuid;
 }
 #endif /* IAMSUID */
@@ -2296,7 +2402,7 @@ S_validate_suid(pTHX_ char *validarg, char *scriptname, int fdscript)
         * But I don't think it's too important.  The manual lies when
         * it says access() is useful in setuid programs.
         */
-       if (PerlLIO_access(SvPVX(GvSV(PL_curcop->cop_filegv)),1)) /*double check*/
+       if (PerlLIO_access(CopFILE(PL_curcop),1)) /*double check*/
            Perl_croak(aTHX_ "Permission denied");
 #else
        /* If we can swap euid and uid, then we can determine access rights
@@ -2317,7 +2423,7 @@ S_validate_suid(pTHX_ char *validarg, char *scriptname, int fdscript)
 #endif
                || PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid)
                Perl_croak(aTHX_ "Can't swap uid and euid");    /* really paranoid */
-           if (PerlLIO_stat(SvPVX(GvSV(PL_curcop->cop_filegv)),&tmpstatbuf) < 0)
+           if (PerlLIO_stat(CopFILE(PL_curcop),&tmpstatbuf) < 0)
                Perl_croak(aTHX_ "Permission denied");  /* testing full pathname here */
 #if defined(IAMSUID) && !defined(NO_NOSUID_CHECK)
            if (fd_on_nosuid_fs(PerlIO_fileno(PL_rsfp)))
@@ -2328,12 +2434,12 @@ S_validate_suid(pTHX_ char *validarg, char *scriptname, int fdscript)
                (void)PerlIO_close(PL_rsfp);
                if (PL_rsfp = PerlProc_popen("/bin/mail root","w")) {   /* heh, heh */
                    PerlIO_printf(PL_rsfp,
-"User %ld tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
-(Filename of set-id script was %s, uid %ld gid %ld.)\n\nSincerely,\nperl\n",
-                       (long)PL_uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
+"User %"Uid_t_f" tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
+(Filename of set-id script was %s, uid %"Uid_t_f" gid %"Gid_t_f".)\n\nSincerely,\nperl\n",
+                       PL_uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
                        (long)PL_statbuf.st_dev, (long)PL_statbuf.st_ino,
-                       SvPVX(GvSV(PL_curcop->cop_filegv)),
-                       (long)PL_statbuf.st_uid, (long)PL_statbuf.st_gid);
+                       CopFILE(PL_curcop),
+                       PL_statbuf.st_uid, PL_statbuf.st_gid);
                    (void)PerlProc_pclose(PL_rsfp);
                }
                Perl_croak(aTHX_ "Permission denied\n");
@@ -2359,7 +2465,7 @@ S_validate_suid(pTHX_ char *validarg, char *scriptname, int fdscript)
        if (PL_statbuf.st_mode & S_IWOTH)
            Perl_croak(aTHX_ "Setuid/gid script is writable by world");
        PL_doswitches = FALSE;          /* -s is insecure in suid */
-       PL_curcop->cop_line++;
+       CopLINE_inc(PL_curcop);
        if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch ||
          strnNE(SvPV(PL_linestr,n_a),"#!",2) ) /* required even on Sys V */
            Perl_croak(aTHX_ "No #! line");
@@ -2598,7 +2704,7 @@ Perl_init_stacks(pTHX)
     PL_markstack_ptr = PL_markstack;
     PL_markstack_max = PL_markstack + REASONABLE(32);
 
-    SET_MARKBASE;
+    SET_MARK_OFFSET;
 
     New(54,PL_scopestack,REASONABLE(32),I32);
     PL_scopestack_ix = 0;
@@ -2781,7 +2887,7 @@ S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register
     }
     TAINT_NOT;
     if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
-       sv_setiv(GvSV(tmpgv), (IV)getpid());
+       sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
 }
 
 STATIC void
@@ -3030,8 +3136,8 @@ void
 Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
 {
     dTHR;
-    SV *atsv = ERRSV;
-    line_t oldline = PL_curcop->cop_line;
+    SV *atsv;
+    line_t oldline = CopLINE(PL_curcop);
     CV *cv;
     STRLEN len;
     int ret;
@@ -3043,17 +3149,23 @@ Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
        CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_call_list_body), cv);
        switch (ret) {
        case 0:
+           atsv = ERRSV;
            (void)SvPV(atsv, len);
            if (len) {
+               STRLEN n_a;
                PL_curcop = &PL_compiling;
-               PL_curcop->cop_line = oldline;
+               CopLINE_set(PL_curcop, oldline);
                if (paramList == PL_beginav)
                    sv_catpv(atsv, "BEGIN failed--compilation aborted");
                else
-                   sv_catpv(atsv, "END failed--cleanup aborted");
+                   Perl_sv_catpvf(aTHX_ atsv,
+                                  "%s failed--call queue aborted",
+                                  paramList == PL_stopav ? "STOP"
+                                  : paramList == PL_initav ? "INIT"
+                                  : "END");
                while (PL_scopestack_ix > oldscope)
                    LEAVE;
-               Perl_croak(aTHX_ "%s", SvPVX(atsv));
+               Perl_croak(aTHX_ "%s", SvPVx(atsv, n_a));
            }
            break;
        case 1:
@@ -3065,22 +3177,23 @@ Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
                LEAVE;
            FREETMPS;
            PL_curstash = PL_defstash;
-           if (PL_endav && !PL_minus_c)
-               call_list(oldscope, PL_endav);
            PL_curcop = &PL_compiling;
-           PL_curcop->cop_line = oldline;
-           if (PL_statusvalue) {
+           CopLINE_set(PL_curcop, oldline);
+           if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED)) {
                if (paramList == PL_beginav)
                    Perl_croak(aTHX_ "BEGIN failed--compilation aborted");
                else
-                   Perl_croak(aTHX_ "END failed--cleanup aborted");
+                   Perl_croak(aTHX_ "%s failed--call queue aborted",
+                              paramList == PL_stopav ? "STOP"
+                              : paramList == PL_initav ? "INIT"
+                              : "END");
            }
            my_exit_jump();
            /* NOTREACHED */
        case 3:
            if (PL_restartop) {
                PL_curcop = &PL_compiling;
-               PL_curcop->cop_line = oldline;
+               CopLINE_set(PL_curcop, oldline);
                JMPENV_JUMP(3);
            }
            PerlIO_printf(Perl_error_log, "panic: restartop\n");
@@ -3176,7 +3289,6 @@ S_my_exit_jump(pTHX)
 }
 
 #ifdef PERL_OBJECT
-#define NO_XSLOCKS
 #include "XSUB.h"
 #endif
 
@@ -3195,5 +3307,3 @@ read_e_script(pTHXo_ int idx, SV *buf_sv, int maxlen)
     sv_chop(PL_e_script, nl);
     return 1;
 }
-
-