diff options
| author | Michael G Schwern <schwern@pobox.com> | 2021-05-05 07:18:01 -0600 |
|---|---|---|
| committer | Karl Williamson <khw@cpan.org> | 2021-05-31 10:56:32 -0600 |
| commit | 1f4fbd3b4b26604673abca2a5f911744e826b1f3 (patch) | |
| tree | 7773c49ab07c92cda1f284740365a13e835c1376 /perl.c | |
| parent | 77a6d54c0deb1165b37dcf11c21cd334ae2579bb (diff) | |
| download | perl-1f4fbd3b4b26604673abca2a5f911744e826b1f3.tar.gz | |
Base *.[ch] files: Replace leading tabs with blanks
This is a rebasing by @khw of part of GH #18792, which I needed to get
in now to proceed with other commits.
It also strips trailing white space from the affected files.
Diffstat (limited to 'perl.c')
| -rw-r--r-- | perl.c | 3830 |
1 files changed, 1915 insertions, 1915 deletions
@@ -40,7 +40,7 @@ #include "XSUB.h" #ifdef NETWARE -#include "nwutil.h" +#include "nwutil.h" #endif #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP @@ -73,9 +73,9 @@ static I32 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen); #define CALL_BODY_SUB(myop) \ if (PL_op == (myop)) \ - PL_op = PL_ppaddr[OP_ENTERSUB](aTHX); \ + PL_op = PL_ppaddr[OP_ENTERSUB](aTHX); \ if (PL_op) \ - CALLRUNOPS(aTHX); + CALLRUNOPS(aTHX); #define CALL_LIST_BODY(cv) \ PUSHMARK(PL_stack_sp); \ @@ -84,21 +84,21 @@ static I32 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen); static void S_init_tls_and_interp(PerlInterpreter *my_perl) { - if (!PL_curinterp) { - PERL_SET_INTERP(my_perl); + if (!PL_curinterp) { + PERL_SET_INTERP(my_perl); #if defined(USE_ITHREADS) - INIT_THREADS; - ALLOC_THREAD_KEY; - PERL_SET_THX(my_perl); - OP_REFCNT_INIT; - OP_CHECK_MUTEX_INIT; + INIT_THREADS; + ALLOC_THREAD_KEY; + PERL_SET_THX(my_perl); + OP_REFCNT_INIT; + OP_CHECK_MUTEX_INIT; KEYWORD_PLUGIN_MUTEX_INIT; - HINTS_REFCNT_INIT; + HINTS_REFCNT_INIT; LOCALE_INIT; USER_PROP_MUTEX_INIT; ENV_INIT; - MUTEX_INIT(&PL_dollarzero_mutex); - MUTEX_INIT(&PL_my_ctx_mutex); + MUTEX_INIT(&PL_dollarzero_mutex); + MUTEX_INIT(&PL_my_ctx_mutex); # endif } #if defined(USE_ITHREADS) @@ -107,7 +107,7 @@ S_init_tls_and_interp(PerlInterpreter *my_perl) /* This always happens for non-ithreads */ #endif { - PERL_SET_THX(my_perl); + PERL_SET_THX(my_perl); } } @@ -141,7 +141,7 @@ void Perl_sys_term(void) { if (!PL_veto_cleanup) { - PERL_SYS_TERM_BODY(); + PERL_SYS_TERM_BODY(); } } @@ -149,10 +149,10 @@ Perl_sys_term(void) #ifdef PERL_IMPLICIT_SYS PerlInterpreter * 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) + struct IPerlMem* ipMP, struct IPerlEnv* ipE, + struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO, + struct IPerlDir* ipD, struct IPerlSock* ipS, + struct IPerlProc* ipP) { PerlInterpreter *my_perl; @@ -385,7 +385,7 @@ perl_construct(pTHXx) PL_clocktick = sysconf(_SC_CLK_TCK); if (PL_clocktick <= 0) #endif - PL_clocktick = HZ; + PL_clocktick = HZ; PL_stashcache = newHV(); @@ -395,16 +395,16 @@ perl_construct(pTHXx) if (!PL_mmap_page_size) { #if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_MMAP_PAGE_SIZE)) { - SETERRNO(0, SS_NORMAL); + SETERRNO(0, SS_NORMAL); # ifdef _SC_PAGESIZE - PL_mmap_page_size = sysconf(_SC_PAGESIZE); + PL_mmap_page_size = sysconf(_SC_PAGESIZE); # else - PL_mmap_page_size = sysconf(_SC_MMAP_PAGE_SIZE); + PL_mmap_page_size = sysconf(_SC_MMAP_PAGE_SIZE); # endif - if ((long) PL_mmap_page_size < 0) { - Perl_croak(aTHX_ "panic: sysconf: %s", - errno ? Strerror(errno) : "pagesize unknown"); - } + if ((long) PL_mmap_page_size < 0) { + Perl_croak(aTHX_ "panic: sysconf: %s", + errno ? Strerror(errno) : "pagesize unknown"); + } } #elif defined(HAS_GETPAGESIZE) PL_mmap_page_size = getpagesize(); @@ -412,8 +412,8 @@ perl_construct(pTHXx) PL_mmap_page_size = PAGESIZE; /* compiletime, bad */ #endif if (PL_mmap_page_size <= 0) - Perl_croak(aTHX_ "panic: bad pagesize %" IVdf, - (IV) PL_mmap_page_size); + Perl_croak(aTHX_ "panic: bad pagesize %" IVdf, + (IV) PL_mmap_page_size); } #endif /* HAS_MMAP */ @@ -464,7 +464,7 @@ Perl_dump_sv_child(pTHX_ SV *sv) PERL_ARGS_ASSERT_DUMP_SV_CHILD; if(sock == -1 || debug_fd == -1) - return; + return; PerlIO_flush(Perl_debug_log); @@ -493,12 +493,12 @@ Perl_dump_sv_child(pTHX_ SV *sv) got = sendmsg(sock, &msg, 0); if(got < 0) { - perror("Debug leaking scalars parent sendmsg failed"); - abort(); + perror("Debug leaking scalars parent sendmsg failed"); + abort(); } if(got < sizeof(sv)) { - perror("Debug leaking scalars parent short sendmsg"); - abort(); + perror("Debug leaking scalars parent short sendmsg"); + abort(); } /* Return protocol is @@ -514,35 +514,35 @@ Perl_dump_sv_child(pTHX_ SV *sv) got = readv(sock, vec, 2); if(got < 0) { - perror("Debug leaking scalars parent read failed"); - PerlIO_flush(PerlIO_stderr()); - abort(); + 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(); + 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(); - } + 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(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)); + 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 @@ -601,8 +601,8 @@ perl_destruct(pTHXx) destruct_level = PL_perl_destruct_level; { - const char * const s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL"); - if (s) { + const char * const s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL"); + if (s) { int i; if (strEQ(s, "-1")) { /* Special case: modperl folklore. */ i = -1; @@ -613,12 +613,12 @@ perl_destruct(pTHXx) else i = 0; } - if (destruct_level < i) destruct_level = i; + if (destruct_level < i) destruct_level = i; #ifdef PERL_TRACK_MEMPOOL /* RT #114496, for perl_free */ PL_perl_destruct_level = i; #endif - } + } } if (PL_exit_flags & PERL_EXIT_DESTRUCT_END) { @@ -626,11 +626,11 @@ perl_destruct(pTHXx) int x = 0; JMPENV_PUSH(x); - PERL_UNUSED_VAR(x); + PERL_UNUSED_VAR(x); if (PL_endav && !PL_minus_c) { - PERL_SET_PHASE(PERL_PHASE_END); + PERL_SET_PHASE(PERL_PHASE_END); call_list(PL_scopestack_ix, PL_endav); - } + } JMPENV_POP; } LEAVE; @@ -694,164 +694,164 @@ perl_destruct(pTHXx) if (PL_threadhook(aTHX)) { /* Threads hook has vetoed further cleanup */ - PL_veto_cleanup = TRUE; + PL_veto_cleanup = TRUE; return STATUS_EXIT; } #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP if (destruct_level != 0) { - /* Fork here to create a child. Our child's job is to preserve the - state of scalars prior to destruction, so that we can instruct it - to dump any scalars that we later find have leaked. - There's no subtlety in this code - it assumes POSIX, and it doesn't - fail gracefully */ - int fd[2]; - - if(PerlSock_socketpair_cloexec(AF_UNIX, SOCK_STREAM, 0, fd)) { - perror("Debug leaking scalars socketpair failed"); - abort(); - } - - child = fork(); - if(child == -1) { - perror("Debug leaking scalars fork failed"); - abort(); - } - 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] = {0}; - - close(fd[0]); - - /* 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; - 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 = C_ARRAY_LENGTH(vec); - - vec[0].iov_base = (void*)⌖ - vec[0].iov_len = sizeof(target); - - got = recvmsg(sock, &msg, 0); - - if(got == 0) - break; - if(got < 0) { - where = "recv failed"; - goto abort; - } - if(got < sizeof(target)) { - 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 (PerlLIO_dup2_cloexec(got_fd, debug_fd) == -1) { - where = "dup2"; - goto abort; - } - } - sv_dump(target); - - PerlIO_flush(Perl_debug_log); - - got = write(sock, &success, sizeof(success)); - - if(got < 0) { - where = "write failed"; - goto 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. */ - } - PL_dumper_fd = fd[0]; - close(fd[1]); - } -#endif - + /* Fork here to create a child. Our child's job is to preserve the + state of scalars prior to destruction, so that we can instruct it + to dump any scalars that we later find have leaked. + There's no subtlety in this code - it assumes POSIX, and it doesn't + fail gracefully */ + int fd[2]; + + if(PerlSock_socketpair_cloexec(AF_UNIX, SOCK_STREAM, 0, fd)) { + perror("Debug leaking scalars socketpair failed"); + abort(); + } + + child = fork(); + if(child == -1) { + perror("Debug leaking scalars fork failed"); + abort(); + } + 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] = {0}; + + close(fd[0]); + + /* 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; + 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 = C_ARRAY_LENGTH(vec); + + vec[0].iov_base = (void*)⌖ + vec[0].iov_len = sizeof(target); + + got = recvmsg(sock, &msg, 0); + + if(got == 0) + break; + if(got < 0) { + where = "recv failed"; + goto abort; + } + if(got < sizeof(target)) { + 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 (PerlLIO_dup2_cloexec(got_fd, debug_fd) == -1) { + where = "dup2"; + goto abort; + } + } + sv_dump(target); + + PerlIO_flush(Perl_debug_log); + + got = write(sock, &success, sizeof(success)); + + if(got < 0) { + where = "write failed"; + goto 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. */ + } + PL_dumper_fd = fd[0]; + close(fd[1]); + } +#endif + /* We must account for everything. */ /* Destroy the main CV and syntax tree */ @@ -861,13 +861,13 @@ perl_destruct(pTHXx) op from which the filename structure member is copied. */ PL_curcop = &PL_compiling; if (PL_main_root) { - /* ensure comppad/curpad to refer to main's pad */ - if (CvPADLIST(PL_main_cv)) { - PAD_SET_CUR_NOSAVE(CvPADLIST(PL_main_cv), 1); - PL_comppad_name = PadlistNAMES(CvPADLIST(PL_main_cv)); - } - op_free(PL_main_root); - PL_main_root = NULL; + /* ensure comppad/curpad to refer to main's pad */ + if (CvPADLIST(PL_main_cv)) { + PAD_SET_CUR_NOSAVE(CvPADLIST(PL_main_cv), 1); + PL_comppad_name = PadlistNAMES(CvPADLIST(PL_main_cv)); + } + op_free(PL_main_root); + PL_main_root = NULL; } PL_main_start = NULL; /* note that PL_main_cv isn't usually actually freed at this point, @@ -900,7 +900,7 @@ perl_destruct(pTHXx) /* call exit list functions */ while (PL_exitlistlen-- > 0) - PL_exitlist[PL_exitlistlen].fn(aTHX_ PL_exitlist[PL_exitlistlen].ptr); + PL_exitlist[PL_exitlistlen].fn(aTHX_ PL_exitlist[PL_exitlistlen].ptr); Safefree(PL_exitlist); @@ -917,36 +917,36 @@ perl_destruct(pTHXx) #if defined(USE_ENVIRON_ARRAY) && !defined(PERL_USE_SAFE_PUTENV) if (environ != PL_origenviron && !PL_use_safe_putenv #ifdef USE_ITHREADS - /* only main thread can free environ[0] contents */ - && PL_curinterp == aTHX + /* only main thread can free environ[0] contents */ + && PL_curinterp == aTHX #endif - ) + ) { - I32 i; + I32 i; - for (i = 0; environ[i]; i++) - safesysfree(environ[i]); + for (i = 0; environ[i]; i++) + safesysfree(environ[i]); - /* Must use safesysfree() when working with environ. */ - safesysfree(environ); + /* Must use safesysfree() when working with environ. */ + safesysfree(environ); - environ = PL_origenviron; + environ = PL_origenviron; } #endif #endif /* !PERL_MICRO */ if (destruct_level == 0) { - DEBUG_P(debprofdump()); + DEBUG_P(debprofdump()); #if defined(PERLIO_LAYERS) - /* No more IO - including error messages ! */ - PerlIO_cleanup(aTHX); + /* No more IO - including error messages ! */ + PerlIO_cleanup(aTHX); #endif - CopFILE_free(&PL_compiling); + CopFILE_free(&PL_compiling); - /* The exit() function will do everything that needs doing. */ + /* The exit() function will do everything that needs doing. */ return STATUS_EXIT; } @@ -959,13 +959,13 @@ perl_destruct(pTHXx) * we need to manually ReREFCNT_dec for the clones */ { - I32 i = AvFILLp(PL_regex_padav); - SV **ary = AvARRAY(PL_regex_padav); + I32 i = AvFILLp(PL_regex_padav); + SV **ary = AvARRAY(PL_regex_padav); - for (; i; i--) { - SvREFCNT_dec(ary[i]); - ary[i] = &PL_sv_undef; - } + for (; i; i--) { + SvREFCNT_dec(ary[i]); + ary[i] = &PL_sv_undef; + } } #endif @@ -977,13 +977,13 @@ perl_destruct(pTHXx) /* XXX can PL_parser still be non-null here? */ if(PL_parser && PL_parser->rsfp) { - (void)PerlIO_close(PL_parser->rsfp); - PL_parser->rsfp = NULL; + (void)PerlIO_close(PL_parser->rsfp); + PL_parser->rsfp = NULL; } if (PL_minus_F) { - Safefree(PL_splitstr); - PL_splitstr = NULL; + Safefree(PL_splitstr); + PL_splitstr = NULL; } /* switches */ @@ -1004,8 +1004,8 @@ perl_destruct(pTHXx) SvREFCNT_dec(PL_patchlevel); if (PL_e_script) { - SvREFCNT_dec(PL_e_script); - PL_e_script = NULL; + SvREFCNT_dec(PL_e_script); + PL_e_script = NULL; } PL_perldb = 0; @@ -1258,20 +1258,20 @@ perl_destruct(pTHXx) FREETMPS; if (destruct_level >= 2) { - if (PL_scopestack_ix != 0) - Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), - "Unbalanced scopes: %ld more ENTERs than LEAVEs\n", - (long)PL_scopestack_ix); - if (PL_savestack_ix != 0) - Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), - "Unbalanced saves: %ld more saves than restores\n", - (long)PL_savestack_ix); - if (PL_tmps_floor != -1) - Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced tmps: %ld more allocs than frees\n", - (long)PL_tmps_floor + 1); - if (cxstack_ix != -1) - Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced context: %ld more PUSHes than POPs\n", - (long)cxstack_ix + 1); + if (PL_scopestack_ix != 0) + Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), + "Unbalanced scopes: %ld more ENTERs than LEAVEs\n", + (long)PL_scopestack_ix); + if (PL_savestack_ix != 0) + Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), + "Unbalanced saves: %ld more saves than restores\n", + (long)PL_savestack_ix); + if (PL_tmps_floor != -1) + Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced tmps: %ld more allocs than frees\n", + (long)PL_tmps_floor + 1); + if (cxstack_ix != -1) + Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced context: %ld more PUSHes than POPs\n", + (long)cxstack_ix + 1); } #ifdef USE_ITHREADS @@ -1290,7 +1290,7 @@ perl_destruct(pTHXx) /* the 2 is for PL_fdpid and PL_strtab */ while (sv_clean_all() > 2) - ; + ; #ifdef USE_ITHREADS Safefree(PL_stashpad); /* must come after sv_clean_all */ @@ -1312,36 +1312,36 @@ perl_destruct(pTHXx) /* Destruct the global string table. */ { - /* Yell and reset the HeVAL() slots that are still holding refcounts, - * so that sv_free() won't fail on them. - * Now that the global string table is using a single hunk of memory - * for both HE and HEK, we either need to explicitly unshare it the - * correct way, or actually free things here. - */ - I32 riter = 0; - const I32 max = HvMAX(PL_strtab); - HE * const * const array = HvARRAY(PL_strtab); - HE *hent = array[0]; - - for (;;) { - if (hent && ckWARN_d(WARN_INTERNAL)) { - HE * const next = HeNEXT(hent); - Perl_warner(aTHX_ packWARN(WARN_INTERNAL), - "Unbalanced string table refcount: (%ld) for \"%s\"", - (long)hent->he_valu.hent_refcount, HeKEY(hent)); - Safefree(hent); - hent = next; - } - if (!hent) { - if (++riter > max) - break; - hent = array[riter]; - } - } - - Safefree(array); - HvARRAY(PL_strtab) = 0; - HvTOTALKEYS(PL_strtab) = 0; + /* Yell and reset the HeVAL() slots that are still holding refcounts, + * so that sv_free() won't fail on them. + * Now that the global string table is using a single hunk of memory + * for both HE and HEK, we either need to explicitly unshare it the + * correct way, or actually free things here. + */ + I32 riter = 0; + const I32 max = HvMAX(PL_strtab); + HE * const * const array = HvARRAY(PL_strtab); + HE *hent = array[0]; + + for (;;) { + if (hent && ckWARN_d(WARN_INTERNAL)) { + HE * const next = HeNEXT(hent); + Perl_warner(aTHX_ packWARN(WARN_INTERNAL), + "Unbalanced string table refcount: (%ld) for \"%s\"", + (long)hent->he_valu.hent_refcount, HeKEY(hent)); + Safefree(hent); + hent = next; + } + if (!hent) { + if (++riter > max) + break; + hent = array[riter]; + } + } + + Safefree(array); + HvARRAY(PL_strtab) = 0; + HvTOTALKEYS(PL_strtab) = 0; } SvREFCNT_dec(PL_strtab); @@ -1379,62 +1379,62 @@ perl_destruct(pTHXx) } if (PL_sv_count != 0 && ckWARN_d(WARN_INTERNAL)) - Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Scalars leaked: %ld\n", (long)PL_sv_count); + Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Scalars leaked: %ld\n", (long)PL_sv_count); #ifdef DEBUG_LEAKING_SCALARS if (PL_sv_count != 0) { - SV* sva; - SV* sv; - SV* svend; - - for (sva = PL_sv_arenaroot; sva; sva = MUTABLE_SV(SvANY(sva))) { - svend = &sva[SvREFCNT(sva)]; - for (sv = sva + 1; sv < svend; ++sv) { - if (SvTYPE(sv) != (svtype)SVTYPEMASK) { - PerlIO_printf(Perl_debug_log, "leaked: sv=0x%p" - " flags=0x%" UVxf - " refcnt=%" UVuf pTHX__FORMAT "\n" - "\tallocated at %s:%d %s %s (parent 0x%" UVxf ");" - "serial %" UVuf "\n", - (void*)sv, (UV)sv->sv_flags, (UV)sv->sv_refcnt - pTHX__VALUE, - sv->sv_debug_file ? sv->sv_debug_file : "(unknown)", - sv->sv_debug_line, - sv->sv_debug_inpad ? "for" : "by", - sv->sv_debug_optype ? - PL_op_name[sv->sv_debug_optype]: "(none)", - PTR2UV(sv->sv_debug_parent), - sv->sv_debug_serial - ); + SV* sva; + SV* sv; + SV* svend; + + for (sva = PL_sv_arenaroot; sva; sva = MUTABLE_SV(SvANY(sva))) { + svend = &sva[SvREFCNT(sva)]; + for (sv = sva + 1; sv < svend; ++sv) { + if (SvTYPE(sv) != (svtype)SVTYPEMASK) { + PerlIO_printf(Perl_debug_log, "leaked: sv=0x%p" + " flags=0x%" UVxf + " refcnt=%" UVuf pTHX__FORMAT "\n" + "\tallocated at %s:%d %s %s (parent 0x%" UVxf ");" + "serial %" UVuf "\n", + (void*)sv, (UV)sv->sv_flags, (UV)sv->sv_refcnt + pTHX__VALUE, + sv->sv_debug_file ? sv->sv_debug_file : "(unknown)", + sv->sv_debug_line, + sv->sv_debug_inpad ? "for" : "by", + sv->sv_debug_optype ? + PL_op_name[sv->sv_debug_optype]: "(none)", + PTR2UV(sv->sv_debug_parent), + sv->sv_debug_serial + ); #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP - Perl_dump_sv_child(aTHX_ sv); + Perl_dump_sv_child(aTHX_ sv); #endif - } - } - } + } + } + } } #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP { - int status; - fd_set rset; - /* Wait for up to 4 seconds for child to terminate. - 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; + int status; + fd_set rset; + /* Wait for up to 4 seconds for child to terminate. + 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); - FD_SET(sock, &rset); - select(sock + 1, &rset, NULL, NULL, &waitfor); - waitpid(child, &status, WNOHANG); - close(sock); + shutdown(sock, 1); + FD_ZERO(&rset); + FD_SET(sock, &rset); + select(sock + 1, &rset, NULL, NULL, &waitfor); + waitpid(child, &status, WNOHANG); + close(sock); } #endif #endif #ifdef DEBUG_LEAKING_SCALARS_ABORT if (PL_sv_count) - abort(); + abort(); #endif PL_sv_count = 0; @@ -1459,11 +1459,11 @@ perl_destruct(pTHXx) PL_psig_name = (SV**)NULL; PL_psig_ptr = (SV**)NULL; { - /* We need to NULL PL_psig_pend first, so that - signal handlers know not to use it */ - int *psig_save = PL_psig_pend; - PL_psig_pend = (int*)NULL; - Safefree(psig_save); + /* We need to NULL PL_psig_pend first, so that + signal handlers know not to use it */ + int *psig_save = PL_psig_pend; + PL_psig_pend = (int*)NULL; + Safefree(psig_save); } nuke_stacks(); TAINTING_set(FALSE); @@ -1488,32 +1488,32 @@ perl_destruct(pTHXx) sv_free_arenas(); while (PL_regmatch_slab) { - regmatch_slab *s = PL_regmatch_slab; - PL_regmatch_slab = PL_regmatch_slab->next; - Safefree(s); + regmatch_slab *s = PL_regmatch_slab; + PL_regmatch_slab = PL_regmatch_slab->next; + Safefree(s); } /* As the absolutely last thing, free the non-arena SV for mess() */ if (PL_mess_sv) { - /* we know that type == SVt_PVMG */ - - /* it could have accumulated taint magic */ - MAGIC* mg; - MAGIC* moremagic; - for (mg = SvMAGIC(PL_mess_sv); mg; mg = moremagic) { - moremagic = mg->mg_moremagic; - if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global - && mg->mg_len >= 0) - Safefree(mg->mg_ptr); - Safefree(mg); - } - - /* we know that type >= SVt_PV */ - SvPV_free(PL_mess_sv); - Safefree(SvANY(PL_mess_sv)); - Safefree(PL_mess_sv); - PL_mess_sv = NULL; + /* we know that type == SVt_PVMG */ + + /* it could have accumulated taint magic */ + MAGIC* mg; + MAGIC* moremagic; + for (mg = SvMAGIC(PL_mess_sv); mg; mg = moremagic) { + moremagic = mg->mg_moremagic; + if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global + && mg->mg_len >= 0) + Safefree(mg->mg_ptr); + Safefree(mg); + } + + /* we know that type >= SVt_PV */ + SvPV_free(PL_mess_sv); + Safefree(SvANY(PL_mess_sv)); + Safefree(PL_mess_sv); + PL_mess_sv = NULL; } return STATUS_EXIT; } @@ -1533,30 +1533,30 @@ perl_free(pTHXx) PERL_ARGS_ASSERT_PERL_FREE; if (PL_veto_cleanup) - return; + return; #ifdef PERL_TRACK_MEMPOOL { - /* - * Don't free thread memory if PERL_DESTRUCT_LEVEL is set to a non-zero - * value as we're probably hunting memory leaks then - */ - if (PL_perl_destruct_level == 0) { - const U32 old_debug = PL_debug; - /* Emulate the PerlHost behaviour of free()ing all memory allocated in this - thread at thread exit. */ - if (DEBUG_m_TEST) { - PerlIO_puts(Perl_debug_log, "Disabling memory debugging as we " - "free this thread's memory\n"); - PL_debug &= ~ DEBUG_m_FLAG; - } - while(aTHXx->Imemory_debug_header.next != &(aTHXx->Imemory_debug_header)){ - char * next = (char *)(aTHXx->Imemory_debug_header.next); - Malloc_t ptr = PERL_MEMORY_DEBUG_HEADER_SIZE + next; - safesysfree(ptr); - } - PL_debug = old_debug; - } + /* + * Don't free thread memory if PERL_DESTRUCT_LEVEL is set to a non-zero + * value as we're probably hunting memory leaks then + */ + if (PL_perl_destruct_level == 0) { + const U32 old_debug = PL_debug; + /* Emulate the PerlHost behaviour of free()ing all memory allocated in this + thread at thread exit. */ + if (DEBUG_m_TEST) { + PerlIO_puts(Perl_debug_log, "Disabling memory debugging as we " + "free this thread's memory\n"); + PL_debug &= ~ DEBUG_m_FLAG; + } + while(aTHXx->Imemory_debug_header.next != &(aTHXx->Imemory_debug_header)){ + char * next = (char *)(aTHXx->Imemory_debug_header.next); + Malloc_t ptr = PERL_MEMORY_DEBUG_HEADER_SIZE + next; + safesysfree(ptr); + } + PL_debug = old_debug; + } } #endif @@ -1564,13 +1564,13 @@ perl_free(pTHXx) # if defined(PERL_IMPLICIT_SYS) { # ifdef NETWARE - void *host = nw_internal_host; - PerlMem_free(aTHXx); - nw_delete_internal_host(host); + void *host = nw_internal_host; + PerlMem_free(aTHXx); + nw_delete_internal_host(host); # else - void *host = w32_internal_host; - PerlMem_free(aTHXx); - win32_delete_internal_host(host); + void *host = w32_internal_host; + PerlMem_free(aTHXx); + win32_delete_internal_host(host); # endif } # else @@ -1599,7 +1599,7 @@ perl_fini(void) { if ( PL_curinterp && !PL_veto_cleanup) - FREE_THREAD_KEY; + FREE_THREAD_KEY; } #endif /* WIN32 */ @@ -1675,10 +1675,10 @@ bug is due to be fixed in Perl 5.30. */ #define SET_CURSTASH(newstash) \ - if (PL_curstash != newstash) { \ - SvREFCNT_dec(PL_curstash); \ - PL_curstash = (HV *)SvREFCNT_inc(newstash); \ - } + if (PL_curstash != newstash) { \ + SvREFCNT_dec(PL_curstash); \ + PL_curstash = (HV *)SvREFCNT_inc(newstash); \ + } int perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env) @@ -1715,129 +1715,129 @@ perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env) #ifdef __amigaos4__ { struct NameTranslationInfo nti; - __translate_amiga_to_unix_path_name(&argv[0],&nti); + __translate_amiga_to_unix_path_name(&argv[0],&nti); } #endif { - int i; - assert(argc >= 0); - for(i = 0; i != argc; i++) - assert(argv[i]); - assert(!argv[argc]); + int i; + assert(argc >= 0); + for(i = 0; i != argc; i++) + assert(argv[i]); + assert(!argv[argc]); } PL_origargc = argc; PL_origargv = argv; if (PL_origalen != 0) { - PL_origalen = 1; /* don't use old PL_origalen if perl_parse() is called again */ + PL_origalen = 1; /* don't use old PL_origalen if perl_parse() is called again */ } else { - /* Set PL_origalen be the sum of the contiguous argv[] - * elements plus the size of the env in case that it is - * contiguous with the argv[]. This is used in mg.c:Perl_magic_set() - * as the maximum modifiable length of $0. In the worst case - * the area we are able to modify is limited to the size of - * the original argv[0]. (See below for 'contiguous', though.) - * --jhi */ - const char *s = NULL; - const UV mask = ~(UV)(PTRSIZE-1); + /* Set PL_origalen be the sum of the contiguous argv[] + * elements plus the size of the env in case that it is + * contiguous with the argv[]. This is used in mg.c:Perl_magic_set() + * as the maximum modifiable length of $0. In the worst case + * the area we are able to modify is limited to the size of + * the original argv[0]. (See below for 'contiguous', though.) + * --jhi */ + const char *s = NULL; + const UV mask = ~(UV)(PTRSIZE-1); /* Do the mask check only if the args seem like aligned. */ - const UV aligned = - (mask < ~(UV)0) && ((PTR2UV(argv[0]) & mask) == PTR2UV(argv[0])); - - /* See if all the arguments are contiguous in memory. Note - * that 'contiguous' is a loose term because some platforms - * align the argv[] and the envp[]. If the arguments look - * like non-aligned, assume that they are 'strictly' or - * 'traditionally' contiguous. If the arguments look like - * aligned, we just check that they are within aligned - * PTRSIZE bytes. As long as no system has something bizarre - * like the argv[] interleaved with some other data, we are - * fine. (Did I just evoke Murphy's Law?) --jhi */ - if (PL_origargv && PL_origargc >= 1 && (s = PL_origargv[0])) { + const UV aligned = + (mask < ~(UV)0) && ((PTR2UV(argv[0]) & mask) == PTR2UV(argv[0])); + + /* See if all the arguments are contiguous in memory. Note + * that 'contiguous' is a loose term because some platforms + * align the argv[] and the envp[]. If the arguments look + * like non-aligned, assume that they are 'strictly' or + * 'traditionally' contiguous. If the arguments look like + * aligned, we just check that they are within aligned + * PTRSIZE bytes. As long as no system has something bizarre + * like the argv[] interleaved with some other data, we are + * fine. (Did I just evoke Murphy's Law?) --jhi */ + if (PL_origargv && PL_origargc >= 1 && (s = PL_origargv[0])) { int i; - while (*s) s++; - for (i = 1; i < PL_origargc; i++) { - if ((PL_origargv[i] == s + 1 + while (*s) s++; + for (i = 1; i < PL_origargc; i++) { + if ((PL_origargv[i] == s + 1 #ifdef OS2 - || PL_origargv[i] == s + 2 -#endif - ) - || - (aligned && - (PL_origargv[i] > s && - PL_origargv[i] <= - INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask))) - ) - { - s = PL_origargv[i]; - while (*s) s++; - } - else - break; - } - } + || PL_origargv[i] == s + 2 +#endif + ) + || + (aligned && + (PL_origargv[i] > s && + PL_origargv[i] <= + INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask))) + ) + { + s = PL_origargv[i]; + while (*s) s++; + } + else + break; + } + } #ifndef PERL_USE_SAFE_PUTENV - /* Can we grab env area too to be used as the area for $0? */ - if (s && PL_origenviron && !PL_use_safe_putenv) { - if ((PL_origenviron[0] == s + 1) - || - (aligned && - (PL_origenviron[0] > s && - PL_origenviron[0] <= - INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask))) - ) - { + /* Can we grab env area too to be used as the area for $0? */ + if (s && PL_origenviron && !PL_use_safe_putenv) { + if ((PL_origenviron[0] == s + 1) + || + (aligned && + (PL_origenviron[0] > s && + PL_origenviron[0] <= + INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask))) + ) + { int i; #ifndef OS2 /* ENVIRON is read by the kernel too. */ - s = PL_origenviron[0]; - while (*s) s++; -#endif - my_setenv("NoNe SuCh", NULL); - /* Force copy of environment. */ - for (i = 1; PL_origenviron[i]; i++) { - if (PL_origenviron[i] == s + 1 - || - (aligned && - (PL_origenviron[i] > s && - PL_origenviron[i] <= - INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask))) - ) - { - s = PL_origenviron[i]; - while (*s) s++; - } - else - break; - } - } - } + s = PL_origenviron[0]; + while (*s) s++; +#endif + my_setenv("NoNe SuCh", NULL); + /* Force copy of environment. */ + for (i = 1; PL_origenviron[i]; i++) { + if (PL_origenviron[i] == s + 1 + || + (aligned && + (PL_origenviron[i] > s && + PL_origenviron[i] <= + INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask))) + ) + { + s = PL_origenviron[i]; + while (*s) s++; + } + else + break; + } + } + } #endif /* !defined(PERL_USE_SAFE_PUTENV) */ - PL_origalen = s ? s - PL_origargv[0] + 1 : 0; + PL_origalen = s ? s - PL_origargv[0] + 1 : 0; } if (PL_do_undump) { - /* Come here if running an undumped a.out. */ + /* Come here if running an undumped a.out. */ - PL_origfilename = savepv(argv[0]); - PL_do_undump = FALSE; - cxstack_ix = -1; /* start label stack again */ - init_ids(); - assert (!TAINT_get); - TAINT; - set_caret_X(); - TAINT_NOT; - init_postdump_symbols(argc,argv,env); - return 0; + PL_origfilename = savepv(argv[0]); + PL_do_undump = FALSE; + cxstack_ix = -1; /* start label stack again */ + init_ids(); + assert (!TAINT_get); + TAINT; + set_caret_X(); + TAINT_NOT; + init_postdump_symbols(argc,argv,env); + return 0; } if (PL_main_root) { - op_free(PL_main_root); - PL_main_root = NULL; + op_free(PL_main_root); + PL_main_root = NULL; } PL_main_start = NULL; SvREFCNT_dec(PL_main_cv); @@ -1850,47 +1850,47 @@ perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env) JMPENV_PUSH(ret); switch (ret) { case 0: - parse_body(env,xsinit); - if (PL_unitcheckav) { - call_list(oldscope, PL_unitcheckav); - } - if (PL_checkav) { - PERL_SET_PHASE(PERL_PHASE_CHECK); - call_list(oldscope, PL_checkav); - } - ret = 0; - break; + parse_body(env,xsinit); + if (PL_unitcheckav) { + call_list(oldscope, PL_unitcheckav); + } + if (PL_checkav) { + PERL_SET_PHASE(PERL_PHASE_CHECK); + call_list(oldscope, PL_checkav); + } + ret = 0; + break; case 1: - STATUS_ALL_FAILURE; - /* FALLTHROUGH */ + STATUS_ALL_FAILURE; + /* FALLTHROUGH */ case 2: - /* my_exit() was called */ - while (PL_scopestack_ix > oldscope) - LEAVE; - FREETMPS; - SET_CURSTASH(PL_defstash); - if (PL_unitcheckav) { - call_list(oldscope, PL_unitcheckav); - } - if (PL_checkav) { - PERL_SET_PHASE(PERL_PHASE_CHECK); - call_list(oldscope, PL_checkav); - } - ret = STATUS_EXIT; - if (ret == 0) { - /* - * At this point we should do - * ret = 0x100; - * to avoid [perl #2754], but that bugfix has been postponed - * because of the Module::Install breakage it causes - * [perl #132577]. - */ - } - break; + /* my_exit() was called */ + while (PL_scopestack_ix > oldscope) + LEAVE; + FREETMPS; + SET_CURSTASH(PL_defstash); + if (PL_unitcheckav) { + call_list(oldscope, PL_unitcheckav); + } + if (PL_checkav) { + PERL_SET_PHASE(PERL_PHASE_CHECK); + call_list(oldscope, PL_checkav); + } + ret = STATUS_EXIT; + if (ret == 0) { + /* + * At this point we should do + * ret = 0x100; + * to avoid [perl #2754], but that bugfix has been postponed + * because of the Module::Install breakage it causes + * [perl #132577]. + */ + } + break; case 3: - PerlIO_printf(Perl_error_log, "panic: top_env\n"); - ret = 1; - break; + PerlIO_printf(Perl_error_log, "panic: top_env\n"); + ret = 1; + break; } JMPENV_POP; return ret; @@ -1912,125 +1912,125 @@ S_Internals_V(pTHX_ CV *cv) #endif const int entries = 3 + local_patch_count; int i; - static const char non_bincompat_options[] = + static const char non_bincompat_options[] = # ifdef DEBUGGING - " DEBUGGING" + " DEBUGGING" # endif # ifdef NO_MATHOMS - " NO_MATHOMS" + " NO_MATHOMS" # endif # ifdef NO_HASH_SEED - " NO_HASH_SEED" + " NO_HASH_SEED" # endif # ifdef NO_TAINT_SUPPORT - " NO_TAINT_SUPPORT" + " NO_TAINT_SUPPORT" # endif # ifdef PERL_BOOL_AS_CHAR - " PERL_BOOL_AS_CHAR" + " PERL_BOOL_AS_CHAR" # endif # ifdef PERL_COPY_ON_WRITE - " PERL_COPY_ON_WRITE" + " PERL_COPY_ON_WRITE" # endif # ifdef PERL_DISABLE_PMC - " PERL_DISABLE_PMC" + " PERL_DISABLE_PMC" # endif # ifdef PERL_DONT_CREATE_GVSV - " PERL_DONT_CREATE_GVSV" + " PERL_DONT_CREATE_GVSV" # endif # ifdef PERL_EXTERNAL_GLOB - " PERL_EXTERNAL_GLOB" + " PERL_EXTERNAL_GLOB" # endif # ifdef PERL_HASH_FUNC_SIPHASH - " PERL_HASH_FUNC_SIPHASH" + " PERL_HASH_FUNC_SIPHASH" # endif # ifdef PERL_HASH_FUNC_SDBM - " PERL_HASH_FUNC_SDBM" + " PERL_HASH_FUNC_SDBM" # endif # ifdef PERL_HASH_FUNC_DJB2 - " PERL_HASH_FUNC_DJB2" + " PERL_HASH_FUNC_DJB2" # endif # ifdef PERL_HASH_FUNC_SUPERFAST - " PERL_HASH_FUNC_SUPERFAST" + " PERL_HASH_FUNC_SUPERFAST" # endif # ifdef PERL_HASH_FUNC_MURMUR3 - " PERL_HASH_FUNC_MURMUR3" + " PERL_HASH_FUNC_MURMUR3" # endif # ifdef PERL_HASH_FUNC_ONE_AT_A_TIME - " PERL_HASH_FUNC_ONE_AT_A_TIME" + " PERL_HASH_FUNC_ONE_AT_A_TIME" # endif # ifdef PERL_HASH_FUNC_ONE_AT_A_TIME_HARD - " PERL_HASH_FUNC_ONE_AT_A_TIME_HARD" + " PERL_HASH_FUNC_ONE_AT_A_TIME_HARD" # endif # ifdef PERL_HASH_FUNC_ONE_AT_A_TIME_OLD - " PERL_HASH_FUNC_ONE_AT_A_TIME_OLD" + " PERL_HASH_FUNC_ONE_AT_A_TIME_OLD" # endif # ifdef PERL_IS_MINIPERL - " PERL_IS_MINIPERL" + " PERL_IS_MINIPERL" # endif # ifdef PERL_MALLOC_WRAP - " PERL_MALLOC_WRAP" + " PERL_MALLOC_WRAP" # endif # ifdef PERL_MEM_LOG - " PERL_MEM_LOG" + " PERL_MEM_LOG" # endif # ifdef PERL_MEM_LOG_NOIMPL - " PERL_MEM_LOG_NOIMPL" + " PERL_MEM_LOG_NOIMPL" # endif # ifdef PERL_OP_PARENT - " PERL_OP_PARENT" + " PERL_OP_PARENT" # endif # ifdef PERL_PERTURB_KEYS_DETERMINISTIC - " PERL_PERTURB_KEYS_DETERMINISTIC" + " PERL_PERTURB_KEYS_DETERMINISTIC" # endif # ifdef PERL_PERTURB_KEYS_DISABLED - " PERL_PERTURB_KEYS_DISABLED" + " PERL_PERTURB_KEYS_DISABLED" # endif # ifdef PERL_PERTURB_KEYS_RANDOM - " PERL_PERTURB_KEYS_RANDOM" + " PERL_PERTURB_KEYS_RANDOM" # endif # ifdef PERL_PRESERVE_IVUV - " PERL_PRESERVE_IVUV" + " PERL_PRESERVE_IVUV" # endif # ifdef PERL_RELOCATABLE_INCPUSH - " PERL_RELOCATABLE_INCPUSH" + " PERL_RELOCATABLE_INCPUSH" # endif # ifdef PERL_USE_DEVEL - " PERL_USE_DEVEL" + " PERL_USE_DEVEL" # endif # ifdef PERL_USE_SAFE_PUTENV - " PERL_USE_SAFE_PUTENV" + " PERL_USE_SAFE_PUTENV" # endif # ifdef SILENT_NO_TAINT_SUPPORT - " SILENT_NO_TAINT_SUPPORT" + " SILENT_NO_TAINT_SUPPORT" # endif # ifdef UNLINK_ALL_VERSIONS - " UNLINK_ALL_VERSIONS" + " UNLINK_ALL_VERSIONS" # endif # ifdef USE_ATTRIBUTES_FOR_PERLIO - " USE_ATTRIBUTES_FOR_PERLIO" + " USE_ATTRIBUTES_FOR_PERLIO" # endif # ifdef USE_FAST_STDIO - " USE_FAST_STDIO" -# endif + " USE_FAST_STDIO" +# endif # ifdef USE_LOCALE - " USE_LOCALE" + " USE_LOCALE" # endif # ifdef USE_LOCALE_CTYPE - " USE_LOCALE_CTYPE" + " USE_LOCALE_CTYPE" # endif # ifdef WIN32_NO_REGISTRY - " USE_NO_REGISTRY" + " USE_NO_REGISTRY" # endif # ifdef USE_PERL_ATOF - " USE_PERL_ATOF" -# endif + " USE_PERL_ATOF" +# endif # ifdef USE_SITECUSTOMIZE - " USE_SITECUSTOMIZE" -# endif + " USE_SITECUSTOMIZE" +# endif # ifdef USE_THREAD_SAFE_LOCALE - " USE_THREAD_SAFE_LOCALE" + " USE_THREAD_SAFE_LOCALE" # endif - ; + ; PERL_UNUSED_ARG(cv); PERL_UNUSED_VAR(items); @@ -2038,7 +2038,7 @@ S_Internals_V(pTHX_ CV *cv) PUSHs(sv_2mortal(newSVpv(PL_bincompat_options, 0))); PUSHs(Perl_newSVpvn_flags(aTHX_ non_bincompat_options, - sizeof(non_bincompat_options) - 1, SVs_TEMP)); + sizeof(non_bincompat_options) - 1, SVs_TEMP)); #ifndef PERL_BUILD_DATE # ifdef __DATE__ @@ -2052,15 +2052,15 @@ S_Internals_V(pTHX_ CV *cv) #ifdef PERL_BUILD_DATE PUSHs(Perl_newSVpvn_flags(aTHX_ - STR_WITH_LEN("Compiled at " PERL_BUILD_DATE), - SVs_TEMP)); + STR_WITH_LEN("Compiled at " PERL_BUILD_DATE), + SVs_TEMP)); #else PUSHs(&PL_sv_undef); #endif for (i = 1; i <= local_patch_count; i++) { - /* This will be an undef, if PL_localpatches[i] is NULL. */ - PUSHs(sv_2mortal(newSVpv(PL_localpatches[i], 0))); + /* This will be an undef, if PL_localpatches[i] is NULL. */ + PUSHs(sv_2mortal(newSVpv(PL_localpatches[i], 0))); } XSRETURN(entries); @@ -2099,231 +2099,231 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) init_main_stash(); { - const char *s; + const char *s; for (argc--,argv++; argc > 0; argc--,argv++) { - if (argv[0][0] != '-' || !argv[0][1]) - break; - s = argv[0]+1; + if (argv[0][0] != '-' || !argv[0][1]) + break; + s = argv[0]+1; reswitch: - switch ((c = *s)) { - case 'C': + switch ((c = *s)) { + case 'C': #ifndef PERL_STRICT_CR - case '\r': -#endif - case ' ': - case '0': - case 'F': - case 'a': - case 'c': - case 'd': - case 'D': - case 'h': - case 'i': - case 'l': - case 'M': - case 'm': - case 'n': - case 'p': - case 's': - case 'u': - case 'U': - case 'v': - case 'W': - case 'X': - case 'w': - if ((s = moreswitches(s))) - goto reswitch; - break; - - case 't': + case '\r': +#endif + case ' ': + case '0': + case 'F': + case 'a': + case 'c': + case 'd': + case 'D': + case 'h': + case 'i': + case 'l': + case 'M': + case 'm': + case 'n': + case 'p': + case 's': + case 'u': + case 'U': + case 'v': + case 'W': + case 'X': + case 'w': + if ((s = moreswitches(s))) + goto reswitch; + break; + + case 't': #if defined(SILENT_NO_TAINT_SUPPORT) /* silently ignore */ #elif defined(NO_TAINT_SUPPORT) Perl_croak_nocontext("This perl was compiled without taint support. " "Cowardly refusing to run with -t or -T flags"); #else - CHECK_MALLOC_TOO_LATE_FOR('t'); - if( !TAINTING_get ) { - TAINT_WARN_set(TRUE); - TAINTING_set(TRUE); - } -#endif - s++; - goto reswitch; - case 'T': + CHECK_MALLOC_TOO_LATE_FOR('t'); + if( !TAINTING_get ) { + TAINT_WARN_set(TRUE); + TAINTING_set(TRUE); + } +#endif + s++; + goto reswitch; + case 'T': #if defined(SILENT_NO_TAINT_SUPPORT) /* silently ignore */ #elif defined(NO_TAINT_SUPPORT) Perl_croak_nocontext("This perl was compiled without taint support. " "Cowardly refusing to run with -t or -T flags"); #else - CHECK_MALLOC_TOO_LATE_FOR('T'); - TAINTING_set(TRUE); - TAINT_WARN_set(FALSE); -#endif - s++; - goto reswitch; - - case 'E': - PL_minus_E = TRUE; - /* FALLTHROUGH */ - case 'e': - forbid_setid('e', FALSE); + CHECK_MALLOC_TOO_LATE_FOR('T'); + TAINTING_set(TRUE); + TAINT_WARN_set(FALSE); +#endif + s++; + goto reswitch; + + case 'E': + PL_minus_E = TRUE; + /* FALLTHROUGH */ + case 'e': + forbid_setid('e', FALSE); minus_e = TRUE; - if (!PL_e_script) { - PL_e_script = newSVpvs(""); - add_read_e_script = TRUE; - } - if (*++s) - sv_catpv(PL_e_script, s); - else if (argv[1]) { - sv_catpv(PL_e_script, argv[1]); - argc--,argv++; - } - else - Perl_croak(aTHX_ "No code specified for -%c", c); - sv_catpvs(PL_e_script, "\n"); - break; - - case 'f': + if (!PL_e_script) { + PL_e_script = newSVpvs(""); + add_read_e_script = TRUE; + } + if (*++s) + sv_catpv(PL_e_script, s); + else if (argv[1]) { + sv_catpv(PL_e_script, argv[1]); + argc--,argv++; + } + else + Perl_croak(aTHX_ "No code specified for -%c", c); + sv_catpvs(PL_e_script, "\n"); + break; + + case 'f': #ifdef USE_SITECUSTOMIZE - minus_f = TRUE; -#endif - s++; - goto reswitch; - - case 'I': /* -I handled both here and in moreswitches() */ - forbid_setid('I', FALSE); - if (!*++s && (s=argv[1]) != NULL) { - argc--,argv++; - } - if (s && *s) { - STRLEN len = strlen(s); - incpush(s, len, INCPUSH_ADD_SUB_DIRS|INCPUSH_ADD_OLD_VERS); - } - else - Perl_croak(aTHX_ "No directory specified for -I"); - break; - case 'S': - forbid_setid('S', FALSE); - dosearch = TRUE; - s++; - goto reswitch; - case 'V': - { - SV *opts_prog; - - if (*++s != ':') { - opts_prog = newSVpvs("use Config; Config::_V()"); - } - else { - ++s; - opts_prog = Perl_newSVpvf(aTHX_ - "use Config; Config::config_vars(qw%c%s%c)", - 0, s, 0); - s += strlen(s); - } - Perl_av_create_and_push(aTHX_ &PL_preambleav, opts_prog); - /* don't look for script or read stdin */ - scriptname = BIT_BUCKET; - goto reswitch; - } - case 'x': - doextract = TRUE; - s++; - if (*s) - cddir = s; - break; - case 0: - break; - case '-': - if (!*++s || isSPACE(*s)) { - argc--,argv++; - goto switch_end; - } - /* catch use of gnu style long options. - Both of these exit immediately. */ - if (strEQ(s, "version")) - minus_v(); - if (strEQ(s, "help")) - usage(); - s--; - /* FALLTHROUGH */ - default: - Perl_croak(aTHX_ "Unrecognized switch: -%s (-h will show valid options)",s); - } + minus_f = TRUE; +#endif + s++; + goto reswitch; + + case 'I': /* -I handled both here and in moreswitches() */ + forbid_setid('I', FALSE); + if (!*++s && (s=argv[1]) != NULL) { + argc--,argv++; + } + if (s && *s) { + STRLEN len = strlen(s); + incpush(s, len, INCPUSH_ADD_SUB_DIRS|INCPUSH_ADD_OLD_VERS); + } + else + Perl_croak(aTHX_ "No directory specified for -I"); + break; + case 'S': + forbid_setid('S', FALSE); + dosearch = TRUE; + s++; + goto reswitch; + case 'V': + { + SV *opts_prog; + + if (*++s != ':') { + opts_prog = newSVpvs("use Config; Config::_V()"); + } + else { + ++s; + opts_prog = Perl_newSVpvf(aTHX_ + "use Config; Config::config_vars(qw%c%s%c)", + 0, s, 0); + s += strlen(s); + } + Perl_av_create_and_push(aTHX_ &PL_preambleav, opts_prog); + /* don't look for script or read stdin */ + scriptname = BIT_BUCKET; + goto reswitch; + } + case 'x': + doextract = TRUE; + s++; + if (*s) + cddir = s; + break; + case 0: + break; + case '-': + if (!*++s || isSPACE(*s)) { + argc--,argv++; + goto switch_end; + } + /* catch use of gnu style long options. + Both of these exit immediately. */ + if (strEQ(s, "version")) + minus_v(); + if (strEQ(s, "help")) + usage(); + s--; + /* FALLTHROUGH */ + default: + Perl_croak(aTHX_ "Unrecognized switch: -%s (-h will show valid options)",s); + } } } switch_end: { - char *s; + char *s; if ( #ifndef SECURE_INTERNAL_GETENV !TAINTING_get && #endif - (s = PerlEnv_getenv("PERL5OPT"))) + (s = PerlEnv_getenv("PERL5OPT"))) { - while (isSPACE(*s)) - s++; - if (*s == '-' && *(s+1) == 'T') { + while (isSPACE(*s)) + s++; + if (*s == '-' && *(s+1) == 'T') { #if defined(SILENT_NO_TAINT_SUPPORT) /* silently ignore */ #elif defined(NO_TAINT_SUPPORT) Perl_croak_nocontext("This perl was compiled without taint support. " "Cowardly refusing to run with -t or -T flags"); #else - CHECK_MALLOC_TOO_LATE_FOR('T'); - TAINTING_set(TRUE); + CHECK_MALLOC_TOO_LATE_FOR('T'); + TAINTING_set(TRUE); TAINT_WARN_set(FALSE); #endif - } - else { - char *popt_copy = NULL; - while (s && *s) { - const char *d; - while (isSPACE(*s)) - s++; - if (*s == '-') { - s++; - if (isSPACE(*s)) - continue; - } - d = s; - if (!*s) - break; - if (!memCHRs("CDIMUdmtwW", *s)) - Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s); - while (++s && *s) { - if (isSPACE(*s)) { - if (!popt_copy) { - popt_copy = SvPVX(sv_2mortal(newSVpv(d,0))); - s = popt_copy + (s - d); - d = popt_copy; - } - *s++ = '\0'; - break; - } - } - if (*d == 't') { + } + else { + char *popt_copy = NULL; + while (s && *s) { + const char *d; + while (isSPACE(*s)) + s++; + if (*s == '-') { + s++; + if (isSPACE(*s)) + continue; + } + d = s; + if (!*s) + break; + if (!memCHRs("CDIMUdmtwW", *s)) + Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s); + while (++s && *s) { + if (isSPACE(*s)) { + if (!popt_copy) { + popt_copy = SvPVX(sv_2mortal(newSVpv(d,0))); + s = popt_copy + (s - d); + d = popt_copy; + } + *s++ = '\0'; + break; + } + } + if (*d == 't') { #if defined(SILENT_NO_TAINT_SUPPORT) /* silently ignore */ #elif defined(NO_TAINT_SUPPORT) Perl_croak_nocontext("This perl was compiled without taint support. " "Cowardly refusing to run with -t or -T flags"); #else - if( !TAINTING_get) { - TAINT_WARN_set(TRUE); - TAINTING_set(TRUE); - } -#endif - } else { - moreswitches(d); - } - } - } + if( !TAINTING_get) { + TAINT_WARN_set(TRUE); + TAINTING_set(TRUE); + } +#endif + } else { + moreswitches(d); + } + } + } } } @@ -2351,101 +2351,101 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) #if defined(USE_SITECUSTOMIZE) if (!minus_f) { - /* The games with local $! are to avoid setting errno if there is no - sitecustomize script. "q%c...%c", 0, ..., 0 becomes "q\0...\0", - ie a q() operator with a NUL byte as a the delimiter. This avoids - problems with pathnames containing (say) ' */ + /* The games with local $! are to avoid setting errno if there is no + sitecustomize script. "q%c...%c", 0, ..., 0 becomes "q\0...\0", + ie a q() operator with a NUL byte as a the delimiter. This avoids + problems with pathnames containing (say) ' */ # ifdef PERL_IS_MINIPERL - AV *const inc = GvAV(PL_incgv); - SV **const inc0 = inc ? av_fetch(inc, 0, FALSE) : NULL; + AV *const inc = GvAV(PL_incgv); + SV **const inc0 = inc ? av_fetch(inc, 0, FALSE) : NULL; - if (inc0) { + if (inc0) { /* if lib/buildcustomize.pl exists, it should not fail. If it does, it should be reported immediately as a build failure. */ - (void)Perl_av_create_and_unshift_one(aTHX_ &PL_preambleav, - Perl_newSVpvf(aTHX_ - "BEGIN { my $f = q%c%s%" SVf "/buildcustomize.pl%c; " - "do {local $!; -f $f }" - " and do $f || die $@ || qq '$f: $!' }", + (void)Perl_av_create_and_unshift_one(aTHX_ &PL_preambleav, + Perl_newSVpvf(aTHX_ + "BEGIN { my $f = q%c%s%" SVf "/buildcustomize.pl%c; " + "do {local $!; -f $f }" + " and do $f || die $@ || qq '$f: $!' }", 0, (TAINTING_get ? "./" : ""), SVfARG(*inc0), 0)); - } + } # else - /* SITELIB_EXP is a function call on Win32. */ - const char *const raw_sitelib = SITELIB_EXP; - if (raw_sitelib) { - /* process .../.. if PERL_RELOCATABLE_INC is defined */ - SV *sitelib_sv = mayberelocate(raw_sitelib, strlen(raw_sitelib), - INCPUSH_CAN_RELOCATE); - const char *const sitelib = SvPVX(sitelib_sv); - (void)Perl_av_create_and_unshift_one(aTHX_ &PL_preambleav, - Perl_newSVpvf(aTHX_ - "BEGIN { do {local $!; -f q%c%s/sitecustomize.pl%c} && do q%c%s/sitecustomize.pl%c }", - 0, sitelib, 0, - 0, sitelib, 0)); - assert (SvREFCNT(sitelib_sv) == 1); - SvREFCNT_dec(sitelib_sv); - } + /* SITELIB_EXP is a function call on Win32. */ + const char *const raw_sitelib = SITELIB_EXP; + if (raw_sitelib) { + /* process .../.. if PERL_RELOCATABLE_INC is defined */ + SV *sitelib_sv = mayberelocate(raw_sitelib, strlen(raw_sitelib), + INCPUSH_CAN_RELOCATE); + const char *const sitelib = SvPVX(sitelib_sv); + (void)Perl_av_create_and_unshift_one(aTHX_ &PL_preambleav, + Perl_newSVpvf(aTHX_ + "BEGIN { do {local $!; -f q%c%s/sitecustomize.pl%c} && do q%c%s/sitecustomize.pl%c }", + 0, sitelib, 0, + 0, sitelib, 0)); + assert (SvREFCNT(sitelib_sv) == 1); + SvREFCNT_dec(sitelib_sv); + } # endif } #endif if (!scriptname) - scriptname = argv[0]; + scriptname = argv[0]; if (PL_e_script) { - argc++,argv--; - scriptname = BIT_BUCKET; /* don't look for script or read stdin */ + argc++,argv--; + scriptname = BIT_BUCKET; /* don't look for script or read stdin */ } else if (scriptname == NULL) { #ifdef MSDOS - if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) ) - moreswitches("h"); + if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) ) + moreswitches("h"); #endif - scriptname = "-"; + scriptname = "-"; } assert (!TAINT_get); init_perllib(); { - bool suidscript = FALSE; + bool suidscript = FALSE; - rsfp = open_script(scriptname, dosearch, &suidscript); - if (!rsfp) { - rsfp = PerlIO_stdin(); - lex_start_flags = LEX_DONT_CLOSE_RSFP; - } + rsfp = open_script(scriptname, dosearch, &suidscript); + if (!rsfp) { + rsfp = PerlIO_stdin(); + lex_start_flags = LEX_DONT_CLOSE_RSFP; + } - validate_suid(rsfp); + validate_suid(rsfp); #ifndef PERL_MICRO # if defined(SIGCHLD) || defined(SIGCLD) - { + { # ifndef SIGCHLD # define SIGCHLD SIGCLD # endif - Sighandler_t sigstate = rsignal_state(SIGCHLD); - if (sigstate == (Sighandler_t) SIG_IGN) { - Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), - "Can't ignore signal CHLD, forcing to default"); - (void)rsignal(SIGCHLD, (Sighandler_t)SIG_DFL); - } - } + Sighandler_t sigstate = rsignal_state(SIGCHLD); + if (sigstate == (Sighandler_t) SIG_IGN) { + Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), + "Can't ignore signal CHLD, forcing to default"); + (void)rsignal(SIGCHLD, (Sighandler_t)SIG_DFL); + } + } # endif #endif - if (doextract) { + if (doextract) { - /* This will croak if suidscript is true, as -x cannot be used with - setuid scripts. */ - forbid_setid('x', suidscript); - /* Hence you can't get here if suidscript is true */ + /* This will croak if suidscript is true, as -x cannot be used with + setuid scripts. */ + forbid_setid('x', suidscript); + /* Hence you can't get here if suidscript is true */ - linestr_sv = newSV_type(SVt_PV); - lex_start_flags |= LEX_START_COPIED; - find_beginning(linestr_sv, rsfp); - if (cddir && PerlDir_chdir( (char *)cddir ) < 0) - Perl_croak(aTHX_ "Can't chdir to %s",cddir); - } + linestr_sv = newSV_type(SVt_PV); + lex_start_flags |= LEX_START_COPIED; + find_beginning(linestr_sv, rsfp); + if (cddir && PerlDir_chdir( (char *)cddir ) < 0) + Perl_croak(aTHX_ "Can't chdir to %s",cddir); + } } PL_main_cv = PL_compcv = MUTABLE_CV(newSV_type(SVt_PVCV)); @@ -2461,7 +2461,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) newXS("Internals::V", S_Internals_V, __FILE__); if (xsinit) - (*xsinit)(aTHX); /* in case linked C routines want magical variables */ + (*xsinit)(aTHX); /* in case linked C routines want magical variables */ #ifndef PERL_MICRO #if defined(VMS) || defined(WIN32) || defined(DJGPP) || defined(__CYGWIN__) init_os_extras(); @@ -2481,7 +2481,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) /* more than once (ENV isn't cleared first, for example) */ /* But running with -u leaves %ENV & @ARGV undefined! XXX */ if (!PL_do_undump) - init_postdump_symbols(argc,argv,env); + init_postdump_symbols(argc,argv,env); /* PL_unicode is turned on by -C, or by $ENV{PERL_UNICODE}, * or explicitly in some platforms. @@ -2490,54 +2490,54 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) * look like the user wants to use UTF-8. */ # ifndef PERL_IS_MINIPERL if (PL_unicode) { - /* Requires init_predump_symbols(). */ - if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) { - IO* io; - PerlIO* fp; - SV* sv; - - /* Turn on UTF-8-ness on STDIN, STDOUT, STDERR - * and the default open disciplines. */ - if ((PL_unicode & PERL_UNICODE_STDIN_FLAG) && - PL_stdingv && (io = GvIO(PL_stdingv)) && - (fp = IoIFP(io))) - PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8"); - if ((PL_unicode & PERL_UNICODE_STDOUT_FLAG) && - PL_defoutgv && (io = GvIO(PL_defoutgv)) && - (fp = IoOFP(io))) - PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8"); - if ((PL_unicode & PERL_UNICODE_STDERR_FLAG) && - PL_stderrgv && (io = GvIO(PL_stderrgv)) && - (fp = IoOFP(io))) - PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8"); - if ((PL_unicode & PERL_UNICODE_INOUT_FLAG) && - (sv = GvSV(gv_fetchpvs("\017PEN", GV_ADD|GV_NOTQUAL, - SVt_PV)))) { - U32 in = PL_unicode & PERL_UNICODE_IN_FLAG; - U32 out = PL_unicode & PERL_UNICODE_OUT_FLAG; - if (in) { - if (out) - sv_setpvs(sv, ":utf8\0:utf8"); - else - sv_setpvs(sv, ":utf8\0"); - } - else if (out) - sv_setpvs(sv, "\0:utf8"); - SvSETMAGIC(sv); - } - } + /* Requires init_predump_symbols(). */ + if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) { + IO* io; + PerlIO* fp; + SV* sv; + + /* Turn on UTF-8-ness on STDIN, STDOUT, STDERR + * and the default open disciplines. */ + if ((PL_unicode & PERL_UNICODE_STDIN_FLAG) && + PL_stdingv && (io = GvIO(PL_stdingv)) && + (fp = IoIFP(io))) + PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8"); + if ((PL_unicode & PERL_UNICODE_STDOUT_FLAG) && + PL_defoutgv && (io = GvIO(PL_defoutgv)) && + (fp = IoOFP(io))) + PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8"); + if ((PL_unicode & PERL_UNICODE_STDERR_FLAG) && + PL_stderrgv && (io = GvIO(PL_stderrgv)) && + (fp = IoOFP(io))) + PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8"); + if ((PL_unicode & PERL_UNICODE_INOUT_FLAG) && + (sv = GvSV(gv_fetchpvs("\017PEN", GV_ADD|GV_NOTQUAL, + SVt_PV)))) { + U32 in = PL_unicode & PERL_UNICODE_IN_FLAG; + U32 out = PL_unicode & PERL_UNICODE_OUT_FLAG; + if (in) { + if (out) + sv_setpvs(sv, ":utf8\0:utf8"); + else + sv_setpvs(sv, ":utf8\0"); + } + else if (out) + sv_setpvs(sv, "\0:utf8"); + SvSETMAGIC(sv); + } + } } #endif { - const char *s; + const char *s; if ((s = PerlEnv_getenv("PERL_SIGNALS"))) { - if (strEQ(s, "unsafe")) - PL_signals |= PERL_SIGNALS_UNSAFE_FLAG; - else if (strEQ(s, "safe")) - PL_signals &= ~PERL_SIGNALS_UNSAFE_FLAG; - else - Perl_croak(aTHX_ "PERL_SIGNALS illegal: \"%s\"", s); + if (strEQ(s, "unsafe")) + PL_signals |= PERL_SIGNALS_UNSAFE_FLAG; + else if (strEQ(s, "safe")) + PL_signals &= ~PERL_SIGNALS_UNSAFE_FLAG; + else + Perl_croak(aTHX_ "PERL_SIGNALS illegal: \"%s\"", s); } } @@ -2548,7 +2548,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) PL_subname = newSVpvs("main"); if (add_read_e_script) - filter_add(read_e_script, NULL); + filter_add(read_e_script, NULL); /* now parse the script */ if (minus_e == FALSE) @@ -2561,17 +2561,17 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) CopLINE_set(PL_curcop, 0); SET_CURSTASH(PL_defstash); if (PL_e_script) { - SvREFCNT_dec(PL_e_script); - PL_e_script = NULL; + SvREFCNT_dec(PL_e_script); + PL_e_script = NULL; } if (PL_do_undump) - my_unexec(); + my_unexec(); if (isWARN_ONCE) { - SAVECOPFILE(PL_curcop); - SAVECOPLINE(PL_curcop); - gv_check(PL_defstash); + SAVECOPFILE(PL_curcop); + SAVECOPLINE(PL_curcop); + gv_check(PL_defstash); } LEAVE; @@ -2579,7 +2579,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) #ifdef MYMALLOC { - const char *s; + const char *s; UV uv; s = PerlEnv_getenv("PERL_DEBUG_MSTATS"); if (s && grok_atoUV(s, &uv, NULL) && uv >= 2) @@ -2659,37 +2659,37 @@ perl_run(pTHXx) JMPENV_PUSH(ret); switch (ret) { case 1: - cxstack_ix = -1; /* start context stack again */ - goto redo_body; + cxstack_ix = -1; /* start context stack again */ + goto redo_body; case 0: /* normal completion */ redo_body: - run_body(oldscope); - /* FALLTHROUGH */ + run_body(oldscope); + /* FALLTHROUGH */ case 2: /* my_exit() */ - while (PL_scopestack_ix > oldscope) - LEAVE; - FREETMPS; - SET_CURSTASH(PL_defstash); - if (!(PL_exit_flags & PERL_EXIT_DESTRUCT_END) && - PL_endav && !PL_minus_c) { - PERL_SET_PHASE(PERL_PHASE_END); - call_list(oldscope, PL_endav); - } + while (PL_scopestack_ix > oldscope) + LEAVE; + FREETMPS; + SET_CURSTASH(PL_defstash); + if (!(PL_exit_flags & PERL_EXIT_DESTRUCT_END) && + PL_endav && !PL_minus_c) { + PERL_SET_PHASE(PERL_PHASE_END); + call_list(oldscope, PL_endav); + } #ifdef MYMALLOC - if (PerlEnv_getenv("PERL_DEBUG_MSTATS")) - dump_mstats("after execution: "); + if (PerlEnv_getenv("PERL_DEBUG_MSTATS")) + dump_mstats("after execution: "); #endif - ret = STATUS_EXIT; - break; + ret = STATUS_EXIT; + break; case 3: - if (PL_restartop) { - POPSTACK_TO(PL_mainstack); - goto redo_body; - } - PerlIO_printf(Perl_error_log, "panic: restartop in perl_run\n"); - FREETMPS; - ret = 1; - break; + if (PL_restartop) { + POPSTACK_TO(PL_mainstack); + goto redo_body; + } + PerlIO_printf(Perl_error_log, "panic: restartop in perl_run\n"); + FREETMPS; + ret = 1; + break; } JMPENV_POP; @@ -2705,25 +2705,25 @@ S_run_body(pTHX_ I32 oldscope) if (!PL_restartop) { #ifdef DEBUGGING - if (DEBUG_x_TEST || DEBUG_B_TEST) - dump_all_perl(!DEBUG_B_TEST); - if (!DEBUG_q_TEST) - PERL_DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n")); + if (DEBUG_x_TEST || DEBUG_B_TEST) + dump_all_perl(!DEBUG_B_TEST); + if (!DEBUG_q_TEST) + PERL_DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n")); #endif - if (PL_minus_c) { - PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename); - my_exit(0); - } - if (PERLDB_SINGLE && PL_DBsingle) + if (PL_minus_c) { + PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename); + my_exit(0); + } + if (PERLDB_SINGLE && PL_DBsingle) PL_DBsingle_iv = 1; - if (PL_initav) { - PERL_SET_PHASE(PERL_PHASE_INIT); - call_list(oldscope, PL_initav); - } + if (PL_initav) { + PERL_SET_PHASE(PERL_PHASE_INIT); + call_list(oldscope, PL_initav); + } #ifdef PERL_DEBUG_READONLY_OPS - if (PL_main_root && PL_main_root->op_slabbed) - Slab_to_ro(OpSLAB(PL_main_root)); + if (PL_main_root && PL_main_root->op_slabbed) + Slab_to_ro(OpSLAB(PL_main_root)); #endif } @@ -2732,15 +2732,15 @@ S_run_body(pTHX_ I32 oldscope) PERL_SET_PHASE(PERL_PHASE_RUN); if (PL_restartop) { - PL_restartjmpenv = NULL; - PL_op = PL_restartop; - PL_restartop = 0; - CALLRUNOPS(aTHX); + PL_restartjmpenv = NULL; + PL_op = PL_restartop; + PL_restartop = 0; + CALLRUNOPS(aTHX); } else if (PL_main_start) { - CvDEPTH(PL_main_cv) = 1; - PL_op = PL_main_start; - CALLRUNOPS(aTHX); + CvDEPTH(PL_main_cv) = 1; + PL_op = PL_main_start; + CALLRUNOPS(aTHX); } my_exit(0); NOT_REACHED; /* NOTREACHED */ @@ -2768,7 +2768,7 @@ Perl_get_sv(pTHX_ const char *name, I32 flags) gv = gv_fetchpv(name, flags, SVt_PV); if (gv) - return GvSV(gv); + return GvSV(gv); return NULL; } @@ -2778,7 +2778,7 @@ Perl_get_sv(pTHX_ const char *name, I32 flags) =for apidoc get_av Returns the AV of the specified Perl global or package array with the given -name (so it won't work on lexical variables). C<flags> are passed +name (so it won't work on lexical variables). C<flags> are passed to C<gv_fetchpv>. If C<GV_ADD> is set and the Perl variable does not exist then it will be created. If C<flags> is zero and the variable does not exist then NULL is returned. @@ -2796,9 +2796,9 @@ Perl_get_av(pTHX_ const char *name, I32 flags) PERL_ARGS_ASSERT_GET_AV; if (flags) - return GvAVn(gv); + return GvAVn(gv); if (gv) - return GvAV(gv); + return GvAV(gv); return NULL; } @@ -2823,9 +2823,9 @@ Perl_get_hv(pTHX_ const char *name, I32 flags) PERL_ARGS_ASSERT_GET_HV; if (flags) - return GvHVn(gv); + return GvHVn(gv); if (gv) - return GvHV(gv); + return GvHV(gv); return NULL; } @@ -2862,16 +2862,16 @@ Perl_get_cvn_flags(pTHX_ const char *name, STRLEN len, I32 flags) PERL_ARGS_ASSERT_GET_CVN_FLAGS; if (gv && UNLIKELY(SvROK(gv)) && SvTYPE(SvRV((SV *)gv)) == SVt_PVCV) - return (CV*)SvRV((SV *)gv); + return (CV*)SvRV((SV *)gv); /* XXX this is probably not what they think they're getting. * It has the same effect as "sub name;", i.e. just a forward * declaration! */ if ((flags & ~GV_NOADD_MASK) && !GvCVu(gv)) { - return newSTUB(gv,0); + return newSTUB(gv,0); } if (gv) - return GvCVu(gv); + return GvCVu(gv); return NULL; } @@ -2893,7 +2893,7 @@ Perl_get_cv(pTHX_ const char *name, I32 flags) =for apidoc call_argv -Performs a callback to the specified named and package-scoped Perl subroutine +Performs a callback to the specified named and package-scoped Perl subroutine with C<argv> (a C<NULL>-terminated array of strings) as arguments. See L<perlcall>. @@ -2905,8 +2905,8 @@ Approximate Perl equivalent: C<&{"$sub_name"}(@$argv)>. I32 Perl_call_argv(pTHX_ const char *sub_name, I32 flags, char **argv) - /* See G_* flags in cop.h */ - /* null terminated arg list */ + /* See G_* flags in cop.h */ + /* null terminated arg list */ { dSP; @@ -2931,8 +2931,8 @@ Performs a callback to the specified Perl sub. See L<perlcall>. I32 Perl_call_pv(pTHX_ const char *sub_name, I32 flags) - /* name of the subroutine */ - /* See G_* flags in cop.h */ + /* name of the subroutine */ + /* See G_* flags in cop.h */ { PERL_ARGS_ASSERT_CALL_PV; @@ -2950,8 +2950,8 @@ be on the stack. See L<perlcall>. I32 Perl_call_method(pTHX_ const char *methname, I32 flags) - /* name of the subroutine */ - /* See G_* flags in cop.h */ + /* name of the subroutine */ + /* See G_* flags in cop.h */ { STRLEN len; SV* sv; @@ -2994,7 +2994,7 @@ See L<perlcall>. I32 Perl_call_sv(pTHX_ SV *sv, volatile I32 flags) - /* See G_* flags in cop.h */ + /* See G_* flags in cop.h */ { LOGOP myop; /* fake syntax tree node */ METHOP method_op; @@ -3008,38 +3008,38 @@ Perl_call_sv(pTHX_ SV *sv, volatile I32 flags) PERL_ARGS_ASSERT_CALL_SV; if (flags & G_DISCARD) { - ENTER; - SAVETMPS; + ENTER; + SAVETMPS; } if (!(flags & G_WANT)) { - /* Backwards compatibility - as G_SCALAR was 0, it could be omitted. - */ - flags |= G_SCALAR; + /* Backwards compatibility - as G_SCALAR was 0, it could be omitted. + */ + flags |= G_SCALAR; } Zero(&myop, 1, LOGOP); if (!(flags & G_NOARGS)) - myop.op_flags |= OPf_STACKED; + myop.op_flags |= OPf_STACKED; myop.op_flags |= OP_GIMME_REVERSE(flags); SAVEOP(); PL_op = (OP*)&myop; if (!(flags & G_METHOD_NAMED)) { - dSP; - EXTEND(SP, 1); - PUSHs(sv); - PUTBACK; + dSP; + EXTEND(SP, 1); + PUSHs(sv); + PUTBACK; } oldmark = TOPMARK; if (PERLDB_SUB && PL_curstash != PL_debstash - /* Handle first BEGIN of -d. */ - && (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub))) - /* Try harder, since this may have been a sighandler, thus - * curstash may be meaningless. */ - && (SvTYPE(sv) != SVt_PVCV || CvSTASH((const CV *)sv) != PL_debstash) - && !(flags & G_NODEBUG)) - myop.op_private |= OPpENTERSUB_DB; + /* Handle first BEGIN of -d. */ + && (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub))) + /* Try harder, since this may have been a sighandler, thus + * curstash may be meaningless. */ + && (SvTYPE(sv) != SVt_PVCV || CvSTASH((const CV *)sv) != PL_debstash) + && !(flags & G_NODEBUG)) + myop.op_private |= OPpENTERSUB_DB; if (flags & (G_METHOD|G_METHOD_NAMED)) { Zero(&method_op, 1, METHOP); @@ -3058,72 +3058,72 @@ Perl_call_sv(pTHX_ SV *sv, volatile I32 flags) } if (!(flags & G_EVAL)) { - CATCH_SET(TRUE); - CALL_BODY_SUB((OP*)&myop); - retval = PL_stack_sp - (PL_stack_base + oldmark); - CATCH_SET(oldcatch); + CATCH_SET(TRUE); + CALL_BODY_SUB((OP*)&myop); + retval = PL_stack_sp - (PL_stack_base + oldmark); + CATCH_SET(oldcatch); } else { I32 old_cxix; - myop.op_other = (OP*)&myop; - (void)POPMARK; + myop.op_other = (OP*)&myop; + (void)POPMARK; old_cxix = cxstack_ix; - create_eval_scope(NULL, flags|G_FAKINGEVAL); - INCMARK; + create_eval_scope(NULL, flags|G_FAKINGEVAL); + INCMARK; - JMPENV_PUSH(ret); + JMPENV_PUSH(ret); - switch (ret) { - case 0: + switch (ret) { + case 0: redo_body: - CALL_BODY_SUB((OP*)&myop); - retval = PL_stack_sp - (PL_stack_base + oldmark); - if (!(flags & G_KEEPERR)) { - CLEAR_ERRSV(); - } - break; - case 1: - STATUS_ALL_FAILURE; - /* FALLTHROUGH */ - case 2: - /* my_exit() was called */ - SET_CURSTASH(PL_defstash); - FREETMPS; - JMPENV_POP; - my_exit_jump(); - NOT_REACHED; /* NOTREACHED */ - case 3: - if (PL_restartop) { - PL_restartjmpenv = NULL; - PL_op = PL_restartop; - PL_restartop = 0; - goto redo_body; - } - PL_stack_sp = PL_stack_base + oldmark; - if ((flags & G_WANT) == G_ARRAY) - retval = 0; - else { - retval = 1; - *++PL_stack_sp = &PL_sv_undef; - } - break; - } + CALL_BODY_SUB((OP*)&myop); + retval = PL_stack_sp - (PL_stack_base + oldmark); + if (!(flags & G_KEEPERR)) { + CLEAR_ERRSV(); + } + break; + case 1: + STATUS_ALL_FAILURE; + /* FALLTHROUGH */ + case 2: + /* my_exit() was called */ + SET_CURSTASH(PL_defstash); + FREETMPS; + JMPENV_POP; + my_exit_jump(); + NOT_REACHED; /* NOTREACHED */ + case 3: + if (PL_restartop) { + PL_restartjmpenv = NULL; + PL_op = PL_restartop; + PL_restartop = 0; + goto redo_body; + } + PL_stack_sp = PL_stack_base + oldmark; + if ((flags & G_WANT) == G_ARRAY) + retval = 0; + else { + retval = 1; + *++PL_stack_sp = &PL_sv_undef; + } + break; + } /* if we croaked, depending on how we croaked the eval scope * may or may not have already been popped */ - if (cxstack_ix > old_cxix) { + if (cxstack_ix > old_cxix) { assert(cxstack_ix == old_cxix + 1); assert(CxTYPE(CX_CUR()) == CXt_EVAL); - delete_eval_scope(); + delete_eval_scope(); } - JMPENV_POP; + JMPENV_POP; } if (flags & G_DISCARD) { - PL_stack_sp = PL_stack_base + oldmark; - retval = 0; - FREETMPS; - LEAVE; + PL_stack_sp = PL_stack_base + oldmark; + retval = 0; + FREETMPS; + LEAVE; } PL_op = oldop; return retval; @@ -3147,7 +3147,7 @@ execute code specified by a string, but not catch any errors. I32 Perl_eval_sv(pTHX_ SV *sv, I32 flags) - /* See G_* flags in cop.h */ + /* See G_* flags in cop.h */ { UNOP myop; /* fake syntax tree node */ volatile I32 oldmark; @@ -3159,30 +3159,30 @@ Perl_eval_sv(pTHX_ SV *sv, I32 flags) PERL_ARGS_ASSERT_EVAL_SV; if (flags & G_DISCARD) { - ENTER; - SAVETMPS; + ENTER; + SAVETMPS; } SAVEOP(); PL_op = (OP*)&myop; Zero(&myop, 1, UNOP); { - dSP; - oldmark = SP - PL_stack_base; - EXTEND(SP, 1); - PUSHs(sv); - PUTBACK; + dSP; + oldmark = SP - PL_stack_base; + EXTEND(SP, 1); + PUSHs(sv); + PUTBACK; } if (!(flags & G_NOARGS)) - myop.op_flags = OPf_STACKED; + myop.op_flags = OPf_STACKED; myop.op_type = OP_ENTEREVAL; myop.op_flags |= OP_GIMME_REVERSE(flags); if (flags & G_KEEPERR) - myop.op_flags |= OPf_SPECIAL; + myop.op_flags |= OPf_SPECIAL; if (flags & G_RE_REPARSING) - myop.op_private = (OPpEVAL_COPHH | OPpEVAL_RE_REPARSING); + myop.op_private = (OPpEVAL_COPHH | OPpEVAL_RE_REPARSING); /* fail now; otherwise we could fail after the JMPENV_PUSH but * before a cx_pusheval(), which corrupts the stack after a croak */ @@ -3192,56 +3192,56 @@ Perl_eval_sv(pTHX_ SV *sv, I32 flags) switch (ret) { case 0: redo_body: - if (PL_op == (OP*)(&myop)) { - PL_op = PL_ppaddr[OP_ENTEREVAL](aTHX); - if (!PL_op) - goto fail; /* failed in compilation */ - } - CALLRUNOPS(aTHX); - retval = PL_stack_sp - (PL_stack_base + oldmark); - if (!(flags & G_KEEPERR)) { - CLEAR_ERRSV(); - } - break; + if (PL_op == (OP*)(&myop)) { + PL_op = PL_ppaddr[OP_ENTEREVAL](aTHX); + if (!PL_op) + goto fail; /* failed in compilation */ + } + CALLRUNOPS(aTHX); + retval = PL_stack_sp - (PL_stack_base + oldmark); + if (!(flags & G_KEEPERR)) { + CLEAR_ERRSV(); + } + break; case 1: - STATUS_ALL_FAILURE; - /* FALLTHROUGH */ + STATUS_ALL_FAILURE; + /* FALLTHROUGH */ case 2: - /* my_exit() was called */ - SET_CURSTASH(PL_defstash); - FREETMPS; - JMPENV_POP; - my_exit_jump(); - NOT_REACHED; /* NOTREACHED */ + /* my_exit() was called */ + SET_CURSTASH(PL_defstash); + FREETMPS; + JMPENV_POP; + my_exit_jump(); + NOT_REACHED; /* NOTREACHED */ case 3: - if (PL_restartop) { - PL_restartjmpenv = NULL; - PL_op = PL_restartop; - PL_restartop = 0; - goto redo_body; - } + if (PL_restartop) { + PL_restartjmpenv = NULL; + PL_op = PL_restartop; + PL_restartop = 0; + goto redo_body; + } fail: if (flags & G_RETHROW) { JMPENV_POP; croak_sv(ERRSV); } - PL_stack_sp = PL_stack_base + oldmark; - if ((flags & G_WANT) == G_ARRAY) - retval = 0; - else { - retval = 1; - *++PL_stack_sp = &PL_sv_undef; - } - break; + PL_stack_sp = PL_stack_base + oldmark; + if ((flags & G_WANT) == G_ARRAY) + retval = 0; + else { + retval = 1; + *++PL_stack_sp = &PL_sv_undef; + } + break; } JMPENV_POP; if (flags & G_DISCARD) { - PL_stack_sp = PL_stack_base + oldmark; - retval = 0; - FREETMPS; - LEAVE; + PL_stack_sp = PL_stack_base + oldmark; + retval = 0; + FREETMPS; + LEAVE; } PL_op = oldop; return retval; @@ -3352,10 +3352,10 @@ NULL PerlIO *out = PerlIO_stdout(); PerlIO_printf(out, - "\nUsage: %s [switches] [--] [programfile] [arguments]\n", - PL_origargv[0]); + "\nUsage: %s [switches] [--] [programfile] [arguments]\n", + PL_origargv[0]); while (*p) - PerlIO_puts(out, *p++); + PerlIO_puts(out, *p++); my_exit(0); } @@ -3403,23 +3403,23 @@ Perl_get_debug_opts(pTHX_ const char **s, bool givehelp) PERL_ARGS_ASSERT_GET_DEBUG_OPTS; if (isALPHA(**s)) { - /* if adding extra options, remember to update DEBUG_MASK */ - static const char debopts[] = "psltocPmfrxuUHXDSTRJvCAqMBLiy"; - - for (; isWORDCHAR(**s); (*s)++) { - const char * const d = strchr(debopts,**s); - if (d) - uv |= 1 << (d - debopts); - else if (ckWARN_d(WARN_DEBUGGING)) - Perl_warner(aTHX_ packWARN(WARN_DEBUGGING), - "invalid option -D%c, use -D'' to see choices\n", **s); - } + /* if adding extra options, remember to update DEBUG_MASK */ + static const char debopts[] = "psltocPmfrxuUHXDSTRJvCAqMBLiy"; + + for (; isWORDCHAR(**s); (*s)++) { + const char * const d = strchr(debopts,**s); + if (d) + uv |= 1 << (d - debopts); + else if (ckWARN_d(WARN_DEBUGGING)) + Perl_warner(aTHX_ packWARN(WARN_DEBUGGING), + "invalid option -D%c, use -D'' to see choices\n", **s); + } } else if (isDIGIT(**s)) { const char* e = *s + strlen(*s); - if (grok_atoUV(*s, &uv, &e)) + if (grok_atoUV(*s, &uv, &e)) *s = e; - for (; isWORDCHAR(**s); (*s)++) ; + for (; isWORDCHAR(**s); (*s)++) ; } else if (givehelp) { const char *const *p = usage_msgd; @@ -3442,259 +3442,259 @@ Perl_moreswitches(pTHX_ const char *s) switch (*s) { case '0': { - I32 flags = 0; - STRLEN numlen; - - SvREFCNT_dec(PL_rs); - if (s[1] == 'x' && s[2]) { - const char *e = s+=2; - U8 *tmps; - - while (*e) - e++; - numlen = e - s; - flags = PERL_SCAN_SILENT_ILLDIGIT; - rschar = (U32)grok_hex(s, &numlen, &flags, NULL); - if (s + numlen < e) { - rschar = 0; /* Grandfather -0xFOO as -0 -xFOO. */ - numlen = 0; - s--; - } - PL_rs = newSVpvs(""); - tmps = (U8*) SvGROW(PL_rs, (STRLEN)(UVCHR_SKIP(rschar) + 1)); - uvchr_to_utf8(tmps, rschar); - SvCUR_set(PL_rs, UVCHR_SKIP(rschar)); - SvUTF8_on(PL_rs); - } - else { - numlen = 4; - rschar = (U32)grok_oct(s, &numlen, &flags, NULL); - if (rschar & ~((U8)~0)) - PL_rs = &PL_sv_undef; - else if (!rschar && numlen >= 2) - PL_rs = newSVpvs(""); - else { - char ch = (char)rschar; - PL_rs = newSVpvn(&ch, 1); - } - } - sv_setsv(get_sv("/", GV_ADD), PL_rs); - return s + numlen; + I32 flags = 0; + STRLEN numlen; + + SvREFCNT_dec(PL_rs); + if (s[1] == 'x' && s[2]) { + const char *e = s+=2; + U8 *tmps; + + while (*e) + e++; + numlen = e - s; + flags = PERL_SCAN_SILENT_ILLDIGIT; + rschar = (U32)grok_hex(s, &numlen, &flags, NULL); + if (s + numlen < e) { + rschar = 0; /* Grandfather -0xFOO as -0 -xFOO. */ + numlen = 0; + s--; + } + PL_rs = newSVpvs(""); + tmps = (U8*) SvGROW(PL_rs, (STRLEN)(UVCHR_SKIP(rschar) + 1)); + uvchr_to_utf8(tmps, rschar); + SvCUR_set(PL_rs, UVCHR_SKIP(rschar)); + SvUTF8_on(PL_rs); + } + else { + numlen = 4; + rschar = (U32)grok_oct(s, &numlen, &flags, NULL); + if (rschar & ~((U8)~0)) + PL_rs = &PL_sv_undef; + else if (!rschar && numlen >= 2) + PL_rs = newSVpvs(""); + else { + char ch = (char)rschar; + PL_rs = newSVpvn(&ch, 1); + } + } + sv_setsv(get_sv("/", GV_ADD), PL_rs); + return s + numlen; } case 'C': s++; PL_unicode = parse_unicode_opts( (const char **)&s ); - if (PL_unicode & PERL_UNICODE_UTF8CACHEASSERT_FLAG) - PL_utf8cache = -1; - return s; + if (PL_unicode & PERL_UNICODE_UTF8CACHEASSERT_FLAG) + PL_utf8cache = -1; + return s; case 'F': - PL_minus_a = TRUE; - PL_minus_F = TRUE; + PL_minus_a = TRUE; + PL_minus_F = TRUE; PL_minus_n = TRUE; - PL_splitstr = ++s; - while (*s && !isSPACE(*s)) ++s; - PL_splitstr = savepvn(PL_splitstr, s - PL_splitstr); - return s; + PL_splitstr = ++s; + while (*s && !isSPACE(*s)) ++s; + PL_splitstr = savepvn(PL_splitstr, s - PL_splitstr); + return s; case 'a': - PL_minus_a = TRUE; + PL_minus_a = TRUE; PL_minus_n = TRUE; - s++; - return s; + s++; + return s; case 'c': - PL_minus_c = TRUE; - s++; - return s; + PL_minus_c = TRUE; + s++; + return s; case 'd': - forbid_setid('d', FALSE); - s++; + forbid_setid('d', FALSE); + s++; /* -dt indicates to the debugger that threads will be used */ - if (*s == 't' && !isWORDCHAR(s[1])) { - ++s; - my_setenv("PERL5DB_THREADED", "1"); - } - - /* The following permits -d:Mod to accepts arguments following an = - in the fashion that -MSome::Mod does. */ - if (*s == ':' || *s == '=') { - const char *start; - const char *end; - SV *sv; - - if (*++s == '-') { - ++s; - sv = newSVpvs("no Devel::"); - } else { - sv = newSVpvs("use Devel::"); - } - - start = s; - end = s + strlen(s); - - /* We now allow -d:Module=Foo,Bar and -d:-Module */ - while(isWORDCHAR(*s) || *s==':') ++s; - if (*s != '=') - sv_catpvn(sv, start, end - start); - else { - sv_catpvn(sv, start, s-start); - /* Don't use NUL as q// delimiter here, this string goes in the - * environment. */ - Perl_sv_catpvf(aTHX_ sv, " split(/,/,q{%s});", ++s); - } - s = end; - my_setenv("PERL5DB", SvPV_nolen_const(sv)); - SvREFCNT_dec(sv); - } - if (!PL_perldb) { - PL_perldb = PERLDB_ALL; - init_debugger(); - } - return s; + if (*s == 't' && !isWORDCHAR(s[1])) { + ++s; + my_setenv("PERL5DB_THREADED", "1"); + } + + /* The following permits -d:Mod to accepts arguments following an = + in the fashion that -MSome::Mod does. */ + if (*s == ':' || *s == '=') { + const char *start; + const char *end; + SV *sv; + + if (*++s == '-') { + ++s; + sv = newSVpvs("no Devel::"); + } else { + sv = newSVpvs("use Devel::"); + } + + start = s; + end = s + strlen(s); + + /* We now allow -d:Module=Foo,Bar and -d:-Module */ + while(isWORDCHAR(*s) || *s==':') ++s; + if (*s != '=') + sv_catpvn(sv, start, end - start); + else { + sv_catpvn(sv, start, s-start); + /* Don't use NUL as q// delimiter here, this string goes in the + * environment. */ + Perl_sv_catpvf(aTHX_ sv, " split(/,/,q{%s});", ++s); + } + s = end; + my_setenv("PERL5DB", SvPV_nolen_const(sv)); + SvREFCNT_dec(sv); + } + if (!PL_perldb) { + PL_perldb = PERLDB_ALL; + init_debugger(); + } + return s; case 'D': - { + { #ifdef DEBUGGING - forbid_setid('D', FALSE); - s++; - PL_debug = get_debug_opts( (const char **)&s, 1) | DEBUG_TOP_FLAG; + forbid_setid('D', FALSE); + s++; + PL_debug = get_debug_opts( (const char **)&s, 1) | DEBUG_TOP_FLAG; #else /* !DEBUGGING */ - if (ckWARN_d(WARN_DEBUGGING)) - Perl_warner(aTHX_ packWARN(WARN_DEBUGGING), - "Recompile perl with -DDEBUGGING to use -D switch (did you mean -d ?)\n"); - for (s++; isWORDCHAR(*s); s++) ; + if (ckWARN_d(WARN_DEBUGGING)) + Perl_warner(aTHX_ packWARN(WARN_DEBUGGING), + "Recompile perl with -DDEBUGGING to use -D switch (did you mean -d ?)\n"); + for (s++; isWORDCHAR(*s); s++) ; #endif - return s; + return s; NOT_REACHED; /* NOTREACHED */ - } + } case 'h': - usage(); + usage(); NOT_REACHED; /* NOTREACHED */ case 'i': - Safefree(PL_inplace); - { - const char * const start = ++s; - while (*s && !isSPACE(*s)) - ++s; - - PL_inplace = savepvn(start, s - start); - } - return s; + Safefree(PL_inplace); + { + const char * const start = ++s; + while (*s && !isSPACE(*s)) + ++s; + + PL_inplace = savepvn(start, s - start); + } + return s; case 'I': /* -I handled both here and in parse_body() */ - forbid_setid('I', FALSE); - ++s; - while (*s && isSPACE(*s)) - ++s; - if (*s) { - const char *e, *p; - 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 != '-'); - incpush(s, e-s, - INCPUSH_ADD_SUB_DIRS|INCPUSH_ADD_OLD_VERS|INCPUSH_UNSHIFT); - s = p; - if (*s == '-') - s++; - } - else - Perl_croak(aTHX_ "No directory specified for -I"); - return s; + forbid_setid('I', FALSE); + ++s; + while (*s && isSPACE(*s)) + ++s; + if (*s) { + const char *e, *p; + 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 != '-'); + incpush(s, e-s, + INCPUSH_ADD_SUB_DIRS|INCPUSH_ADD_OLD_VERS|INCPUSH_UNSHIFT); + s = p; + if (*s == '-') + s++; + } + else + Perl_croak(aTHX_ "No directory specified for -I"); + return s; case 'l': - PL_minus_l = TRUE; - s++; - if (PL_ors_sv) { - SvREFCNT_dec(PL_ors_sv); - PL_ors_sv = NULL; - } - if (isDIGIT(*s)) { + PL_minus_l = TRUE; + s++; + if (PL_ors_sv) { + SvREFCNT_dec(PL_ors_sv); + PL_ors_sv = NULL; + } + if (isDIGIT(*s)) { I32 flags = 0; - STRLEN numlen; - PL_ors_sv = newSVpvs("\n"); - numlen = 3 + (*s == '0'); - *SvPVX(PL_ors_sv) = (char)grok_oct(s, &numlen, &flags, NULL); - s += numlen; - } - else { - if (RsPARA(PL_rs)) { - PL_ors_sv = newSVpvs("\n\n"); - } - else { - PL_ors_sv = newSVsv(PL_rs); - } - } - return s; + STRLEN numlen; + PL_ors_sv = newSVpvs("\n"); + numlen = 3 + (*s == '0'); + *SvPVX(PL_ors_sv) = (char)grok_oct(s, &numlen, &flags, NULL); + s += numlen; + } + else { + if (RsPARA(PL_rs)) { + PL_ors_sv = newSVpvs("\n\n"); + } + else { + PL_ors_sv = newSVsv(PL_rs); + } + } + return s; case 'M': - forbid_setid('M', FALSE); /* XXX ? */ - /* FALLTHROUGH */ + forbid_setid('M', FALSE); /* XXX ? */ + /* FALLTHROUGH */ case 'm': - forbid_setid('m', FALSE); /* XXX ? */ - if (*++s) { - const char *start; - const char *end; - SV *sv; - const char *use = "use "; - bool colon = FALSE; - /* -M-foo == 'no foo' */ - /* 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(isWORDCHAR(*s) || *s==':') { - if( *s++ == ':' ) { - if( *s == ':' ) - s++; - else - colon = TRUE; - } - } - if (s == start) - Perl_croak(aTHX_ "Module name required with -%c option", - option); - if (colon) - Perl_croak(aTHX_ "Invalid module name %.*s with -%c option: " - "contains single ':'", - (int)(s - start), start, option); - end = s + strlen(s); - if (*s != '=') { - sv_catpvn(sv, start, end - start); - if (option == 'm') { - if (*s != '\0') - Perl_croak(aTHX_ "Can't use '%c' after -mname", *s); - sv_catpvs( sv, " ()"); - } - } else { - sv_catpvn(sv, start, s-start); - /* Use NUL as q''-delimiter. */ - sv_catpvs(sv, " split(/,/,q\0"); - ++s; - sv_catpvn(sv, s, end - s); - sv_catpvs(sv, "\0)"); - } - s = end; - Perl_av_create_and_push(aTHX_ &PL_preambleav, sv); - } - else - Perl_croak(aTHX_ "Missing argument to -%c", option); - return s; + forbid_setid('m', FALSE); /* XXX ? */ + if (*++s) { + const char *start; + const char *end; + SV *sv; + const char *use = "use "; + bool colon = FALSE; + /* -M-foo == 'no foo' */ + /* 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(isWORDCHAR(*s) || *s==':') { + if( *s++ == ':' ) { + if( *s == ':' ) + s++; + else + colon = TRUE; + } + } + if (s == start) + Perl_croak(aTHX_ "Module name required with -%c option", + option); + if (colon) + Perl_croak(aTHX_ "Invalid module name %.*s with -%c option: " + "contains single ':'", + (int)(s - start), start, option); + end = s + strlen(s); + if (*s != '=') { + sv_catpvn(sv, start, end - start); + if (option == 'm') { + if (*s != '\0') + Perl_croak(aTHX_ "Can't use '%c' after -mname", *s); + sv_catpvs( sv, " ()"); + } + } else { + sv_catpvn(sv, start, s-start); + /* Use NUL as q''-delimiter. */ + sv_catpvs(sv, " split(/,/,q\0"); + ++s; + sv_catpvn(sv, s, end - s); + sv_catpvs(sv, "\0)"); + } + s = end; + Perl_av_create_and_push(aTHX_ &PL_preambleav, sv); + } + else + Perl_croak(aTHX_ "Missing argument to -%c", option); + return s; case 'n': - PL_minus_n = TRUE; - s++; - return s; + PL_minus_n = TRUE; + s++; + return s; case 'p': - PL_minus_p = TRUE; - s++; - return s; + PL_minus_p = TRUE; + s++; + return s; case 's': - forbid_setid('s', FALSE); - PL_doswitches = TRUE; - s++; - return s; + forbid_setid('s', FALSE); + PL_doswitches = TRUE; + s++; + return s; case 't': case 'T': #if defined(SILENT_NO_TAINT_SUPPORT) @@ -3704,43 +3704,43 @@ Perl_moreswitches(pTHX_ const char *s) "Cowardly refusing to run with -t or -T flags"); #else if (!TAINTING_get) - TOO_LATE_FOR(*s); + TOO_LATE_FOR(*s); #endif s++; - return s; + return s; case 'u': - PL_do_undump = TRUE; - s++; - return s; + PL_do_undump = TRUE; + s++; + return s; case 'U': - PL_unsafe = TRUE; - s++; - return s; + PL_unsafe = TRUE; + s++; + return s; case 'v': - minus_v(); + minus_v(); case 'w': - if (! (PL_dowarn & G_WARN_ALL_MASK)) { - PL_dowarn |= G_WARN_ON; - } - s++; - return s; + if (! (PL_dowarn & G_WARN_ALL_MASK)) { + PL_dowarn |= G_WARN_ON; + } + s++; + return s; case 'W': - PL_dowarn = G_WARN_ALL_ON|G_WARN_ON; + PL_dowarn = G_WARN_ALL_ON|G_WARN_ON; free_and_set_cop_warnings(&PL_compiling, pWARN_ALL); - s++; - return s; + s++; + return s; case 'X': - PL_dowarn = G_WARN_ALL_OFF; + PL_dowarn = G_WARN_ALL_OFF; free_and_set_cop_warnings(&PL_compiling, pWARN_NONE); - s++; - return s; + s++; + return s; case '*': case ' ': while( *s == ' ' ) ++s; - if (s[0] == '-') /* Additional switches on #! line. */ - return s+1; - break; + if (s[0] == '-') /* Additional switches on #! line. */ + return s+1; + break; case '-': case 0: #if defined(WIN32) || !defined(PERL_STRICT_CR) @@ -3748,21 +3748,21 @@ Perl_moreswitches(pTHX_ const char *s) #endif case '\n': case '\t': - break; + break; #ifdef ALTERNATE_SHEBANG case 'S': /* OS/2 needs -S on "extproc" line. */ - break; + break; #endif case 'e': case 'f': case 'x': case 'E': #ifndef ALTERNATE_SHEBANG case 'S': #endif case 'V': - Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s); + Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s); default: - Perl_croak(aTHX_ - "Unrecognized switch: -%.1s (-h will show valid options)",s - ); + Perl_croak(aTHX_ + "Unrecognized switch: -%.1s (-h will show valid options)",s + ); } return NULL; } @@ -3771,93 +3771,93 @@ Perl_moreswitches(pTHX_ const char *s) STATIC void S_minus_v(pTHX) { - PerlIO * PIO_stdout; - { - const char * const level_str = "v" PERL_VERSION_STRING; - const STRLEN level_len = sizeof("v" PERL_VERSION_STRING)-1; + PerlIO * PIO_stdout; + { + const char * const level_str = "v" PERL_VERSION_STRING; + const STRLEN level_len = sizeof("v" PERL_VERSION_STRING)-1; #ifdef PERL_PATCHNUM - SV* level; + SV* level; # ifdef PERL_GIT_UNCOMMITTED_CHANGES - static const char num [] = PERL_PATCHNUM "*"; + static const char num [] = PERL_PATCHNUM "*"; # else - static const char num [] = PERL_PATCHNUM; + static const char num [] = PERL_PATCHNUM; # endif - { - const STRLEN num_len = sizeof(num)-1; - /* A very advanced compiler would fold away the strnEQ - and this whole conditional, but most (all?) won't do it. - SV level could also be replaced by with preprocessor - catenation. - */ - if (num_len >= level_len && strnEQ(num,level_str,level_len)) { - /* per 46807d8e80, PERL_PATCHNUM is outside of the control - of the interp so it might contain format characters - */ - level = newSVpvn(num, num_len); - } else { - level = Perl_newSVpvf_nocontext("%s (%s)", level_str, num); - } - } + { + const STRLEN num_len = sizeof(num)-1; + /* A very advanced compiler would fold away the strnEQ + and this whole conditional, but most (all?) won't do it. + SV level could also be replaced by with preprocessor + catenation. + */ + if (num_len >= level_len && strnEQ(num,level_str,level_len)) { + /* per 46807d8e80, PERL_PATCHNUM is outside of the control + of the interp so it might contain format characters + */ + level = newSVpvn(num, num_len); + } else { + level = Perl_newSVpvf_nocontext("%s (%s)", level_str, num); + } + } #else - SV* level = newSVpvn(level_str, level_len); + SV* level = newSVpvn(level_str, level_len); #endif /* #ifdef PERL_PATCHNUM */ - PIO_stdout = PerlIO_stdout(); - PerlIO_printf(PIO_stdout, - "\nThis is perl " STRINGIFY(PERL_REVISION) - ", version " STRINGIFY(PERL_VERSION) - ", subversion " STRINGIFY(PERL_SUBVERSION) - " (%" SVf ") built for " ARCHNAME, SVfARG(level) - ); - SvREFCNT_dec_NN(level); - } + PIO_stdout = PerlIO_stdout(); + PerlIO_printf(PIO_stdout, + "\nThis is perl " STRINGIFY(PERL_REVISION) + ", version " STRINGIFY(PERL_VERSION) + ", subversion " STRINGIFY(PERL_SUBVERSION) + " (%" SVf ") built for " ARCHNAME, SVfARG(level) + ); + SvREFCNT_dec_NN(level); + } #if defined(LOCAL_PATCH_COUNT) - if (LOCAL_PATCH_COUNT > 0) - PerlIO_printf(PIO_stdout, - "\n(with %d registered patch%s, " - "see perl -V for more detail)", - LOCAL_PATCH_COUNT, - (LOCAL_PATCH_COUNT!=1) ? "es" : ""); + if (LOCAL_PATCH_COUNT > 0) + PerlIO_printf(PIO_stdout, + "\n(with %d registered patch%s, " + "see perl -V for more detail)", + LOCAL_PATCH_COUNT, + (LOCAL_PATCH_COUNT!=1) ? "es" : ""); #endif - PerlIO_printf(PIO_stdout, - "\n\nCopyright 1987-2021, Larry Wall\n"); + PerlIO_printf(PIO_stdout, + "\n\nCopyright 1987-2021, Larry Wall\n"); #ifdef MSDOS - PerlIO_printf(PIO_stdout, - "\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n"); + PerlIO_printf(PIO_stdout, + "\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n"); #endif #ifdef DJGPP - PerlIO_printf(PIO_stdout, - "djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n" - "djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n"); + PerlIO_printf(PIO_stdout, + "djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n" + "djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n"); #endif #ifdef OS2 - PerlIO_printf(PIO_stdout, - "\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n" - "Version 5 port Copyright (c) 1994-2002, Andreas Kaiser, Ilya Zakharevich\n"); + PerlIO_printf(PIO_stdout, + "\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n" + "Version 5 port Copyright (c) 1994-2002, Andreas Kaiser, Ilya Zakharevich\n"); #endif #ifdef OEMVS - PerlIO_printf(PIO_stdout, - "MVS (OS390) port by Mortice Kern Systems, 1997-1999\n"); + PerlIO_printf(PIO_stdout, + "MVS (OS390) port by Mortice Kern Systems, 1997-1999\n"); #endif #ifdef __VOS__ - PerlIO_printf(PIO_stdout, - "Stratus OpenVOS port by Paul.Green@stratus.com, 1997-2013\n"); + PerlIO_printf(PIO_stdout, + "Stratus OpenVOS port by Paul.Green@stratus.com, 1997-2013\n"); #endif #ifdef POSIX_BC - PerlIO_printf(PIO_stdout, - "BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n"); + PerlIO_printf(PIO_stdout, + "BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n"); #endif #ifdef BINARY_BUILD_NOTICE - BINARY_BUILD_NOTICE; + BINARY_BUILD_NOTICE; #endif - PerlIO_printf(PIO_stdout, - "\n\ + PerlIO_printf(PIO_stdout, + "\n\ Perl may be copied only under the terms of either the Artistic License or the\n\ GNU General Public License, which may be found in the Perl 5 source kit.\n\n\ Complete documentation for Perl, including FAQ lists, should be found on\n\ this system using \"man perl\" or \"perldoc perl\". If you have access to the\n\ Internet, point your browser at http://www.perl.org/, the Perl Home Page.\n\n"); - my_exit(0); + my_exit(0); } /* compliments of Tom Christiansen */ @@ -3950,7 +3950,7 @@ S_init_main_stash(pTHX) GvHV(gv) = MUTABLE_HV(SvREFCNT_inc_simple(PL_defstash)); SvREADONLY_on(gv); PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpvs("INC", GV_ADD|GV_NOTQUAL, - SVt_PVAV))); + SVt_PVAV))); SvREFCNT_inc_simple_void(PL_incgv); /* Don't allow it to be freed */ GvMULTI_on(PL_incgv); PL_hintgv = gv_fetchpvs("\010", GV_ADD|GV_NOTQUAL, SVt_PV); /* ^H */ @@ -3973,7 +3973,7 @@ S_init_main_stash(pTHX) CopSTASH_set(&PL_compiling, PL_defstash); PL_debstash = GvHV(gv_fetchpvs("DB::", GV_ADDMULTI, SVt_PVHV)); PL_globalstash = GvHV(gv_fetchpvs("CORE::GLOBAL::", GV_ADDMULTI, - SVt_PVHV)); + SVt_PVHV)); /* We must init $/ before switches are processed. */ sv_setpvs(get_sv("/", GV_ADD), "\n"); } @@ -3989,102 +3989,102 @@ S_open_script(pTHX_ const char *scriptname, bool dosearch, bool *suidscript) PERL_ARGS_ASSERT_OPEN_SCRIPT; if (PL_e_script) { - PL_origfilename = savepvs("-e"); + PL_origfilename = savepvs("-e"); } else { const char *s; UV uv; - /* if find_script() returns, it returns a malloc()-ed value */ - scriptname = PL_origfilename = find_script(scriptname, dosearch, NULL, 1); + /* if find_script() returns, it returns a malloc()-ed value */ + scriptname = PL_origfilename = find_script(scriptname, dosearch, NULL, 1); s = scriptname + strlen(scriptname); - if (strBEGINs(scriptname, "/dev/fd/") + if (strBEGINs(scriptname, "/dev/fd/") && isDIGIT(scriptname[8]) && grok_atoUV(scriptname + 8, &uv, &s) && uv <= PERL_INT_MAX ) { fdscript = (int)uv; - if (*s) { - /* PSz 18 Feb 04 - * Tell apart "normal" usage of fdscript, e.g. - * with bash on FreeBSD: - * perl <( echo '#!perl -DA'; echo 'print "$0\n"') - * from usage in suidperl. - * Does any "normal" usage leave garbage after the number??? - * Is it a mistake to use a similar /dev/fd/ construct for - * suidperl? - */ - *suidscript = TRUE; - /* PSz 20 Feb 04 - * Be supersafe and do some sanity-checks. - * Still, can we be sure we got the right thing? - */ - if (*s != '/') { - Perl_croak(aTHX_ "Wrong syntax (suid) fd script name \"%s\"\n", s); - } - if (! *(s+1)) { - Perl_croak(aTHX_ "Missing (suid) fd script name\n"); - } - scriptname = savepv(s + 1); - Safefree(PL_origfilename); - PL_origfilename = (char *)scriptname; - } - } + if (*s) { + /* PSz 18 Feb 04 + * Tell apart "normal" usage of fdscript, e.g. + * with bash on FreeBSD: + * perl <( echo '#!perl -DA'; echo 'print "$0\n"') + * from usage in suidperl. + * Does any "normal" usage leave garbage after the number??? + * Is it a mistake to use a similar /dev/fd/ construct for + * suidperl? + */ + *suidscript = TRUE; + /* PSz 20 Feb 04 + * Be supersafe and do some sanity-checks. + * Still, can we be sure we got the right thing? + */ + if (*s != '/') { + Perl_croak(aTHX_ "Wrong syntax (suid) fd script name \"%s\"\n", s); + } + if (! *(s+1)) { + Perl_croak(aTHX_ "Missing (suid) fd script name\n"); + } + scriptname = savepv(s + 1); + Safefree(PL_origfilename); + PL_origfilename = (char *)scriptname; + } + } } CopFILE_free(PL_curcop); CopFILE_set(PL_curcop, PL_origfilename); if (*PL_origfilename == '-' && PL_origfilename[1] == '\0') - scriptname = (char *)""; + scriptname = (char *)""; if (fdscript >= 0) { - rsfp = PerlIO_fdopen(fdscript,PERL_SCRIPT_MODE); + rsfp = PerlIO_fdopen(fdscript,PERL_SCRIPT_MODE); } else if (!*scriptname) { - forbid_setid(0, *suidscript); - return NULL; + forbid_setid(0, *suidscript); + return NULL; } else { #ifdef FAKE_BIT_BUCKET - /* This hack allows one not to have /dev/null (or BIT_BUCKET as it - * is called) and still have the "-e" work. (Believe it or not, - * a /dev/null is required for the "-e" to work because source - * filter magic is used to implement it. ) This is *not* a general - * replacement for a /dev/null. What we do here is create a temp - * file (an empty file), open up that as the script, and then - * immediately close and unlink it. Close enough for jazz. */ + /* This hack allows one not to have /dev/null (or BIT_BUCKET as it + * is called) and still have the "-e" work. (Believe it or not, + * a /dev/null is required for the "-e" to work because source + * filter magic is used to implement it. ) This is *not* a general + * replacement for a /dev/null. What we do here is create a temp + * file (an empty file), open up that as the script, and then + * immediately close and unlink it. Close enough for jazz. */ #define FAKE_BIT_BUCKET_PREFIX "/tmp/perlnull-" #define FAKE_BIT_BUCKET_SUFFIX "XXXXXXXX" #define FAKE_BIT_BUCKET_TEMPLATE FAKE_BIT_BUCKET_PREFIX FAKE_BIT_BUCKET_SUFFIX - char tmpname[sizeof(FAKE_BIT_BUCKET_TEMPLATE)] = { - FAKE_BIT_BUCKET_TEMPLATE - }; - const char * const err = "Failed to create a fake bit bucket"; - if (strEQ(scriptname, BIT_BUCKET)) { - int tmpfd = Perl_my_mkstemp_cloexec(tmpname); - if (tmpfd > -1) { - scriptname = tmpname; - close(tmpfd); - } else - Perl_croak(aTHX_ err); - } -#endif - rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE); + char tmpname[sizeof(FAKE_BIT_BUCKET_TEMPLATE)] = { + FAKE_BIT_BUCKET_TEMPLATE + }; + const char * const err = "Failed to create a fake bit bucket"; + if (strEQ(scriptname, BIT_BUCKET)) { + int tmpfd = Perl_my_mkstemp_cloexec(tmpname); + if (tmpfd > -1) { + scriptname = tmpname; + close(tmpfd); + } else + Perl_croak(aTHX_ err); + } +#endif + rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE); #ifdef FAKE_BIT_BUCKET if ( strBEGINs(scriptname, FAKE_BIT_BUCKET_PREFIX) - && strlen(scriptname) == sizeof(tmpname) - 1) + && strlen(scriptname) == sizeof(tmpname) - 1) { - unlink(scriptname); - } - scriptname = BIT_BUCKET; + unlink(scriptname); + } + scriptname = BIT_BUCKET; #endif } if (!rsfp) { - /* PSz 16 Sep 03 Keep neat error message */ - 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)); + /* PSz 16 Sep 03 Keep neat error message */ + 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)); } fd = PerlIO_fileno(rsfp); @@ -4137,10 +4137,10 @@ S_validate_suid(pTHX_ PerlIO *rsfp) || (my_egid != my_gid && my_egid == statbuf.st_gid && statbuf.st_mode & S_ISGID) ) - if (!PL_do_undump) - Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\ + if (!PL_do_undump) + Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n"); - /* not set-id, must be wrapped */ + /* not set-id, must be wrapped */ } } #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */ @@ -4156,20 +4156,20 @@ S_find_beginning(pTHX_ SV* linestr_sv, PerlIO *rsfp) /* skip forward in input to the real script? */ do { - if ((s = sv_gets(linestr_sv, rsfp, 0)) == NULL) - Perl_croak(aTHX_ "No Perl script found in input\n"); - s2 = s; + if ((s = sv_gets(linestr_sv, rsfp, 0)) == NULL) + Perl_croak(aTHX_ "No Perl script found in input\n"); + s2 = s; } while (!(*s == '#' && s[1] == '!' && ((s = instr(s,"perl")) || (s = instr(s2,"PERL"))))); PerlIO_ungetc(rsfp, '\n'); /* to keep line count right */ while (*s && !(isSPACE (*s) || *s == '#')) s++; s2 = s; while (*s == ' ' || *s == '\t') s++; if (*s++ == '-') { - while (isDIGIT(s2[-1]) || s2[-1] == '-' || s2[-1] == '.' - || s2[-1] == '_') s2--; - if (strBEGINs(s2-4,"perl")) - while ((s = moreswitches(s))) - ; + while (isDIGIT(s2[-1]) || s2[-1] == '-' || s2[-1] == '.' + || s2[-1] == '_') s2--; + if (strBEGINs(s2-4,"perl")) + while ((s = moreswitches(s))) + ; } } @@ -4228,14 +4228,14 @@ Perl_doing_taint(int argc, char *argv[], char *envp[]) euid |= egid << 16; #endif if (uid && (euid != uid || egid != gid)) - return 1; + return 1; #endif /* !PERL_IMPLICIT_SYS */ /* This is a really primitive check; environment gets ignored only * if -T are the first chars together; otherwise one gets * "Too late" message. */ if ( argc > 1 && argv[1][0] == '-' && isALPHA_FOLD_EQ(argv[1][1], 't')) - return 1; + return 1; return 0; } @@ -4251,8 +4251,8 @@ S_forbid_setid(pTHX_ const char flag, const bool suidscript) /* g */ PERL_UNUSED_CONTEXT; if (flag) { - string[1] = flag; - message = string; + string[1] = flag; + message = string; } #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW @@ -4269,16 +4269,16 @@ void Perl_init_dbargs(pTHX) { AV *const args = PL_dbargs = GvAV(gv_AVadd((gv_fetchpvs("DB::args", - GV_ADDMULTI, - SVt_PVAV)))); + GV_ADDMULTI, + SVt_PVAV)))); if (AvREAL(args)) { - /* Someone has already created it. - It might have entries, and if we just turn off AvREAL(), they will - "leak" until global destruction. */ - av_clear(args); - if (SvTIED_mg((const SV *)args, PERL_MAGIC_tied)) - Perl_croak(aTHX_ "Cannot set tied @DB::args"); + /* Someone has already created it. + It might have entries, and if we just turn off AvREAL(), they will + "leak" until global destruction. */ + av_clear(args); + if (SvTIED_mg((const SV *)args, PERL_MAGIC_tied)) + Perl_croak(aTHX_ "Cannot set tied @DB::args"); } AvREIFY_only(PL_dbargs); } @@ -4293,31 +4293,31 @@ Perl_init_debugger(pTHX) Perl_init_dbargs(aTHX); PL_DBgv = MUTABLE_GV( - SvREFCNT_inc(gv_fetchpvs("DB::DB", GV_ADDMULTI, SVt_PVGV)) + SvREFCNT_inc(gv_fetchpvs("DB::DB", GV_ADDMULTI, SVt_PVGV)) ); PL_DBline = MUTABLE_GV( - SvREFCNT_inc(gv_fetchpvs("DB::dbline", GV_ADDMULTI, SVt_PVAV)) + SvREFCNT_inc(gv_fetchpvs("DB::dbline", GV_ADDMULTI, SVt_PVAV)) ); PL_DBsub = MUTABLE_GV(SvREFCNT_inc( - gv_HVadd(gv_fetchpvs("DB::sub", GV_ADDMULTI, SVt_PVHV)) + gv_HVadd(gv_fetchpvs("DB::sub", GV_ADDMULTI, SVt_PVHV)) )); PL_DBsingle = GvSV((gv_fetchpvs("DB::single", GV_ADDMULTI, SVt_PV))); if (!SvIOK(PL_DBsingle)) - sv_setiv(PL_DBsingle, 0); + sv_setiv(PL_DBsingle, 0); mg = sv_magicext(PL_DBsingle, NULL, PERL_MAGIC_debugvar, &PL_vtbl_debugvar, 0, 0); mg->mg_private = DBVARMG_SINGLE; SvSETMAGIC(PL_DBsingle); PL_DBtrace = GvSV((gv_fetchpvs("DB::trace", GV_ADDMULTI, SVt_PV))); if (!SvIOK(PL_DBtrace)) - sv_setiv(PL_DBtrace, 0); + sv_setiv(PL_DBtrace, 0); mg = sv_magicext(PL_DBtrace, NULL, PERL_MAGIC_debugvar, &PL_vtbl_debugvar, 0, 0); mg->mg_private = DBVARMG_TRACE; SvSETMAGIC(PL_DBtrace); PL_DBsignal = GvSV((gv_fetchpvs("DB::signal", GV_ADDMULTI, SVt_PV))); if (!SvIOK(PL_DBsignal)) - sv_setiv(PL_DBsignal, 0); + sv_setiv(PL_DBsignal, 0); mg = sv_magicext(PL_DBsignal, NULL, PERL_MAGIC_debugvar, &PL_vtbl_debugvar, 0, 0); mg->mg_private = DBVARMG_SIGNAL; SvSETMAGIC(PL_DBsignal); @@ -4341,7 +4341,7 @@ Perl_init_stacks(pTHX) /* start with 128-item stack and 8K cxstack */ PL_curstackinfo = new_stackinfo(REASONABLE(128), - REASONABLE(8192/sizeof(PERL_CONTEXT) - 1)); + REASONABLE(8192/sizeof(PERL_CONTEXT) - 1)); PL_curstackinfo->si_type = PERLSI_MAIN; #if defined DEBUGGING && !defined DEBUGGING_RE_ONLY PL_curstackinfo->si_stack_hwm = 0; @@ -4384,13 +4384,13 @@ STATIC void S_nuke_stacks(pTHX) { while (PL_curstackinfo->si_next) - PL_curstackinfo = PL_curstackinfo->si_next; + PL_curstackinfo = PL_curstackinfo->si_next; while (PL_curstackinfo) { - PERL_SI *p = PL_curstackinfo->si_prev; - /* curstackinfo->si_stack got nuked by sv_free_arenas() */ - Safefree(PL_curstackinfo->si_cxstack); - Safefree(PL_curstackinfo); - PL_curstackinfo = p; + PERL_SI *p = PL_curstackinfo->si_prev; + /* curstackinfo->si_stack got nuked by sv_free_arenas() */ + Safefree(PL_curstackinfo->si_cxstack); + Safefree(PL_curstackinfo); + PL_curstackinfo = p; } Safefree(PL_tmps_stack); Safefree(PL_markstack); @@ -4411,25 +4411,25 @@ Perl_populate_isa(pTHX_ const char *name, STRLEN len, ...) PERL_ARGS_ASSERT_POPULATE_ISA; if(AvFILLp(isa) != -1) - return; + return; /* NOTE: No support for tied ISA */ va_start(args, len); do { - const char *const parent = va_arg(args, const char*); - size_t parent_len; - - if (!parent) - break; - parent_len = va_arg(args, size_t); - - /* Arguments are supplied with a trailing :: */ - assert(parent_len > 2); - assert(parent[parent_len - 1] == ':'); - assert(parent[parent_len - 2] == ':'); - av_push(isa, newSVpvn(parent, parent_len - 2)); - (void) gv_fetchpvn(parent, parent_len, GV_ADD, SVt_PVGV); + const char *const parent = va_arg(args, const char*); + size_t parent_len; + + if (!parent) + break; + parent_len = va_arg(args, size_t); + + /* Arguments are supplied with a trailing :: */ + assert(parent_len > 2); + assert(parent[parent_len - 1] == ':'); + assert(parent[parent_len - 2] == ':'); + av_push(isa, newSVpvn(parent, parent_len - 2)); + (void) gv_fetchpvn(parent, parent_len, GV_ADD, SVt_PVGV); } while (1); va_end(args); } @@ -4457,12 +4457,12 @@ S_init_predump_symbols(pTHX) So a compromise is to set up the correct @IO::File::ISA, so that code that does C<use IO::Handle>; will still work. */ - + Perl_populate_isa(aTHX_ STR_WITH_LEN("IO::File::ISA"), - STR_WITH_LEN("IO::Handle::"), - STR_WITH_LEN("IO::Seekable::"), - STR_WITH_LEN("Exporter::"), - NULL); + STR_WITH_LEN("IO::Handle::"), + STR_WITH_LEN("IO::Seekable::"), + STR_WITH_LEN("Exporter::"), + NULL); PL_stdingv = gv_fetchpvs("STDIN", GV_ADD|GV_NOTQUAL, SVt_PVIO); GvMULTI_on(PL_stdingv); @@ -4502,37 +4502,37 @@ Perl_init_argv_symbols(pTHX_ int argc, char **argv) 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]) { - argc--,argv++; - break; - } - if ((s = strchr(argv[0], '='))) { - const char *const start_name = argv[0] + 1; - sv_setpv(GvSV(gv_fetchpvn_flags(start_name, s - start_name, - TRUE, SVt_PV)), s + 1); - } - else - sv_setiv(GvSV(gv_fetchpv(argv[0]+1, GV_ADD, SVt_PV)),1); - } + for (; argc > 0 && **argv == '-'; argc--,argv++) { + char *s; + if (!argv[0][1]) + break; + if (argv[0][1] == '-' && !argv[0][2]) { + argc--,argv++; + break; + } + if ((s = strchr(argv[0], '='))) { + const char *const start_name = argv[0] + 1; + sv_setpv(GvSV(gv_fetchpvn_flags(start_name, s - start_name, + TRUE, SVt_PV)), s + 1); + } + else + sv_setiv(GvSV(gv_fetchpv(argv[0]+1, GV_ADD, SVt_PV)),1); + } } if ((PL_argvgv = gv_fetchpvs("ARGV", GV_ADD|GV_NOTQUAL, SVt_PVAV))) { - SvREFCNT_inc_simple_void_NN(PL_argvgv); - GvMULTI_on(PL_argvgv); - av_clear(GvAVn(PL_argvgv)); - for (; argc > 0; argc--,argv++) { - SV * const sv = newSVpv(argv[0],0); - av_push(GvAV(PL_argvgv),sv); - if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) { - if (PL_unicode & PERL_UNICODE_ARGV_FLAG) - SvUTF8_on(sv); - } - if (PL_unicode & PERL_UNICODE_WIDESYSCALLS_FLAG) /* Sarathy? */ - (void)sv_utf8_decode(sv); - } + SvREFCNT_inc_simple_void_NN(PL_argvgv); + GvMULTI_on(PL_argvgv); + av_clear(GvAVn(PL_argvgv)); + for (; argc > 0; argc--,argv++) { + SV * const sv = newSVpv(argv[0],0); + av_push(GvAV(PL_argvgv),sv); + if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) { + if (PL_unicode & PERL_UNICODE_ARGV_FLAG) + SvUTF8_on(sv); + } + if (PL_unicode & PERL_UNICODE_WIDESYSCALLS_FLAG) /* Sarathy? */ + (void)sv_utf8_decode(sv); + } } if (PL_inplace && (!PL_argvgv || AvFILL(GvAV(PL_argvgv)) == -1)) @@ -4559,50 +4559,50 @@ S_init_postdump_symbols(pTHX_ int argc, char **argv, char **env) init_argv_symbols(argc,argv); if ((tmpgv = gv_fetchpvs("0", GV_ADD|GV_NOTQUAL, SVt_PV))) { - sv_setpv(GvSV(tmpgv),PL_origfilename); + sv_setpv(GvSV(tmpgv),PL_origfilename); } if ((PL_envgv = gv_fetchpvs("ENV", GV_ADD|GV_NOTQUAL, SVt_PVHV))) { - HV *hv; - bool env_is_not_environ; - SvREFCNT_inc_simple_void_NN(PL_envgv); - GvMULTI_on(PL_envgv); - hv = GvHVn(PL_envgv); - hv_magic(hv, NULL, PERL_MAGIC_env); + HV *hv; + bool env_is_not_environ; + SvREFCNT_inc_simple_void_NN(PL_envgv); + GvMULTI_on(PL_envgv); + hv = GvHVn(PL_envgv); + hv_magic(hv, NULL, PERL_MAGIC_env); #ifndef PERL_MICRO #ifdef USE_ENVIRON_ARRAY - /* Note that if the supplied env parameter is actually a copy - of the global environ then it may now point to free'd memory - if the environment has been modified since. To avoid this - problem we treat env==NULL as meaning 'use the default' - */ - if (!env) - env = environ; - env_is_not_environ = env != environ; - if (env_is_not_environ + /* Note that if the supplied env parameter is actually a copy + of the global environ then it may now point to free'd memory + if the environment has been modified since. To avoid this + problem we treat env==NULL as meaning 'use the default' + */ + if (!env) + env = environ; + env_is_not_environ = env != environ; + if (env_is_not_environ # ifdef USE_ITHREADS - && PL_curinterp == aTHX + && PL_curinterp == aTHX # endif - ) - { - environ[0] = NULL; - } - if (env) { - char *s, *old_var; + ) + { + environ[0] = NULL; + } + if (env) { + char *s, *old_var; STRLEN nlen; - SV *sv; + SV *sv; HV *dups = newHV(); - for (; *env; env++) { - old_var = *env; + for (; *env; env++) { + old_var = *env; - if (!(s = strchr(old_var,'=')) || s == old_var) - continue; + if (!(s = strchr(old_var,'=')) || s == old_var) + continue; nlen = s - old_var; #if defined(MSDOS) && !defined(DJGPP) - *s = '\0'; - (void)strupr(old_var); - *s = '='; + *s = '\0'; + (void)strupr(old_var); + *s = '='; #endif if (hv_exists(hv, old_var, nlen)) { const char *name = savepvn(old_var, nlen); @@ -4623,10 +4623,10 @@ S_init_postdump_symbols(pTHX_ int argc, char **argv, char **env) else { sv = newSVpv(s+1, 0); } - (void)hv_store(hv, old_var, nlen, sv, 0); - if (env_is_not_environ) - mg_set(sv); - } + (void)hv_store(hv, old_var, nlen, sv, 0); + if (env_is_not_environ) + mg_set(sv); + } if (HvKEYS(dups)) { /* environ has some duplicate definitions, remove them */ HE *entry; @@ -4677,38 +4677,38 @@ S_init_perllib(pTHX) if (!TAINTING_get) { #ifndef VMS - perl5lib = PerlEnv_getenv("PERL5LIB"); + perl5lib = 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 (perl5lib && *perl5lib != '\0') + if (perl5lib && *perl5lib != '\0') #else - if (perl5lib) -#endif - incpush_use_sep(perl5lib, 0, INCPUSH_ADD_SUB_DIRS); - else { - s = PerlEnv_getenv("PERLLIB"); - if (s) - incpush_use_sep(s, 0, 0); - } + if (perl5lib) +#endif + incpush_use_sep(perl5lib, 0, INCPUSH_ADD_SUB_DIRS); + else { + s = PerlEnv_getenv("PERLLIB"); + if (s) + incpush_use_sep(s, 0, 0); + } #else /* VMS */ - /* Treat PERL5?LIB as a possible search list logical name -- the - * "natural" VMS idiom for a Unix path string. We allow each - * element to be a set of |-separated directories for compatibility. - */ - char buf[256]; - int idx = 0; - if (vmstrnenv("PERL5LIB",buf,0,NULL,0)) - do { - incpush_use_sep(buf, 0, INCPUSH_ADD_SUB_DIRS); - } while (vmstrnenv("PERL5LIB",buf,++idx,NULL,0)); - else { - while (vmstrnenv("PERLLIB",buf,idx++,NULL,0)) - incpush_use_sep(buf, 0, 0); - } + /* Treat PERL5?LIB as a possible search list logical name -- the + * "natural" VMS idiom for a Unix path string. We allow each + * element to be a set of |-separated directories for compatibility. + */ + char buf[256]; + int idx = 0; + if (vmstrnenv("PERL5LIB",buf,0,NULL,0)) + do { + incpush_use_sep(buf, 0, INCPUSH_ADD_SUB_DIRS); + } while (vmstrnenv("PERL5LIB",buf,++idx,NULL,0)); + else { + while (vmstrnenv("PERLLIB",buf,idx++,NULL,0)) + incpush_use_sep(buf, 0, 0); + } #endif /* VMS */ } @@ -4768,12 +4768,12 @@ S_incpush_if_exists(pTHX_ AV *const av, SV *dir, SV *const stem) PERL_ARGS_ASSERT_INCPUSH_IF_EXISTS; if (PerlLIO_stat(SvPVX_const(dir), &tmpstatbuf) >= 0 && - S_ISDIR(tmpstatbuf.st_mode)) { - av_push(av, dir); - dir = newSVsv(stem); + S_ISDIR(tmpstatbuf.st_mode)) { + av_push(av, dir); + dir = newSVsv(stem); } else { - /* Truncate dir back to stem. */ - SvCUR_set(dir, SvCUR(stem)); + /* Truncate dir back to stem. */ + SvCUR_set(dir, SvCUR(stem)); } return dir; } @@ -4797,120 +4797,120 @@ S_mayberelocate(pTHX_ const char *const dir, STRLEN len, U32 flags) #ifdef VMS { - char *unix; + char *unix; - if ((unix = tounixspec_ts(SvPV(libdir,len),NULL)) != NULL) { - len = strlen(unix); - while (len > 1 && unix[len-1] == '/') len--; /* Cosmetic */ - sv_usepvn(libdir,unix,len); - } - else - PerlIO_printf(Perl_error_log, - "Failed to unixify @INC element \"%s\"\n", - SvPV_nolen_const(libdir)); + if ((unix = tounixspec_ts(SvPV(libdir,len),NULL)) != NULL) { + len = strlen(unix); + while (len > 1 && unix[len-1] == '/') len--; /* Cosmetic */ + sv_usepvn(libdir,unix,len); + } + else + PerlIO_printf(Perl_error_log, + "Failed to unixify @INC element \"%s\"\n", + SvPV_nolen_const(libdir)); } #endif - /* Do the if() outside the #ifdef to avoid warnings about an unused - parameter. */ - if (canrelocate) { + /* Do the if() outside the #ifdef to avoid warnings about an unused + parameter. */ + if (canrelocate) { #ifdef PERL_RELOCATABLE_INC - /* - * Relocatable include entries are marked with a leading .../ - * - * The algorithm is - * 0: Remove that leading ".../" - * 1: Remove trailing executable name (anything after the last '/') - * from the perl path to give a perl prefix - * Then - * While the @INC element starts "../" and the prefix ends with a real - * directory (ie not . or ..) chop that real directory off the prefix - * and the leading "../" from the @INC element. ie a logical "../" - * cleanup - * Finally concatenate the prefix and the remainder of the @INC element - * The intent is that /usr/local/bin/perl and .../../lib/perl5 - * generates /usr/local/lib/perl5 - */ - const char *libpath = SvPVX(libdir); - STRLEN libpath_len = SvCUR(libdir); - if (memBEGINs(libpath, libpath_len, ".../")) { - /* Game on! */ - 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; - char *prefix; - char *lastslash; - - /* $^X is *the* source of taint if tainting is on, hence - SvPOK() won't be true. */ - assert(caret_X); - assert(SvPOKp(caret_X)); - prefix_sv = newSVpvn_flags(SvPVX(caret_X), SvCUR(caret_X), - SvUTF8(caret_X)); - /* Firstly take off the leading .../ - If all else fail we'll do the paths relative to the current - directory. */ - sv_chop(libdir, libpath + 4); - /* Don't use SvPV as we're intentionally bypassing taining, - mortal copies that the mg_get of tainting creates, and - corruption that seems to come via the save stack. - I guess that the save stack isn't correctly set up yet. */ - libpath = SvPVX(libdir); - libpath_len = SvCUR(libdir); - - prefix = SvPVX(prefix_sv); - lastslash = (char *) my_memrchr(prefix, '/', + /* + * Relocatable include entries are marked with a leading .../ + * + * The algorithm is + * 0: Remove that leading ".../" + * 1: Remove trailing executable name (anything after the last '/') + * from the perl path to give a perl prefix + * Then + * While the @INC element starts "../" and the prefix ends with a real + * directory (ie not . or ..) chop that real directory off the prefix + * and the leading "../" from the @INC element. ie a logical "../" + * cleanup + * Finally concatenate the prefix and the remainder of the @INC element + * The intent is that /usr/local/bin/perl and .../../lib/perl5 + * generates /usr/local/lib/perl5 + */ + const char *libpath = SvPVX(libdir); + STRLEN libpath_len = SvCUR(libdir); + if (memBEGINs(libpath, libpath_len, ".../")) { + /* Game on! */ + 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; + char *prefix; + char *lastslash; + + /* $^X is *the* source of taint if tainting is on, hence + SvPOK() won't be true. */ + assert(caret_X); + assert(SvPOKp(caret_X)); + prefix_sv = newSVpvn_flags(SvPVX(caret_X), SvCUR(caret_X), + SvUTF8(caret_X)); + /* Firstly take off the leading .../ + If all else fail we'll do the paths relative to the current + directory. */ + sv_chop(libdir, libpath + 4); + /* Don't use SvPV as we're intentionally bypassing taining, + mortal copies that the mg_get of tainting creates, and + corruption that seems to come via the save stack. + I guess that the save stack isn't correctly set up yet. */ + libpath = SvPVX(libdir); + libpath_len = SvCUR(libdir); + + prefix = SvPVX(prefix_sv); + lastslash = (char *) my_memrchr(prefix, '/', SvEND(prefix_sv) - prefix); - /* First time in with the *lastslash = '\0' we just wipe off - the trailing /perl from (say) /usr/foo/bin/perl - */ - if (lastslash) { - SV *tempsv; - while ((*lastslash = '\0'), /* Do that, come what may. */ + /* First time in with the *lastslash = '\0' we just wipe off + the trailing /perl from (say) /usr/foo/bin/perl + */ + if (lastslash) { + SV *tempsv; + while ((*lastslash = '\0'), /* Do that, come what may. */ ( memBEGINs(libpath, libpath_len, "../") - && (lastslash = + && (lastslash = (char *) my_memrchr(prefix, '/', SvEND(prefix_sv) - prefix)))) { - if (lastslash[1] == '\0' - || (lastslash[1] == '.' - && (lastslash[2] == '/' /* ends "/." */ - || (lastslash[2] == '/' - && lastslash[3] == '/' /* or "/.." */ - )))) { - /* Prefix ends "/" or "/." or "/..", any of which - are fishy, so don't do any more logical cleanup. - */ - break; - } - /* Remove leading "../" from path */ - libpath += 3; - libpath_len -= 3; - /* Next iteration round the loop removes the last - directory name from prefix by writing a '\0' in - the while clause. */ - } - /* prefix has been terminated with a '\0' to the correct - length. libpath points somewhere into the libdir SV. - We need to join the 2 with '/' and drop the result into - libdir. */ - tempsv = Perl_newSVpvf(aTHX_ "%s/%s", prefix, libpath); - SvREFCNT_dec(libdir); - /* And this is the new libdir. */ - libdir = tempsv; - if (TAINTING_get && - (PerlProc_getuid() != PerlProc_geteuid() || - PerlProc_getgid() != PerlProc_getegid())) { - /* Need to taint relocated paths if running set ID */ - SvTAINTED_on(libdir); - } - } - SvREFCNT_dec(prefix_sv); - } -#endif - } + if (lastslash[1] == '\0' + || (lastslash[1] == '.' + && (lastslash[2] == '/' /* ends "/." */ + || (lastslash[2] == '/' + && lastslash[3] == '/' /* or "/.." */ + )))) { + /* Prefix ends "/" or "/." or "/..", any of which + are fishy, so don't do any more logical cleanup. + */ + break; + } + /* Remove leading "../" from path */ + libpath += 3; + libpath_len -= 3; + /* Next iteration round the loop removes the last + directory name from prefix by writing a '\0' in + the while clause. */ + } + /* prefix has been terminated with a '\0' to the correct + length. libpath points somewhere into the libdir SV. + We need to join the 2 with '/' and drop the result into + libdir. */ + tempsv = Perl_newSVpvf(aTHX_ "%s/%s", prefix, libpath); + SvREFCNT_dec(libdir); + /* And this is the new libdir. */ + libdir = tempsv; + if (TAINTING_get && + (PerlProc_getuid() != PerlProc_geteuid() || + PerlProc_getgid() != PerlProc_getegid())) { + /* Need to taint relocated paths if running set ID */ + SvTAINTED_on(libdir); + } + } + SvREFCNT_dec(prefix_sv); + } +#endif + } return libdir; } @@ -4919,12 +4919,12 @@ S_incpush(pTHX_ const char *const dir, STRLEN len, U32 flags) { #ifndef PERL_IS_MINIPERL const U8 using_sub_dirs - = (U8)flags & (INCPUSH_ADD_VERSIONED_SUB_DIRS - |INCPUSH_ADD_ARCHONLY_SUB_DIRS|INCPUSH_ADD_OLD_VERS); + = (U8)flags & (INCPUSH_ADD_VERSIONED_SUB_DIRS + |INCPUSH_ADD_ARCHONLY_SUB_DIRS|INCPUSH_ADD_OLD_VERS); const U8 add_versioned_sub_dirs - = (U8)flags & INCPUSH_ADD_VERSIONED_SUB_DIRS; + = (U8)flags & INCPUSH_ADD_VERSIONED_SUB_DIRS; const U8 add_archonly_sub_dirs - = (U8)flags & INCPUSH_ADD_ARCHONLY_SUB_DIRS; + = (U8)flags & INCPUSH_ADD_ARCHONLY_SUB_DIRS; #ifdef PERL_INC_VERSION_LIST const U8 addoldvers = (U8)flags & INCPUSH_ADD_OLD_VERS; #endif @@ -4939,95 +4939,95 @@ S_incpush(pTHX_ const char *const dir, STRLEN len, U32 flags) /* Could remove this vestigial extra block, if we don't mind a lot of re-indenting diff noise. */ { - SV *const libdir = mayberelocate(dir, len, flags); - /* Change 20189146be79a0596543441fa369c6bf7f85103f, to fix RT#6665, - arranged to unshift #! line -I onto the front of @INC. However, - -I can add version and architecture specific libraries, and they - need to go first. The old code assumed that it was always - pushing. Hence to make it work, need to push the architecture - (etc) libraries onto a temporary array, then "unshift" that onto - the front of @INC. */ + SV *const libdir = mayberelocate(dir, len, flags); + /* Change 20189146be79a0596543441fa369c6bf7f85103f, to fix RT#6665, + arranged to unshift #! line -I onto the front of @INC. However, + -I can add version and architecture specific libraries, and they + need to go first. The old code assumed that it was always + pushing. Hence to make it work, need to push the architecture + (etc) libraries onto a temporary array, then "unshift" that onto + the front of @INC. */ #ifndef PERL_IS_MINIPERL - AV *const av = (using_sub_dirs) ? (unshift ? newAV() : inc) : NULL; - - /* - * BEFORE pushing libdir onto @INC we may first push version- and - * archname-specific sub-directories. - */ - if (using_sub_dirs) { - SV *subdir = newSVsv(libdir); + AV *const av = (using_sub_dirs) ? (unshift ? newAV() : inc) : NULL; + + /* + * BEFORE pushing libdir onto @INC we may first push version- and + * archname-specific sub-directories. + */ + if (using_sub_dirs) { + SV *subdir = newSVsv(libdir); #ifdef PERL_INC_VERSION_LIST - /* Configure terminates PERL_INC_VERSION_LIST with a NULL */ - const char * const incverlist[] = { PERL_INC_VERSION_LIST }; - const char * const *incver; + /* Configure terminates PERL_INC_VERSION_LIST with a NULL */ + const char * const incverlist[] = { PERL_INC_VERSION_LIST }; + const char * const *incver; #endif - if (add_versioned_sub_dirs) { - /* .../version/archname if -d .../version/archname */ - sv_catpvs(subdir, "/" PERL_FS_VERSION "/" ARCHNAME); - subdir = S_incpush_if_exists(aTHX_ av, subdir, libdir); + if (add_versioned_sub_dirs) { + /* .../version/archname if -d .../version/archname */ + sv_catpvs(subdir, "/" PERL_FS_VERSION "/" ARCHNAME); + subdir = S_incpush_if_exists(aTHX_ av, subdir, libdir); - /* .../version if -d .../version */ - sv_catpvs(subdir, "/" PERL_FS_VERSION); - subdir = S_incpush_if_exists(aTHX_ av, subdir, libdir); - } + /* .../version if -d .../version */ + sv_catpvs(subdir, "/" PERL_FS_VERSION); + subdir = S_incpush_if_exists(aTHX_ av, subdir, libdir); + } #ifdef PERL_INC_VERSION_LIST - if (addoldvers) { - for (incver = incverlist; *incver; incver++) { - /* .../xxx if -d .../xxx */ - Perl_sv_catpvf(aTHX_ subdir, "/%s", *incver); - subdir = S_incpush_if_exists(aTHX_ av, subdir, libdir); - } - } + if (addoldvers) { + for (incver = incverlist; *incver; incver++) { + /* .../xxx if -d .../xxx */ + Perl_sv_catpvf(aTHX_ subdir, "/%s", *incver); + subdir = S_incpush_if_exists(aTHX_ av, subdir, libdir); + } + } #endif - if (add_archonly_sub_dirs) { - /* .../archname if -d .../archname */ - sv_catpvs(subdir, "/" ARCHNAME); - subdir = S_incpush_if_exists(aTHX_ av, subdir, libdir); + if (add_archonly_sub_dirs) { + /* .../archname if -d .../archname */ + sv_catpvs(subdir, "/" ARCHNAME); + subdir = S_incpush_if_exists(aTHX_ av, subdir, libdir); - } + } - assert (SvREFCNT(subdir) == 1); - SvREFCNT_dec(subdir); - } + assert (SvREFCNT(subdir) == 1); + SvREFCNT_dec(subdir); + } #endif /* !PERL_IS_MINIPERL */ - /* finally add this lib directory at the end of @INC */ - if (unshift) { + /* finally add this lib directory at the end of @INC */ + if (unshift) { #ifdef PERL_IS_MINIPERL - const Size_t extra = 0; + const Size_t extra = 0; #else - Size_t extra = av_count(av); + Size_t extra = av_count(av); #endif - av_unshift(inc, extra + push_basedir); - if (push_basedir) - av_store(inc, extra, libdir); + av_unshift(inc, extra + push_basedir); + if (push_basedir) + av_store(inc, extra, libdir); #ifndef PERL_IS_MINIPERL - while (extra--) { - /* av owns a reference, av_store() expects to be donated a - reference, and av expects to be sane when it's cleared. - If I wanted to be naughty and wrong, I could peek inside the - implementation of av_clear(), realise that it uses - SvREFCNT_dec() too, so av's array could be a run of NULLs, - and so directly steal from it (with a memcpy() to inc, and - then memset() to NULL them out. But people copy code from the - core expecting it to be best practise, so let's use the API. - Although studious readers will note that I'm not checking any - return codes. */ - av_store(inc, extra, SvREFCNT_inc(*av_fetch(av, extra, FALSE))); - } - SvREFCNT_dec(av); -#endif - } - else if (push_basedir) { - av_push(inc, libdir); - } - - if (!push_basedir) { - assert (SvREFCNT(libdir) == 1); - SvREFCNT_dec(libdir); - } + while (extra--) { + /* av owns a reference, av_store() expects to be donated a + reference, and av expects to be sane when it's cleared. + If I wanted to be naughty and wrong, I could peek inside the + implementation of av_clear(), realise that it uses + SvREFCNT_dec() too, so av's array could be a run of NULLs, + and so directly steal from it (with a memcpy() to inc, and + then memset() to NULL them out. But people copy code from the + core expecting it to be best practise, so let's use the API. + Although studious readers will note that I'm not checking any + return codes. */ + av_store(inc, extra, SvREFCNT_inc(*av_fetch(av, extra, FALSE))); + } + SvREFCNT_dec(av); +#endif + } + else if (push_basedir) { + av_push(inc, libdir); + } + + if (!push_basedir) { + assert (SvREFCNT(libdir) == 1); + SvREFCNT_dec(libdir); + } } } @@ -5050,25 +5050,25 @@ S_incpush_use_sep(pTHX_ const char *p, STRLEN len, U32 flags) #ifndef PERL_RELOCATABLE_INCPUSH if (!len) #endif - len = strlen(p); + len = strlen(p); end = p + len; /* Break at all separators */ while ((s = (const char*)memchr(p, PERLLIB_SEP, end - p))) { - if (s == p) { - /* skip any consecutive separators */ + if (s == p) { + /* skip any consecutive separators */ - /* Uncomment the next line for PATH semantics */ - /* But you'll need to write tests */ - /* av_push(GvAVn(PL_incgv), newSVpvs(".")); */ - } else { - incpush(p, (STRLEN)(s - p), flags); - } - p = s + 1; + /* Uncomment the next line for PATH semantics */ + /* But you'll need to write tests */ + /* av_push(GvAVn(PL_incgv), newSVpvs(".")); */ + } else { + incpush(p, (STRLEN)(s - p), flags); + } + p = s + 1; } if (p != end) - incpush(p, (STRLEN)(end - p), flags); + incpush(p, (STRLEN)(end - p), flags); } @@ -5085,72 +5085,72 @@ Perl_call_list(pTHX_ I32 oldscope, AV *paramList) PERL_ARGS_ASSERT_CALL_LIST; while (av_count(paramList) > 0) { - cv = MUTABLE_CV(av_shift(paramList)); - if (PL_savebegin) { - if (paramList == PL_beginav) { - /* save PL_beginav for compiler */ - Perl_av_create_and_push(aTHX_ &PL_beginav_save, MUTABLE_SV(cv)); - } - else if (paramList == PL_checkav) { - /* save PL_checkav for compiler */ - Perl_av_create_and_push(aTHX_ &PL_checkav_save, MUTABLE_SV(cv)); - } - else if (paramList == PL_unitcheckav) { - /* save PL_unitcheckav for compiler */ - Perl_av_create_and_push(aTHX_ &PL_unitcheckav_save, MUTABLE_SV(cv)); - } - } else { + cv = MUTABLE_CV(av_shift(paramList)); + if (PL_savebegin) { + if (paramList == PL_beginav) { + /* save PL_beginav for compiler */ + Perl_av_create_and_push(aTHX_ &PL_beginav_save, MUTABLE_SV(cv)); + } + else if (paramList == PL_checkav) { + /* save PL_checkav for compiler */ + Perl_av_create_and_push(aTHX_ &PL_checkav_save, MUTABLE_SV(cv)); + } + else if (paramList == PL_unitcheckav) { + /* save PL_unitcheckav for compiler */ + Perl_av_create_and_push(aTHX_ &PL_unitcheckav_save, MUTABLE_SV(cv)); + } + } else { SAVEFREESV(cv); - } - JMPENV_PUSH(ret); - switch (ret) { - case 0: - CALL_LIST_BODY(cv); - atsv = ERRSV; - (void)SvPV_const(atsv, len); - if (len) { - PL_curcop = &PL_compiling; - CopLINE_set(PL_curcop, oldline); - if (paramList == PL_beginav) - sv_catpvs(atsv, "BEGIN failed--compilation aborted"); - else - Perl_sv_catpvf(aTHX_ atsv, - "%s failed--call queue aborted", - paramList == PL_checkav ? "CHECK" - : paramList == PL_initav ? "INIT" - : paramList == PL_unitcheckav ? "UNITCHECK" - : "END"); - while (PL_scopestack_ix > oldscope) - LEAVE; - JMPENV_POP; - Perl_croak(aTHX_ "%" SVf, SVfARG(atsv)); - } - break; - case 1: - STATUS_ALL_FAILURE; - /* FALLTHROUGH */ - case 2: - /* my_exit() was called */ - while (PL_scopestack_ix > oldscope) - LEAVE; - FREETMPS; - SET_CURSTASH(PL_defstash); - PL_curcop = &PL_compiling; - CopLINE_set(PL_curcop, oldline); - JMPENV_POP; - my_exit_jump(); - NOT_REACHED; /* NOTREACHED */ - case 3: - if (PL_restartop) { - PL_curcop = &PL_compiling; - CopLINE_set(PL_curcop, oldline); - JMPENV_JUMP(3); - } - PerlIO_printf(Perl_error_log, "panic: restartop in call_list\n"); - FREETMPS; - break; - } - JMPENV_POP; + } + JMPENV_PUSH(ret); + switch (ret) { + case 0: + CALL_LIST_BODY(cv); + atsv = ERRSV; + (void)SvPV_const(atsv, len); + if (len) { + PL_curcop = &PL_compiling; + CopLINE_set(PL_curcop, oldline); + if (paramList == PL_beginav) + sv_catpvs(atsv, "BEGIN failed--compilation aborted"); + else + Perl_sv_catpvf(aTHX_ atsv, + "%s failed--call queue aborted", + paramList == PL_checkav ? "CHECK" + : paramList == PL_initav ? "INIT" + : paramList == PL_unitcheckav ? "UNITCHECK" + : "END"); + while (PL_scopestack_ix > oldscope) + LEAVE; + JMPENV_POP; + Perl_croak(aTHX_ "%" SVf, SVfARG(atsv)); + } + break; + case 1: + STATUS_ALL_FAILURE; + /* FALLTHROUGH */ + case 2: + /* my_exit() was called */ + while (PL_scopestack_ix > oldscope) + LEAVE; + FREETMPS; + SET_CURSTASH(PL_defstash); + PL_curcop = &PL_compiling; + CopLINE_set(PL_curcop, oldline); + JMPENV_POP; + my_exit_jump(); + NOT_REACHED; /* NOTREACHED */ + case 3: + if (PL_restartop) { + PL_curcop = &PL_compiling; + CopLINE_set(PL_curcop, oldline); + JMPENV_JUMP(3); + } + PerlIO_printf(Perl_error_log, "panic: restartop in call_list\n"); + FREETMPS; + break; + } + JMPENV_POP; } } @@ -5167,23 +5167,23 @@ void Perl_my_exit(pTHX_ U32 status) { if (PL_exit_flags & PERL_EXIT_ABORT) { - abort(); + abort(); } if (PL_exit_flags & PERL_EXIT_WARN) { - PL_exit_flags |= PERL_EXIT_ABORT; /* Protect against reentrant calls */ - Perl_warn(aTHX_ "Unexpected exit %lu", (unsigned long)status); - PL_exit_flags &= ~PERL_EXIT_ABORT; + PL_exit_flags |= PERL_EXIT_ABORT; /* Protect against reentrant calls */ + Perl_warn(aTHX_ "Unexpected exit %lu", (unsigned long)status); + PL_exit_flags &= ~PERL_EXIT_ABORT; } switch (status) { case 0: - STATUS_ALL_SUCCESS; - break; + STATUS_ALL_SUCCESS; + break; case 1: - STATUS_ALL_FAILURE; - break; + STATUS_ALL_FAILURE; + break; default: - STATUS_EXIT_SET(status); - break; + STATUS_EXIT_SET(status); + break; } my_exit_jump(); } @@ -5204,80 +5204,80 @@ Perl_my_failure_exit(pTHX) /* According to the die_exit.t tests, if errno is non-zero */ /* It should be used for the error status. */ - if (errno == EVMSERR) { - STATUS_NATIVE = vaxc$errno; - } else { + if (errno == EVMSERR) { + STATUS_NATIVE = vaxc$errno; + } else { /* According to die_exit.t tests, if the child_exit code is */ /* also zero, then we need to exit with a code of 255 */ if ((errno != 0) && (errno < 256)) - STATUS_UNIX_EXIT_SET(errno); + STATUS_UNIX_EXIT_SET(errno); else if (STATUS_UNIX < 255) { - STATUS_UNIX_EXIT_SET(255); + STATUS_UNIX_EXIT_SET(255); } - } - - /* The exit code could have been set by $? or vmsish which - * means that it may not have fatal set. So convert - * success/warning codes to fatal with out changing - * the POSIX status code. The severity makes VMS native - * status handling work, while UNIX mode programs use the - * POSIX exit codes. - */ - if ((STATUS_NATIVE & (STS$K_SEVERE|STS$K_ERROR)) == 0) { - STATUS_NATIVE &= STS$M_COND_ID; - STATUS_NATIVE |= STS$K_ERROR | STS$M_INHIB_MSG; + } + + /* The exit code could have been set by $? or vmsish which + * means that it may not have fatal set. So convert + * success/warning codes to fatal with out changing + * the POSIX status code. The severity makes VMS native + * status handling work, while UNIX mode programs use the + * POSIX exit codes. + */ + if ((STATUS_NATIVE & (STS$K_SEVERE|STS$K_ERROR)) == 0) { + STATUS_NATIVE &= STS$M_COND_ID; + STATUS_NATIVE |= STS$K_ERROR | STS$M_INHIB_MSG; } } else { - /* 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; - } - } + /* 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; int eno = errno; if (eno & 255) - STATUS_UNIX_SET(eno); + STATUS_UNIX_SET(eno); else { - exitstatus = STATUS_UNIX >> 8; - if (exitstatus & 255) - STATUS_UNIX_SET(exitstatus); - else - STATUS_UNIX_SET(255); + exitstatus = STATUS_UNIX >> 8; + if (exitstatus & 255) + STATUS_UNIX_SET(exitstatus); + else + STATUS_UNIX_SET(255); } #endif if (PL_exit_flags & PERL_EXIT_ABORT) { - abort(); + abort(); } if (PL_exit_flags & PERL_EXIT_WARN) { - PL_exit_flags |= PERL_EXIT_ABORT; /* Protect against reentrant calls */ - Perl_warn(aTHX_ "Unexpected exit failure %ld", (long)PL_statusvalue); - PL_exit_flags &= ~PERL_EXIT_ABORT; + PL_exit_flags |= PERL_EXIT_ABORT; /* Protect against reentrant calls */ + Perl_warn(aTHX_ "Unexpected exit failure %ld", (long)PL_statusvalue); + PL_exit_flags &= ~PERL_EXIT_ABORT; } my_exit_jump(); } @@ -5286,8 +5286,8 @@ STATIC void S_my_exit_jump(pTHX) { if (PL_e_script) { - SvREFCNT_dec(PL_e_script); - PL_e_script = NULL; + SvREFCNT_dec(PL_e_script); + PL_e_script = NULL; } POPSTACK_TO(PL_mainstack); @@ -5312,8 +5312,8 @@ read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen) nl = (nl) ? nl+1 : e; if (nl-p == 0) { - filter_del(read_e_script); - return 0; + filter_del(read_e_script); + return 0; } sv_catpvn(buf_sv, p, nl-p); sv_chop(PL_e_script, nl); @@ -5325,7 +5325,7 @@ void Perl_xs_boot_epilog(pTHX_ const I32 ax) { if (PL_unitcheckav) - call_list(PL_scopestack_ix, PL_unitcheckav); + call_list(PL_scopestack_ix, PL_unitcheckav); XSRETURN_YES; } |