X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/17fbfdf6c6f5ee46c01833862a16cddc094c4bd5..9c0a4d5d8cc72d1c0301ac17cb2d9af4383cebac:/perl.c diff --git a/perl.c b/perl.c index 838f911..4b005b6 100644 --- a/perl.c +++ b/perl.c @@ -96,6 +96,15 @@ char *nw_get_sitelib(const char *pl); # ifdef I_SYS_WAIT # include # endif +# ifdef I_SYSUIO +# include +# endif + +union control_un { + struct cmsghdr cm; + char control[CMSG_SPACE(sizeof(int))]; +}; + #endif #ifdef __BEOS__ @@ -128,6 +137,15 @@ static I32 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen); #endif #endif +#ifndef NO_MATHOMS +/* This reference ensures that the mathoms are linked with perl */ +extern void Perl_mathoms(void); +void Perl_mathoms_ref(void); +void Perl_mathoms_ref(void) { + Perl_mathoms(); +} +#endif + static void S_init_tls_and_interp(PerlInterpreter *my_perl) { @@ -156,7 +174,7 @@ perl_alloc_using(struct IPerlMem* ipM, struct IPerlMem* ipMS, struct IPerlProc* ipP) { PerlInterpreter *my_perl; - /* New() needs interpreter, so call malloc() instead */ + /* Newx() needs interpreter, so call malloc() instead */ my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter)); S_init_tls_and_interp(my_perl); Zero(my_perl, 1, PerlInterpreter); @@ -189,7 +207,7 @@ perl_alloc(void) { PerlInterpreter *my_perl; - /* New() needs interpreter, so call malloc() instead */ + /* Newx() needs interpreter, so call malloc() instead */ my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter)); S_init_tls_and_interp(my_perl); @@ -209,6 +227,7 @@ void perl_construct(pTHXx) { dVAR; + PERL_UNUSED_ARG(my_perl); #ifdef MULTIPLICITY init_interp(); PL_perl_destruct_level = 1; @@ -248,8 +267,10 @@ perl_construct(pTHXx) SvREFCNT(&PL_sv_placeholder) = (~(U32)0)/2; } - PL_sighandlerp = Perl_sighandler; + PL_sighandlerp = (Sighandler_t) Perl_sighandler; +#ifdef PERL_USES_PL_PIDSTATUS PL_pidstatus = newHV(); +#endif } PL_rs = newSVpvn("\n", 1); @@ -322,12 +343,8 @@ perl_construct(pTHXx) PL_stashcache = newHV(); - PL_patchlevel = newSVpv( - Perl_form(aTHX_ "%d.%d.%d", - (int)PERL_REVISION, - (int)PERL_VERSION, - (int)PERL_SUBVERSION ), 0 - ); + PL_patchlevel = Perl_newSVpvf(aTHX_ "%d.%d.%d", (int)PERL_REVISION, + (int)PERL_VERSION, (int)PERL_SUBVERSION); #ifdef HAS_MMAP if (!PL_mmap_page_size) { @@ -341,7 +358,7 @@ perl_construct(pTHXx) # endif if ((long) PL_mmap_page_size < 0) { if (errno) { - SV *error = ERRSV; + SV * const error = ERRSV; (void) SvUPGRADE(error, SVt_PV); Perl_croak(aTHX_ "panic: sysconf: %s", SvPV_nolen_const(error)); } @@ -389,6 +406,104 @@ Perl_nothreadhook(pTHX) return 0; } +#ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP +void +Perl_dump_sv_child(pTHX_ SV *sv) +{ + ssize_t got; + const int sock = PL_dumper_fd; + const int debug_fd = PerlIO_fileno(Perl_debug_log); + union control_un control; + struct msghdr msg; + struct iovec vec[2]; + struct cmsghdr *cmptr; + int returned_errno; + unsigned char buffer[256]; + + if(sock == -1 || debug_fd == -1) + return; + + PerlIO_flush(Perl_debug_log); + + /* All these shenanigans are to pass a file descriptor over to our child for + it to dump out to. We can't let it hold open the file descriptor when it + forks, as the file descriptor it will dump to can turn out to be one end + of pipe that some other process will wait on for EOF. (So as it would + be open, the wait would be forever. */ + + msg.msg_control = control.control; + msg.msg_controllen = sizeof(control.control); + /* We're a connected socket so we don't need a destination */ + msg.msg_name = NULL; + msg.msg_namelen = 0; + msg.msg_iov = vec; + msg.msg_iovlen = 1; + + cmptr = CMSG_FIRSTHDR(&msg); + cmptr->cmsg_len = CMSG_LEN(sizeof(int)); + cmptr->cmsg_level = SOL_SOCKET; + cmptr->cmsg_type = SCM_RIGHTS; + *((int *)CMSG_DATA(cmptr)) = 1; + + vec[0].iov_base = (void*)&sv; + vec[0].iov_len = sizeof(sv); + got = sendmsg(sock, &msg, 0); + + if(got < 0) { + perror("Debug leaking scalars parent sendmsg failed"); + abort(); + } + if(got < sizeof(sv)) { + perror("Debug leaking scalars parent short sendmsg"); + abort(); + } + + /* Return protocol is + int: errno value + unsigned char: length of location string (0 for empty) + unsigned char*: string (not terminated) + */ + vec[0].iov_base = (void*)&returned_errno; + vec[0].iov_len = sizeof(returned_errno); + vec[1].iov_base = buffer; + vec[1].iov_len = 1; + + got = readv(sock, vec, 2); + + if(got < 0) { + perror("Debug leaking scalars parent read failed"); + PerlIO_flush(PerlIO_stderr()); + abort(); + } + if(got < sizeof(returned_errno) + 1) { + perror("Debug leaking scalars parent short read"); + PerlIO_flush(PerlIO_stderr()); + abort(); + } + + if (*buffer) { + got = read(sock, buffer + 1, *buffer); + if(got < 0) { + perror("Debug leaking scalars parent read 2 failed"); + PerlIO_flush(PerlIO_stderr()); + abort(); + } + + if(got < *buffer) { + perror("Debug leaking scalars parent short read 2"); + PerlIO_flush(PerlIO_stderr()); + abort(); + } + } + + if (returned_errno || *buffer) { + Perl_warn(aTHX_ "Debug leaking scalars child failed%s%.*s with errno" + " %d: %s", (*buffer ? " at " : ""), (int) *buffer, buffer + 1, + returned_errno, strerror(returned_errno)); + } +} +#endif + /* =for apidoc perl_destruct @@ -404,18 +519,19 @@ perl_destruct(pTHXx) volatile int destruct_level; /* 0=none, 1=full, 2=full with checks */ HV *hv; #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP - int sock; pid_t child; #endif + PERL_UNUSED_ARG(my_perl); + /* wait for all pseudo-forked children to finish */ PERL_WAIT_FOR_CHILDREN; destruct_level = PL_perl_destruct_level; #ifdef DEBUGGING { - const char *s; - if ((s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL"))) { + const char * const s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL"); + if (s) { const int i = atoi(s); if (destruct_level < i) destruct_level = i; @@ -441,7 +557,7 @@ perl_destruct(pTHXx) if (CALL_FPTR(PL_threadhook)(aTHX)) { /* Threads hook has vetoed further cleanup */ - return STATUS_NATIVE_EXPORT; + return STATUS_EXIT; } #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP @@ -465,41 +581,135 @@ perl_destruct(pTHXx) } if (!child) { /* We are the child */ + const int sock = fd[1]; + const int debug_fd = PerlIO_fileno(Perl_debug_log); + int f; + const char *where; + /* Our success message is an integer 0, and a char 0 */ + static const char success[sizeof(int) + 1]; + close(fd[0]); - sock = fd[1]; + + /* We need to close all other file descriptors otherwise we end up + with interesting hangs, where the parent closes its end of a + pipe, and sits waiting for (another) child to terminate. Only + that child never terminates, because it never gets EOF, because + we also have the far end of the pipe open. We even need to + close the debugging fd, because sometimes it happens to be one + end of a pipe, and a process is waiting on the other end for + EOF. Normally it would be closed at some point earlier in + destruction, but if we happen to cause the pipe to remain open, + EOF never occurs, and we get an infinite hang. Hence all the + games to pass in a file descriptor if it's actually needed. */ + + f = sysconf(_SC_OPEN_MAX); + if(f < 0) { + where = "sysconf failed"; + goto abort; + } + while (f--) { + if (f == sock) + continue; + close(f); + } while (1) { SV *target; - ssize_t got = read(sock, &target, sizeof(target)); + union control_un control; + struct msghdr msg; + struct iovec vec[1]; + struct cmsghdr *cmptr; + ssize_t got; + int got_fd; + + msg.msg_control = control.control; + msg.msg_controllen = sizeof(control.control); + /* We're a connected socket so we don't need a source */ + msg.msg_name = NULL; + msg.msg_namelen = 0; + msg.msg_iov = vec; + msg.msg_iovlen = sizeof(vec)/sizeof(vec[0]); + + vec[0].iov_base = (void*)⌖ + vec[0].iov_len = sizeof(target); + + got = recvmsg(sock, &msg, 0); if(got == 0) break; if(got < 0) { - perror("Debug leaking scalars child read failed"); - abort(); + where = "recv failed"; + goto abort; } if(got < sizeof(target)) { - perror("Debug leaking scalars child short read"); - abort(); + where = "short recv"; + goto abort; + } + + if(!(cmptr = CMSG_FIRSTHDR(&msg))) { + where = "no cmsg"; + goto abort; + } + if(cmptr->cmsg_len != CMSG_LEN(sizeof(int))) { + where = "wrong cmsg_len"; + goto abort; + } + if(cmptr->cmsg_level != SOL_SOCKET) { + where = "wrong cmsg_level"; + goto abort; + } + if(cmptr->cmsg_type != SCM_RIGHTS) { + where = "wrong cmsg_type"; + goto abort; + } + + got_fd = *(int*)CMSG_DATA(cmptr); + /* For our last little bit of trickery, put the file descriptor + back into Perl_debug_log, as if we never actually closed it + */ + if(got_fd != debug_fd) { + if (dup2(got_fd, debug_fd) == -1) { + where = "dup2"; + goto abort; + } } sv_dump(target); + PerlIO_flush(Perl_debug_log); - /* Write something back as synchronisation. */ - got = write(sock, &target, sizeof(target)); + got = write(sock, &success, sizeof(success)); if(got < 0) { - perror("Debug leaking scalars child write failed"); - abort(); + where = "write failed"; + goto abort; } - if(got < sizeof(target)) { - perror("Debug leaking scalars child short write"); - abort(); + if(got < sizeof(success)) { + where = "short write"; + goto abort; } } _exit(0); + abort: + { + int send_errno = errno; + unsigned char length = (unsigned char) strlen(where); + struct iovec failure[3] = { + {(void*)&send_errno, sizeof(send_errno)}, + {&length, 1}, + {(void*)where, length} + }; + int got = writev(sock, failure, 3); + /* Bad news travels fast. Faster than data. We'll get a SIGPIPE + in the parent if we try to read from the socketpair after the + child has exited, even if there was data to read. + So sleep a bit to give the parent a fighting chance of + reading the data. */ + sleep(2); + _exit((got == -1) ? errno : 0); + } + /* End of child. */ } - sock = fd[0]; + PL_dumper_fd = fd[0]; close(fd[1]); } #endif @@ -540,6 +750,8 @@ perl_destruct(pTHXx) */ sv_clean_objs(); PL_sv_objcount = 0; + if (PL_defoutgv && !SvREFCNT(PL_defoutgv)) + PL_defoutgv = Nullgv; /* may have been freed */ } /* unhook hooks which will soon be, or use, destroyed data */ @@ -567,7 +779,7 @@ perl_destruct(pTHXx) #endif /* The exit() function will do everything that needs doing. */ - return STATUS_NATIVE_EXPORT; + return STATUS_EXIT; } /* jettison our possibly duplicated environment */ @@ -607,10 +819,10 @@ perl_destruct(pTHXx) */ { I32 i = AvFILLp(PL_regex_padav) + 1; - SV **ary = AvARRAY(PL_regex_padav); + SV * const * const ary = AvARRAY(PL_regex_padav); while (i) { - SV *resv = ary[--i]; + SV * const resv = ary[--i]; if (SvFLAGS(resv) & SVf_BREAK) { /* this is PL_reg_curpm, already freed @@ -751,8 +963,10 @@ perl_destruct(pTHXx) PL_subname = Nullsv; SvREFCNT_dec(PL_linestr); PL_linestr = Nullsv; +#ifdef PERL_USES_PL_PIDSTATUS SvREFCNT_dec(PL_pidstatus); PL_pidstatus = Nullhv; +#endif SvREFCNT_dec(PL_toptarget); PL_toptarget = Nullsv; SvREFCNT_dec(PL_bodytarget); @@ -884,15 +1098,15 @@ perl_destruct(pTHXx) */ I32 riter = 0; const I32 max = HvMAX(PL_strtab); - HE **array = HvARRAY(PL_strtab); + HE * const * const array = HvARRAY(PL_strtab); HE *hent = array[0]; for (;;) { if (hent && ckWARN_d(WARN_INTERNAL)) { - HE *next = HeNEXT(hent); + HE * const next = HeNEXT(hent); Perl_warner(aTHX_ packWARN(WARN_INTERNAL), - "Unbalanced string table refcount: (%d) for \"%s\"", - HeVAL(hent) - Nullsv, HeKEY(hent)); + "Unbalanced string table refcount: (%ld) for \"%s\"", + (long)(HeVAL(hent) - Nullsv), HeKEY(hent)); Safefree(hent); hent = next; } @@ -951,11 +1165,6 @@ perl_destruct(pTHXx) svend = &sva[SvREFCNT(sva)]; for (sv = sva + 1; sv < svend; ++sv) { if (SvTYPE(sv) != SVTYPEMASK) { -#ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP - ssize_t got; - SV *target; -#endif - PerlIO_printf(Perl_debug_log, "leaked: sv=0x%p" " flags=0x%"UVxf " refcnt=%"UVuf pTHX__FORMAT "\n" @@ -968,31 +1177,8 @@ perl_destruct(pTHXx) PL_op_name[sv->sv_debug_optype]: "(none)", sv->sv_debug_cloned ? " (cloned)" : "" ); - #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP - PerlIO_flush(Perl_debug_log); - - got = write(sock, &sv, sizeof(sv)); - - if(got < 0) { - perror("Debug leaking scalars parent write failed"); - abort(); - } - if(got < sizeof(target)) { - perror("Debug leaking scalars parent short write"); - abort(); - } - - got = read(sock, &target, sizeof(target)); - - if(got < 0) { - perror("Debug leaking scalars parent read failed"); - abort(); - } - if(got < sizeof(target)) { - perror("Debug leaking scalars parent short read"); - abort(); - } + Perl_dump_sv_child(aTHX_ sv); #endif } } @@ -1006,6 +1192,7 @@ perl_destruct(pTHXx) This seems to be the least effort way of timing out on reaping its exit status. */ struct timeval waitfor = {4, 0}; + int sock = PL_dumper_fd; shutdown(sock, 1); FD_ZERO(&rset); @@ -1036,8 +1223,7 @@ perl_destruct(pTHXx) Safefree(PL_reg_start_tmp); PL_reg_start_tmp = (char**)NULL; PL_reg_start_tmpl = 0; - if (PL_reg_curpm) - Safefree(PL_reg_curpm); + Safefree(PL_reg_curpm); Safefree(PL_reg_poscache); free_tied_hv_pool(); Safefree(PL_op_mask); @@ -1086,7 +1272,7 @@ perl_destruct(pTHXx) Safefree(PL_mess_sv); PL_mess_sv = Nullsv; } - return STATUS_NATIVE_EXPORT; + return STATUS_EXIT; } /* @@ -1195,9 +1381,9 @@ S_set_caret_X(pTHX) { S_procself_val(aTHX_ GvSV(tmpgv), PL_origargv[0]); #else #ifdef OS2 - sv_setpv(GvSV(tmpgv), os2_execname(aTHX)); + sv_setpv(GvSVn(tmpgv), os2_execname(aTHX)); #else - sv_setpv(GvSV(tmpgv),PL_origargv[0]); + sv_setpv(GvSVn(tmpgv),PL_origargv[0]); #endif #endif } @@ -1219,6 +1405,8 @@ perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env) int ret; dJMPENV; + PERL_UNUSED_VAR(my_perl); + #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW #ifdef IAMSUID #undef IAMSUID @@ -1236,7 +1424,7 @@ setuid perl scripts securely.\n"); if (!PL_rehash_seed_set) PL_rehash_seed = get_hash_seed(); { - const char *s = PerlEnv_getenv("PERL_HASH_SEED_DEBUG"); + const char * const s = PerlEnv_getenv("PERL_HASH_SEED_DEBUG"); if (s && (atoi(s) == 1)) PerlIO_printf(Perl_debug_log, "HASH_SEED = %"UVuf"\n", PL_rehash_seed); @@ -1380,7 +1568,7 @@ setuid perl scripts securely.\n"); PL_curstash = PL_defstash; if (PL_checkav) call_list(oldscope, PL_checkav); - ret = STATUS_NATIVE_EXPORT; + ret = STATUS_EXIT; break; case 3: PerlIO_printf(Perl_error_log, "panic: top_env\n"); @@ -1512,9 +1700,8 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) argc--,argv++; } if (s && *s) { - char *p; STRLEN len = strlen(s); - p = savepvn(s, len); + const char * const p = savepvn(s, len); incpush(p, TRUE, TRUE, FALSE, FALSE); sv_catpvn(sv, "-I", 2); sv_catpvn(sv, p, len); @@ -1535,117 +1722,191 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) s++; goto reswitch; case 'V': - if (!PL_preambleav) - PL_preambleav = newAV(); - av_push(PL_preambleav, newSVpv("use Config qw(myconfig config_vars)",0)); - if (*++s != ':') { - STRLEN opts; - - PL_Sv = newSVpv("print myconfig();",0); + { + SV *opts_prog; + + if (!PL_preambleav) + PL_preambleav = newAV(); + av_push(PL_preambleav, + newSVpv("use Config;",0)); + if (*++s != ':') { + STRLEN opts; + + opts_prog = newSVpv("print Config::myconfig(),",0); #ifdef VMS - sv_catpv(PL_Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\","); + sv_catpv(opts_prog,"\"\\nCharacteristics of this PERLSHR image: \\n\","); #else - sv_catpv(PL_Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\","); + sv_catpv(opts_prog,"\"\\nCharacteristics of this binary (from libperl): \\n\","); #endif - opts = SvCUR(PL_Sv); + opts = SvCUR(opts_prog); - sv_catpv(PL_Sv,"\" Compile-time options:"); + Perl_sv_catpv(aTHX_ opts_prog,"\" Compile-time options:" # ifdef DEBUGGING - sv_catpv(PL_Sv," DEBUGGING"); + " DEBUGGING" +# endif +# ifdef DEBUG_LEAKING_SCALARS + " DEBUG_LEAKING_SCALARS" +# endif +# ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP + " DEBUG_LEAKING_SCALARS_FORK_DUMP" +# endif +# ifdef FAKE_THREADS + " FAKE_THREADS" # endif # ifdef MULTIPLICITY - sv_catpv(PL_Sv," MULTIPLICITY"); + " MULTIPLICITY" +# endif +# ifdef MYMALLOC + " MYMALLOC" +# endif +# ifdef NO_MATHOMS + " NO_MATHOMS" +# endif +# ifdef PERL_DONT_CREATE_GVSV + " PERL_DONT_CREATE_GVSV" +# endif +# ifdef PERL_GLOBAL_STRUCT + " PERL_GLOBAL_STRUCT" +# endif +# ifdef PERL_IMPLICIT_CONTEXT + " PERL_IMPLICIT_CONTEXT" +# endif +# ifdef PERL_IMPLICIT_SYS + " PERL_IMPLICIT_SYS" +# endif +# ifdef PERL_MALLOC_WRAP + " PERL_MALLOC_WRAP" +# endif +# ifdef PERL_NEED_APPCTX + " PERL_NEED_APPCTX" +# endif +# ifdef PERL_NEED_TIMESBASE + " PERL_NEED_TIMESBASE" +# endif +# ifdef PERL_OLD_COPY_ON_WRITE + " PERL_OLD_COPY_ON_WRITE" +# endif +# ifdef PERL_TRACK_MEMPOOL + " PERL_TRACK_MEMPOOL" +# endif +# ifdef PERL_USE_SAFE_PUTENV + " PERL_USE_SAFE_PUTENV" +# endif +#ifdef PERL_USES_PL_PIDSTATUS + " PERL_USES_PL_PIDSTATUS" +#endif +# ifdef PL_OP_SLAB_ALLOC + " PL_OP_SLAB_ALLOC" +# endif +# ifdef SPRINTF_RETURNS_STRLEN + " SPRINTF_RETURNS_STRLEN" +# endif +# ifdef THREADS_HAVE_PIDS + " THREADS_HAVE_PIDS" # endif # ifdef USE_5005THREADS - sv_catpv(PL_Sv," USE_5005THREADS"); + " USE_5005THREADS" # endif -# ifdef USE_ITHREADS - sv_catpv(PL_Sv," USE_ITHREADS"); +# ifdef USE_64_BIT_ALL + " USE_64_BIT_ALL" # endif # ifdef USE_64_BIT_INT - sv_catpv(PL_Sv," USE_64_BIT_INT"); + " USE_64_BIT_INT" # endif -# ifdef USE_64_BIT_ALL - sv_catpv(PL_Sv," USE_64_BIT_ALL"); +# ifdef USE_ITHREADS + " USE_ITHREADS" +# endif +# ifdef USE_LARGE_FILES + " USE_LARGE_FILES" # endif # ifdef USE_LONG_DOUBLE - sv_catpv(PL_Sv," USE_LONG_DOUBLE"); + " USE_LONG_DOUBLE" # endif -# ifdef USE_LARGE_FILES - sv_catpv(PL_Sv," USE_LARGE_FILES"); +# ifdef USE_PERLIO + " USE_PERLIO" # endif -# ifdef USE_SOCKS - sv_catpv(PL_Sv," USE_SOCKS"); +# ifdef USE_REENTRANT_API + " USE_REENTRANT_API" +# endif +# ifdef USE_SFIO + " USE_SFIO" # endif # ifdef USE_SITECUSTOMIZE - sv_catpv(PL_Sv," USE_SITECUSTOMIZE"); + " USE_SITECUSTOMIZE" # endif -# ifdef PERL_IMPLICIT_CONTEXT - sv_catpv(PL_Sv," PERL_IMPLICIT_CONTEXT"); -# endif -# ifdef PERL_IMPLICIT_SYS - sv_catpv(PL_Sv," PERL_IMPLICIT_SYS"); +# ifdef USE_SOCKS + " USE_SOCKS" # endif + ); - while (SvCUR(PL_Sv) > opts+76) { - /* find last space after "options: " and before col 76 */ + while (SvCUR(opts_prog) > opts+76) { + /* find last space after "options: " and before col 76 + */ - const char *space; - char *pv = SvPV_nolen(PL_Sv); - const char c = pv[opts+76]; - pv[opts+76] = '\0'; - space = strrchr(pv+opts+26, ' '); - pv[opts+76] = c; - if (!space) break; /* "Can't happen" */ + const char *space; + char * const pv = SvPV_nolen(opts_prog); + const char c = pv[opts+76]; + pv[opts+76] = '\0'; + space = strrchr(pv+opts+26, ' '); + pv[opts+76] = c; + if (!space) break; /* "Can't happen" */ - /* break the line before that space */ + /* break the line before that space */ - opts = space - pv; - sv_insert(PL_Sv, opts, 0, - "\\n ", 25); - } + opts = space - pv; + sv_insert(opts_prog, opts, 0, + "\\n ", 25); + } - sv_catpv(PL_Sv,"\\n\","); + sv_catpv(opts_prog,"\\n\","); #if defined(LOCAL_PATCH_COUNT) - if (LOCAL_PATCH_COUNT > 0) { - int i; - sv_catpv(PL_Sv,"\" Locally applied patches:\\n\","); - for (i = 1; i <= LOCAL_PATCH_COUNT; i++) { - if (PL_localpatches[i]) - Perl_sv_catpvf(aTHX_ PL_Sv,"q%c\t%s\n%c,", - 0, PL_localpatches[i], 0); + if (LOCAL_PATCH_COUNT > 0) { + int i; + sv_catpv(opts_prog, + "\" Locally applied patches:\\n\","); + for (i = 1; i <= LOCAL_PATCH_COUNT; i++) { + if (PL_localpatches[i]) + Perl_sv_catpvf(aTHX_ opts_prog,"q%c\t%s\n%c,", + 0, PL_localpatches[i], 0); + } } - } #endif - Perl_sv_catpvf(aTHX_ PL_Sv,"\" Built under %s\\n\"",OSNAME); + Perl_sv_catpvf(aTHX_ opts_prog, + "\" Built under %s\\n\"",OSNAME); #ifdef __DATE__ # ifdef __TIME__ - Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled at %s %s\\n\"",__DATE__,__TIME__); + Perl_sv_catpvf(aTHX_ opts_prog, + ",\" Compiled at %s %s\\n\"",__DATE__, + __TIME__); # else - Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled on %s\\n\"",__DATE__); + Perl_sv_catpvf(aTHX_ opts_prog,",\" Compiled on %s\\n\"", + __DATE__); # endif #endif - sv_catpv(PL_Sv, "; \ -$\"=\"\\n \"; \ -@env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; "); + sv_catpv(opts_prog, "; $\"=\"\\n \"; " + "@env = map { \"$_=\\\"$ENV{$_}\\\"\" } " + "sort grep {/^PERL/} keys %ENV; "); #ifdef __CYGWIN__ - sv_catpv(PL_Sv,"\ -push @env, \"CYGWIN=\\\"$ENV{CYGWIN}\\\"\";"); + sv_catpv(opts_prog, + "push @env, \"CYGWIN=\\\"$ENV{CYGWIN}\\\"\";"); #endif - sv_catpv(PL_Sv, "\ -print \" \\%ENV:\\n @env\\n\" if @env; \ -print \" \\@INC:\\n @INC\\n\";"); - } - else { - PL_Sv = newSVpv("config_vars(qw(",0); - sv_catpv(PL_Sv, ++s); - sv_catpv(PL_Sv, "))"); - s += strlen(s); + sv_catpv(opts_prog, + "print \" \\%ENV:\\n @env\\n\" if @env;" + "print \" \\@INC:\\n @INC\\n\";"); + } + else { + ++s; + opts_prog = Perl_newSVpvf(aTHX_ + "Config::config_vars(qw%c%s%c)", + 0, s, 0); + s += strlen(s); + } + av_push(PL_preambleav, opts_prog); + /* don't look for script or read stdin */ + scriptname = BIT_BUCKET; + goto reswitch; } - av_push(PL_preambleav, PL_Sv); - scriptname = BIT_BUCKET; /* don't look for script or read stdin */ - goto reswitch; case 'x': PL_doextract = TRUE; s++; @@ -1704,7 +1965,7 @@ print \" \\@INC:\\n @INC\\n\";"); d = s; if (!*s) break; - if (!strchr("DIMUdmtwA", *s)) + if (!strchr("CDIMUdmtwA", *s)) Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s); while (++s && *s) { if (isSPACE(*s)) { @@ -1774,7 +2035,7 @@ print \" \\@INC:\\n @INC\\n\";"); # define SIGCHLD SIGCLD #endif Sighandler_t sigstate = rsignal_state(SIGCHLD); - if (sigstate == SIG_IGN) { + if (sigstate == (Sighandler_t) SIG_IGN) { if (ckWARN(WARN_SIGNAL)) Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "Can't ignore signal CHLD, forcing to default"); @@ -1802,7 +2063,7 @@ print \" \\@INC:\\n @INC\\n\";"); CvPADLIST(PL_compcv) = pad_new(0); #ifdef USE_5005THREADS CvOWNER(PL_compcv) = 0; - New(666, CvMUTEXP(PL_compcv), 1, perl_mutex); + Newx(CvMUTEXP(PL_compcv), 1, perl_mutex); MUTEX_INIT(CvMUTEXP(PL_compcv)); #endif /* USE_5005THREADS */ @@ -1813,7 +2074,7 @@ print \" \\@INC:\\n @INC\\n\";"); if (xsinit) (*xsinit)(aTHX); /* in case linked C routines want magical variables */ #ifndef PERL_MICRO -#if defined(VMS) || defined(WIN32) || defined(DJGPP) || defined(__CYGWIN__) || defined(EPOC) +#if defined(VMS) || defined(WIN32) || defined(DJGPP) || defined(__CYGWIN__) || defined(EPOC) || defined(SYMBIAN) init_os_extras(); #endif #endif @@ -1837,7 +2098,7 @@ print \" \\@INC:\\n @INC\\n\";"); * or explicitly in some platforms. * locale.c:Perl_init_i18nl10n() if the environment * look like the user wants to use UTF-8. */ -#if defined(SYMBIAN) +#if defined(__SYMBIAN32__) PL_unicode = PERL_UNICODE_STD_FLAG; /* See PERL_SYMBIAN_CONSOLE_UTF8. */ #endif if (PL_unicode) { @@ -1957,6 +2218,8 @@ perl_run(pTHXx) int ret = 0; dJMPENV; + PERL_UNUSED_ARG(my_perl); + oldscope = PL_scopestack_ix; #ifdef VMS VMSISH_HUSHED = 0; @@ -1983,7 +2246,7 @@ perl_run(pTHXx) if (PerlEnv_getenv("PERL_DEBUG_MSTATS")) dump_mstats("after execution: "); #endif - ret = STATUS_NATIVE_EXPORT; + ret = STATUS_EXIT; break; case 3: if (PL_restartop) { @@ -2009,8 +2272,10 @@ S_run_body(pTHX_ I32 oldscope) if (!PL_restartop) { DEBUG_x(dump_all()); +#ifdef DEBUGGING if (!DEBUG_q_TEST) PERL_DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n")); +#endif DEBUG_S(PerlIO_printf(Perl_debug_log, "main thread is 0x%"UVxf"\n", PTR2UV(thr))); @@ -2090,7 +2355,7 @@ set and the variable does not exist then NULL is returned. AV* Perl_get_av(pTHX_ const char *name, I32 create) { - GV* gv = gv_fetchpv(name, create, SVt_PVAV); + GV* const gv = gv_fetchpv(name, create, SVt_PVAV); if (create) return GvAVn(gv); if (gv) @@ -2113,7 +2378,7 @@ set and the variable does not exist then NULL is returned. HV* Perl_get_hv(pTHX_ const char *name, I32 create) { - GV* gv = gv_fetchpv(name, create, SVt_PVHV); + GV* const gv = gv_fetchpv(name, create, SVt_PVHV); if (create) return GvHVn(gv); if (gv) @@ -2137,7 +2402,7 @@ subroutine does not exist then NULL is returned. CV* Perl_get_cv(pTHX_ const char *name, I32 create) { - GV* gv = gv_fetchpv(name, create, SVt_PVCV); + GV* const gv = gv_fetchpv(name, create, SVt_PVCV); /* XXX unsafe for threads if eval_owner isn't held */ /* XXX this is probably not what they think they're getting. * It has the same effect as "sub name;", i.e. just a forward @@ -2239,7 +2504,7 @@ Perl_call_sv(pTHX_ SV *sv, I32 flags) I32 oldscope; bool oldcatch = CATCH_GET; int ret; - OP* oldop = PL_op; + OP* const oldop = PL_op; dJMPENV; if (flags & G_DISCARD) { @@ -2356,6 +2621,9 @@ Perl_call_sv(pTHX_ SV *sv, I32 flags) POPEVAL(cx); PL_curpm = newpm; LEAVE; + PERL_UNUSED_VAR(newsp); + PERL_UNUSED_VAR(gimme); + PERL_UNUSED_VAR(optype); } JMPENV_POP; } @@ -2403,7 +2671,7 @@ Perl_eval_sv(pTHX_ SV *sv, I32 flags) volatile I32 oldmark = SP - PL_stack_base; volatile I32 retval = 0; int ret; - OP* oldop = PL_op; + OP* const oldop = PL_op; dJMPENV; if (flags & G_DISCARD) { @@ -2527,11 +2795,8 @@ Perl_require_pv(pTHX_ const char *pv) dSP; PUSHSTACKi(PERLSI_REQUIRE); PUTBACK; - sv = sv_newmortal(); - sv_setpv(sv, "require '"); - sv_catpv(sv, pv); - sv_catpv(sv, "'"); - eval_sv(sv, G_DISCARD); + sv = Perl_newSVpvf(aTHX_ "require q%c%s%c", 0, pv, 0); + eval_sv(sv_2mortal(sv), G_DISCARD); SPAGAIN; POPSTACK; } @@ -2539,9 +2804,9 @@ Perl_require_pv(pTHX_ const char *pv) void Perl_magicname(pTHX_ const char *sym, const char *name, I32 namlen) { - register GV *gv; + register GV * const gv = gv_fetchpv(sym,TRUE, SVt_PV); - if ((gv = gv_fetchpv(sym,TRUE, SVt_PV))) + if (gv) sv_magic(GvSV(gv), (SV*)gv, PERL_MAGIC_sv, name, namlen); } @@ -2633,7 +2898,7 @@ Perl_get_debug_opts(pTHX_ const char **s, bool givehelp) static const char debopts[] = "psltocPmfrxu HXDSTRJvCAq"; for (; isALNUM(**s); (*s)++) { - const char *d = strchr(debopts,**s); + const char * const d = strchr(debopts,**s); if (d) i |= 1 << (d - debopts); else if (ckWARN_d(WARN_DEBUGGING)) @@ -2646,7 +2911,7 @@ Perl_get_debug_opts(pTHX_ const char **s, bool givehelp) for (; isALNUM(**s); (*s)++) ; } else if (givehelp) { - char **p = (char **)usage_msgd; + const char *const *p = usage_msgd; while (*p) PerlIO_printf(PerlIO_stdout(), "%s\n", *p++); } # ifdef EBCDIC @@ -2742,8 +3007,7 @@ Perl_moreswitches(pTHX_ char *s) in the fashion that -MSome::Mod does. */ if (*s == ':' || *s == '=') { const char *start; - SV *sv; - sv = newSVpv("use Devel::", 0); + SV * const sv = newSVpv("use Devel::", 0); start = ++s; /* We now allow -d:Module=Foo,Bar */ while(isALNUM(*s) || *s==':') ++s; @@ -2751,12 +3015,10 @@ Perl_moreswitches(pTHX_ char *s) sv_catpv(sv, start); else { sv_catpvn(sv, start, s-start); - sv_catpv(sv, " split(/,/,q{"); - sv_catpv(sv, ++s); - sv_catpv(sv, "})"); + Perl_sv_catpvf(aTHX_ sv, " split(/,/,q%c%s%c)", 0, ++s, 0); } s += strlen(s); - my_setenv("PERL5DB", SvPV(sv, PL_na)); + my_setenv("PERL5DB", SvPV_nolen_const(sv)); } if (!PL_perldb) { PL_perldb = PERLDB_ALL; @@ -2781,8 +3043,7 @@ Perl_moreswitches(pTHX_ char *s) usage(PL_origargv[0]); my_exit(0); case 'i': - if (PL_inplace) - Safefree(PL_inplace); + Safefree(PL_inplace); #if defined(__CYGWIN__) /* do backup extension automagically */ if (*(s+1) == '\0') { PL_inplace = savepv(".bak"); @@ -2853,21 +3114,19 @@ Perl_moreswitches(pTHX_ char *s) PL_preambleav = newAV(); s++; { - char *start = s; - SV *sv = newSVpv("use assertions::activate", 24); + char * const start = s; + SV * const sv = newSVpv("use assertions::activate", 24); while(isALNUM(*s) || *s == ':') ++s; if (s != start) { sv_catpvn(sv, "::", 2); sv_catpvn(sv, start, s-start); } if (*s == '=') { - sv_catpvn(sv, " split(/,/,q\0", 13); - sv_catpv(sv, s+1); - sv_catpvn(sv, "\0)", 2); + Perl_sv_catpvf(aTHX_ sv, " split(/,/,q%c%s%c)", 0, ++s, 0); s+=strlen(s); } else if (*s != '\0') { - Perl_croak(aTHX_ "Can't use '%c' after -A%.*s", *s, s-start, start); + Perl_croak(aTHX_ "Can't use '%c' after -A%.*s", *s, (int)(s-start), start); } av_push(PL_preambleav, sv); return s; @@ -2882,8 +3141,10 @@ Perl_moreswitches(pTHX_ char *s) SV *sv; const char *use = "use "; /* -M-foo == 'no foo' */ - if (*s == '-') { use = "no "; ++s; } - sv = newSVpv(use,0); + /* Leading space on " no " is deliberate, to make both + possibilities the same length. */ + if (*s == '-') { use = " no "; ++s; } + sv = newSVpvn(use,4); start = s; /* We allow -M'Module qw(Foo Bar)' */ while(isALNUM(*s) || *s==':') ++s; @@ -3038,7 +3299,7 @@ Perl_moreswitches(pTHX_ char *s) PerlIO_printf(PerlIO_stdout(),"Built on " __DATE__ " " __TIME__ "\n\n"); wce_hitreturn(); #endif -#ifdef SYMBIAN +#ifdef __SYMBIAN32__ PerlIO_printf(PerlIO_stdout(), "Symbian port by Nokia, 2004-2005\n"); #endif @@ -3187,17 +3448,23 @@ S_init_main_stash(pTHX) SvREFCNT_dec(GvHV(gv)); GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash); SvREADONLY_on(gv); - Perl_hv_name_set(aTHX_ PL_defstash, "main", 4, 0); + hv_name_set(PL_defstash, "main", 4, 0); PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV))); + SvREFCNT_inc(PL_incgv); /* Don't allow it to be freed */ GvMULTI_on(PL_incgv); PL_hintgv = gv_fetchpv("\010",TRUE, SVt_PV); /* ^H */ GvMULTI_on(PL_hintgv); PL_defgv = gv_fetchpv("_",TRUE, SVt_PVAV); + SvREFCNT_inc(PL_defgv); PL_errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV)); + SvREFCNT_inc(PL_errgv); GvMULTI_on(PL_errgv); PL_replgv = gv_fetchpv("\022", TRUE, SVt_PV); /* ^R */ GvMULTI_on(PL_replgv); (void)Perl_form(aTHX_ "%240s",""); /* Preallocate temp - for immediate signals. */ +#ifdef PERL_DONT_CREATE_GVSV + gv_SVadd(PL_errgv); +#endif sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */ sv_setpvn(ERRSV, "", 0); PL_curstash = PL_defstash; @@ -3293,9 +3560,9 @@ S_open_script(pTHX_ const char *scriptname, bool dosearch, SV *sv) } #else /* IAMSUID */ else if (PL_preprocess) { - const char *cpp_cfg = CPPSTDIN; - SV *cpp = newSVpvn("",0); - SV *cmd = NEWSV(0,0); + const char * const cpp_cfg = CPPSTDIN; + SV * const cpp = newSVpvn("",0); + SV * const cmd = NEWSV(0,0); if (cpp_cfg[0] == 0) /* PERL_MICRO? */ Perl_croak(aTHX_ "Can't run with cpp -P with CPPSTDIN undefined"); @@ -3373,8 +3640,11 @@ S_open_script(pTHX_ const char *scriptname, bool dosearch, SV *sv) #endif /* IAMSUID */ if (!PL_rsfp) { /* PSz 16 Sep 03 Keep neat error message */ - Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n", - CopFILE(PL_curcop), Strerror(errno)); + if (PL_e_script) + Perl_croak(aTHX_ "Can't open "BIT_BUCKET": %s\n", Strerror(errno)); + else + Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n", + CopFILE(PL_curcop), Strerror(errno)); } } @@ -3464,10 +3734,9 @@ S_fd_on_nosuid_fs(pTHX_ int fd) 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; - on_noexec = fsd.fd_req.flags & PERL_MOUNT_NOEXEC; - } + check_okay = 1; + on_nosuid = fsd.fd_req.flags & PERL_MOUNT_NOSUID; + on_noexec = fsd.fd_req.flags & PERL_MOUNT_NOEXEC; } } } @@ -3556,6 +3825,7 @@ S_validate_suid(pTHX_ const char *validarg, const char *scriptname) if (PL_statbuf.st_mode & (S_ISUID|S_ISGID)) { I32 len; const char *linestr; + const char *s_end; #ifdef IAMSUID if (PL_fdscript < 0 || PL_suidscript != 1) @@ -3661,7 +3931,8 @@ S_validate_suid(pTHX_ const char *validarg, const char *scriptname) s = linestr; /* PSz 27 Feb 04 */ /* Sanity check on line length */ - if (strlen(s) < 1 || strlen(s) > 4000) + s_end = s + strlen(s); + if (s_end == s || (s_end - s) > 4000) Perl_croak(aTHX_ "Very long #! line"); /* Allow more than a single space after #! */ while (isSPACE(*s)) s++; @@ -3700,7 +3971,8 @@ S_validate_suid(pTHX_ const char *validarg, const char *scriptname) len = strlen(validarg); if (strEQ(validarg," PHOOEY ") || strnNE(s,validarg,len) || !isSPACE(s[len]) || - !(strlen(s) == len+1 || (strlen(s) == len+2 && isSPACE(s[len+1])))) + !((s_end - s) == len+1 + || ((s_end - s) == len+2 && isSPACE(s[len+1])))) Perl_croak(aTHX_ "Args must match #! line"); #ifndef IAMSUID @@ -4088,7 +4360,7 @@ S_forbid_setid(pTHX_ const char *s) void Perl_init_debugger(pTHX) { - HV *ostash = PL_curstash; + HV * const ostash = PL_curstash; PL_curstash = PL_debstash; PL_dbargs = GvAV(gv_AVadd((gv_fetchpv("DB::args", GV_ADDMULTI, SVt_PVAV)))); @@ -4127,22 +4399,22 @@ Perl_init_stacks(pTHX) PL_stack_sp = PL_stack_base; PL_stack_max = PL_stack_base + AvMAX(PL_curstack); - New(50,PL_tmps_stack,REASONABLE(128),SV*); + Newx(PL_tmps_stack,REASONABLE(128),SV*); PL_tmps_floor = -1; PL_tmps_ix = -1; PL_tmps_max = REASONABLE(128); - New(54,PL_markstack,REASONABLE(32),I32); + Newx(PL_markstack,REASONABLE(32),I32); PL_markstack_ptr = PL_markstack; PL_markstack_max = PL_markstack + REASONABLE(32); SET_MARK_OFFSET; - New(54,PL_scopestack,REASONABLE(32),I32); + Newx(PL_scopestack,REASONABLE(32),I32); PL_scopestack_ix = 0; PL_scopestack_max = REASONABLE(32); - New(54,PL_savestack,REASONABLE(128),ANY); + Newx(PL_savestack,REASONABLE(128),ANY); PL_savestack_ix = 0; PL_savestack_max = REASONABLE(128); } @@ -4215,18 +4487,17 @@ S_init_predump_symbols(pTHX) PL_statname = NEWSV(66,0); /* last filename we did stat on */ - if (PL_osname) - Safefree(PL_osname); + Safefree(PL_osname); PL_osname = savepv(OSNAME); } void Perl_init_argv_symbols(pTHX_ register int argc, register char **argv) { - char *s; argc--,argv++; /* skip name of script */ if (PL_doswitches) { for (; argc > 0 && **argv == '-'; argc--,argv++) { + char *s; if (!argv[0][1]) break; if (argv[0][1] == '-' && !argv[0][2]) { @@ -4246,7 +4517,7 @@ Perl_init_argv_symbols(pTHX_ register int argc, register char **argv) (void)gv_AVadd(PL_argvgv); av_clear(GvAVn(PL_argvgv)); for (; argc > 0; argc--,argv++) { - SV *sv = newSVpv(argv[0],0); + SV * const sv = newSVpv(argv[0],0); av_push(GvAVn(PL_argvgv),sv); if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) { if (PL_unicode & PERL_UNICODE_ARGV_FLAG) @@ -4359,7 +4630,16 @@ S_init_perllib(pTHX) if (!PL_tainting) { #ifndef VMS s = PerlEnv_getenv("PERL5LIB"); +/* + * It isn't possible to delete an environment variable with + * PERL_USE_SAFE_PUTENV set unless unsetenv() is also available, so in that + * case we treat PERL5LIB as undefined if it has a zero-length value. + */ +#if defined(PERL_USE_SAFE_PUTENV) && ! defined(HAS_UNSETENV) + if (s && *s != '\0') +#else if (s) +#endif incpush(s, TRUE, TRUE, TRUE, FALSE); else incpush(PerlEnv_getenv("PERLLIB"), FALSE, FALSE, TRUE, FALSE); @@ -4467,7 +4747,7 @@ S_init_perllib(pTHX) #endif /* MACOS_TRADITIONAL */ } -#if defined(DOSISH) || defined(EPOC) || defined(SYMBIAN) +#if defined(DOSISH) || defined(EPOC) || defined(__SYMBIAN32__) # define PERLLIB_SEP ';' #else # if defined(VMS) @@ -4566,11 +4846,11 @@ S_incpush(pTHX_ const char *dir, bool addsubdirs, bool addoldvers, bool usesep, * The intent is that /usr/local/bin/perl and .../../lib/perl5 * generates /usr/local/lib/perl5 */ - char *libpath = SvPVX(libdir); + const char *libpath = SvPVX(libdir); STRLEN libpath_len = SvCUR(libdir); if (libpath_len >= 4 && memEQ (libpath, ".../", 4)) { /* Game on! */ - SV *caret_X = get_sv("\030", 0); + SV * const caret_X = get_sv("\030", 0); /* Going to use the SV just as a scratch buffer holding a C string: */ SV *prefix_sv; @@ -4651,8 +4931,8 @@ S_incpush(pTHX_ const char *dir, bool addsubdirs, bool addoldvers, bool usesep, if (addsubdirs || addoldvers) { #ifdef PERL_INC_VERSION_LIST /* Configure terminates PERL_INC_VERSION_LIST with a NULL */ - const char *incverlist[] = { PERL_INC_VERSION_LIST }; - const char **incver; + const char * const incverlist[] = { PERL_INC_VERSION_LIST }; + const char * const *incver; #endif #ifdef VMS char *unix; @@ -4726,7 +5006,7 @@ S_init_main_thread(pTHX) #endif XPV *xpv; - Newz(53, thr, 1, struct perl_thread); + Newxz(thr, 1, struct perl_thread); PL_curcop = &PL_compiling; thr->interp = PERL_GET_INTERP; thr->cvcache = newHV(); @@ -4736,8 +5016,8 @@ S_init_main_thread(pTHX) thr->flags = THRf_R_JOINABLE; MUTEX_INIT(&thr->mutex); /* Handcraft thrsv similarly to mess_sv */ - New(53, PL_thrsv, 1, SV); - Newz(53, xpv, 1, XPV); + Newx(PL_thrsv, 1, SV); + Newxz(xpv, 1, XPV); SvFLAGS(PL_thrsv) = SVt_PV; SvANY(PL_thrsv) = (void*)xpv; SvREFCNT(PL_thrsv) = 1 << 30; /* practically infinite */ @@ -4907,7 +5187,7 @@ Perl_my_exit(pTHX_ U32 status) STATUS_ALL_FAILURE; break; default: - STATUS_NATIVE_SET(status); + STATUS_EXIT_SET(status); break; } my_exit_jump(); @@ -4917,16 +5197,60 @@ void Perl_my_failure_exit(pTHX) { #ifdef VMS - if (vaxc$errno & 1) { - if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */ - STATUS_NATIVE_SET(44); + /* We have been called to fall on our sword. The desired exit code + * should be already set in STATUS_UNIX, but could be shifted over + * by 8 bits. STATUS_UNIX_EXIT_SET will handle the cases where a + * that code is set. + * + * If an error code has not been set, then force the issue. + */ + if (MY_POSIX_EXIT) { + + /* In POSIX_EXIT mode follow Perl documentations and use 255 for + * the exit code when there isn't an error. + */ + + if (STATUS_UNIX == 0) + STATUS_UNIX_EXIT_SET(255); + else { + STATUS_UNIX_EXIT_SET(STATUS_UNIX); + + /* The exit code could have been set by $? or vmsish which + * means that it may not be fatal. So convert + * success/warning codes to fatal. + */ + if ((STATUS_NATIVE & (STS$K_SEVERE|STS$K_ERROR)) == 0) + STATUS_UNIX_EXIT_SET(255); + } } else { - if (!vaxc$errno) /* unlikely */ - STATUS_NATIVE_SET(44); - else - STATUS_NATIVE_SET(vaxc$errno); + /* Traditionally Perl on VMS always expects a Fatal Error. */ + if (vaxc$errno & 1) { + + /* So force success status to failure */ + if (STATUS_NATIVE & 1) + STATUS_ALL_FAILURE; + } + else { + if (!vaxc$errno) { + STATUS_UNIX = EINTR; /* In case something cares */ + STATUS_ALL_FAILURE; + } + else { + int severity; + STATUS_NATIVE = vaxc$errno; /* Should already be this */ + + /* Encode the severity code */ + severity = STATUS_NATIVE & STS$M_SEVERITY; + STATUS_UNIX = (severity ? severity : 1) << 8; + + /* Perl expects this to be a fatal error */ + if (severity != STS$K_SEVERE) + STATUS_ALL_FAILURE; + } + } } + #else int exitstatus; if (errno & 255) @@ -4964,17 +5288,19 @@ S_my_exit_jump(pTHX) } JMPENV_JUMP(2); + PERL_UNUSED_VAR(gimme); + PERL_UNUSED_VAR(newsp); } static I32 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen) { - const char *p, *nl; - (void)idx; - (void)maxlen; + const char * const p = SvPVX_const(PL_e_script); + const char *nl = strchr(p, '\n'); + + PERL_UNUSED_ARG(idx); + PERL_UNUSED_ARG(maxlen); - p = SvPVX_const(PL_e_script); - nl = strchr(p, '\n'); nl = (nl) ? nl+1 : SvEND(PL_e_script); if (nl-p == 0) { filter_del(read_e_script);