#include <unistd.h>
#endif
+#ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
+# ifdef I_SYS_WAIT
+# include <sys/wait.h>
+# endif
+# ifdef I_SYSUIO
+# include <sys/uio.h>
+# endif
+
+union control_un {
+ struct cmsghdr cm;
+ char control[CMSG_SPACE(sizeof(int))];
+};
+
+#endif
+
#ifdef __BEOS__
# define HZ 1000000
#endif
perl_construct(pTHXx)
{
dVAR;
+ PERL_UNUSED_ARG(my_perl);
#ifdef MULTIPLICITY
init_interp();
PL_perl_destruct_level = 1;
if ((long) PL_mmap_page_size < 0) {
if (errno) {
SV *error = ERRSV;
- char *msg;
- STRLEN n_a;
(void) SvUPGRADE(error, SVt_PV);
- msg = SvPVx(error, n_a);
- Perl_croak(aTHX_ "panic: sysconf: %s", msg);
+ Perl_croak(aTHX_ "panic: sysconf: %s", SvPV_nolen_const(error));
}
else
Perl_croak(aTHX_ "panic: sysconf: pagesize unknown");
return 0;
}
+#ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
+void
+Perl_dump_sv_child(pTHX_ SV *sv)
+{
+ ssize_t got;
+ const int sock = PL_dumper_fd;
+ const int debug_fd = PerlIO_fileno(Perl_debug_log);
+ union control_un control;
+ struct msghdr msg;
+ struct iovec vec[2];
+ struct cmsghdr *cmptr;
+ int returned_errno;
+ unsigned char buffer[256];
+
+ if(sock == -1 || debug_fd == -1)
+ return;
+
+ PerlIO_flush(Perl_debug_log);
+
+ /* All these shenanigans are to pass a file descriptor over to our child for
+ it to dump out to. We can't let it hold open the file descriptor when it
+ forks, as the file descriptor it will dump to can turn out to be one end
+ of pipe that some other process will wait on for EOF. (So as it would
+ be open, the wait would be forever. */
+
+ msg.msg_control = control.control;
+ msg.msg_controllen = sizeof(control.control);
+ /* We're a connected socket so we don't need a destination */
+ msg.msg_name = NULL;
+ msg.msg_namelen = 0;
+ msg.msg_iov = vec;
+ msg.msg_iovlen = 1;
+
+ cmptr = CMSG_FIRSTHDR(&msg);
+ cmptr->cmsg_len = CMSG_LEN(sizeof(int));
+ cmptr->cmsg_level = SOL_SOCKET;
+ cmptr->cmsg_type = SCM_RIGHTS;
+ *((int *)CMSG_DATA(cmptr)) = 1;
+
+ vec[0].iov_base = (void*)&sv;
+ vec[0].iov_len = sizeof(sv);
+ got = sendmsg(sock, &msg, 0);
+
+ if(got < 0) {
+ perror("Debug leaking scalars parent sendmsg failed");
+ abort();
+ }
+ if(got < sizeof(sv)) {
+ perror("Debug leaking scalars parent short sendmsg");
+ abort();
+ }
+
+ /* Return protocol is
+ int: errno value
+ unsigned char: length of location string (0 for empty)
+ unsigned char*: string (not terminated)
+ */
+ vec[0].iov_base = (void*)&returned_errno;
+ vec[0].iov_len = sizeof(returned_errno);
+ vec[1].iov_base = buffer;
+ vec[1].iov_len = 1;
+
+ got = readv(sock, vec, 2);
+
+ if(got < 0) {
+ perror("Debug leaking scalars parent read failed");
+ PerlIO_flush(PerlIO_stderr());
+ abort();
+ }
+ if(got < sizeof(returned_errno) + 1) {
+ perror("Debug leaking scalars parent short read");
+ PerlIO_flush(PerlIO_stderr());
+ abort();
+ }
+
+ if (*buffer) {
+ got = read(sock, buffer + 1, *buffer);
+ if(got < 0) {
+ perror("Debug leaking scalars parent read 2 failed");
+ PerlIO_flush(PerlIO_stderr());
+ abort();
+ }
+
+ if(got < *buffer) {
+ perror("Debug leaking scalars parent short read 2");
+ PerlIO_flush(PerlIO_stderr());
+ abort();
+ }
+ }
+
+ if (returned_errno || *buffer) {
+ Perl_warn(aTHX_ "Debug leaking scalars child failed%s%.*s with errno"
+ " %d: %s", (*buffer ? " at " : ""), (int) *buffer, buffer + 1,
+ returned_errno, strerror(returned_errno));
+ }
+}
+#endif
+
/*
=for apidoc perl_destruct
dVAR;
volatile int destruct_level; /* 0=none, 1=full, 2=full with checks */
HV *hv;
+#ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
+ pid_t child;
+#endif
+
+ PERL_UNUSED_ARG(my_perl);
/* wait for all pseudo-forked children to finish */
PERL_WAIT_FOR_CHILDREN;
destruct_level = PL_perl_destruct_level;
#ifdef DEBUGGING
{
- const char *s;
- if ((s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL"))) {
+ const char * const s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL");
+ if (s) {
const int i = atoi(s);
if (destruct_level < i)
destruct_level = i;
int x = 0;
JMPENV_PUSH(x);
+ PERL_UNUSED_VAR(x);
if (PL_endav && !PL_minus_c)
call_list(PL_scopestack_ix, PL_endav);
JMPENV_POP;
return STATUS_NATIVE_EXPORT;
}
+#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(socketpair(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];
+
+ 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 = sizeof(vec)/sizeof(vec[0]);
+
+ vec[0].iov_base = (void*)⌖
+ vec[0].iov_len = sizeof(target);
+
+ got = recvmsg(sock, &msg, 0);
+
+ if(got == 0)
+ break;
+ if(got < 0) {
+ 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 (dup2(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 */
+ /* Do this now, because destroying ops can cause new SVs to be generated
+ in Perl_pad_swipe, and when running with -DDEBUG_LEAKING_SCALARS they
+ PL_curcop to point to a valid 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)) {
op_free(PL_main_root);
PL_main_root = Nullop;
}
- PL_curcop = &PL_compiling;
PL_main_start = Nullop;
SvREFCNT_dec(PL_main_cv);
PL_main_cv = Nullcv;
{
/* 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;
- I32 max;
- HE *hent;
- HE **array;
-
- riter = 0;
- max = HvMAX(PL_strtab);
- array = HvARRAY(PL_strtab);
- hent = array[0];
+ I32 riter = 0;
+ const I32 max = HvMAX(PL_strtab);
+ HE **array = HvARRAY(PL_strtab);
+ HE *hent = array[0];
+
for (;;) {
if (hent && ckWARN_d(WARN_INTERNAL)) {
+ HE *next = HeNEXT(hent);
Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
"Unbalanced string table refcount: (%d) for \"%s\"",
HeVAL(hent) - Nullsv, HeKEY(hent));
- HeVAL(hent) = Nullsv;
- hent = HeNEXT(hent);
+ Safefree(hent);
+ hent = next;
}
if (!hent) {
if (++riter > max)
hent = array[riter];
}
}
+
+ Safefree(array);
+ HvARRAY(PL_strtab) = 0;
+ HvTOTALKEYS(PL_strtab) = 0;
+ HvFILL(PL_strtab) = 0;
}
SvREFCNT_dec(PL_strtab);
/* free the pointer tables used for cloning */
ptr_table_free(PL_ptr_table);
PL_ptr_table = (PTR_TBL_t*)NULL;
- ptr_table_free(PL_shared_hek_table);
- PL_shared_hek_table = (PTR_TBL_t*)NULL;
#endif
/* free special SVs */
PL_op_name[sv->sv_debug_optype]: "(none)",
sv->sv_debug_cloned ? " (cloned)" : ""
);
+#ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
+ 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;
+
+ 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
PL_sv_count = 0;
Safefree(PL_psig_pend);
PL_psig_pend = (int*)NULL;
PL_formfeed = Nullsv;
- Safefree(PL_ofmt);
- PL_ofmt = Nullch;
nuke_stacks();
PL_tainting = FALSE;
PL_taint_warn = FALSE;
int ret;
dJMPENV;
+ PERL_UNUSED_VAR(my_perl);
+
#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
#ifdef IAMSUID
#undef IAMSUID
if (!PL_rehash_seed_set)
PL_rehash_seed = get_hash_seed();
{
- char *s = PerlEnv_getenv("PERL_HASH_SEED_DEBUG");
+ const char * const s = PerlEnv_getenv("PERL_HASH_SEED_DEBUG");
- if (s) {
- int i = atoi(s);
-
- if (i == 1)
- PerlIO_printf(Perl_debug_log, "HASH_SEED = %"UVuf"\n",
- PL_rehash_seed);
- }
+ if (s && (atoi(s) == 1))
+ PerlIO_printf(Perl_debug_log, "HASH_SEED = %"UVuf"\n", PL_rehash_seed);
}
#endif /* #if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT) */
* --jhi */
const char *s = NULL;
int i;
- UV mask =
+ const UV mask =
~(UV)(PTRSIZE == 4 ? 3 : PTRSIZE == 8 ? 7 : PTRSIZE == 16 ? 15 : 0);
/* Do the mask check only if the args seem like aligned. */
- UV aligned =
+ const UV aligned =
(mask < ~(UV)0) && ((PTR2UV(argv[0]) & mask) == PTR2UV(argv[0]));
/* See if all the arguments are contiguous in memory. Note
register SV *sv;
register char *s;
const char *cddir = Nullch;
+#ifdef USE_SITECUSTOMIZE
bool minus_f = FALSE;
+#endif
PL_fdscript = -1;
PL_suidscript = -1;
break;
case 'f':
+#ifdef USE_SITECUSTOMIZE
minus_f = TRUE;
+#endif
s++;
goto reswitch;
int ret = 0;
dJMPENV;
+ PERL_UNUSED_ARG(my_perl);
+
oldscope = PL_scopestack_ix;
#ifdef VMS
VMSISH_HUSHED = 0;
POPEVAL(cx);
PL_curpm = newpm;
LEAVE;
+ PERL_UNUSED_VAR(newsp);
+ PERL_UNUSED_VAR(gimme);
+ PERL_UNUSED_VAR(optype);
}
JMPENV_POP;
}
PUTBACK;
if (croak_on_error && SvTRUE(ERRSV)) {
- STRLEN n_a;
- Perl_croak(aTHX_ SvPVx(ERRSV, n_a));
+ Perl_croak(aTHX_ SvPVx_nolen_const(ERRSV));
}
return sv;
* Removed -h because the user already knows that option. Others? */
static const char * const usage_msg[] = {
-"-0[octal] specify record separator (\\0, if no argument)",
-"-A[name] activate all/given assertions",
-"-a autosplit mode with -n or -p (splits $_ into @F)",
-"-C[number/list] enables the listed Unicode features",
-"-c check syntax only (runs BEGIN and CHECK blocks)",
-"-d[:debugger] run program under debugger",
-"-D[number/list] set debugging flags (argument is a bit mask or alphabets)",
-"-e program one line of program (several -e's allowed, omit programfile)",
-#ifdef USE_SITECUSTOMIZE
-"-f don't do $sitelib/sitecustomize.pl at startup",
-#endif
-"-F/pattern/ split() pattern for -a switch (//'s are optional)",
-"-i[extension] edit <> files in place (makes backup if extension supplied)",
-"-Idirectory specify @INC/#include directory (several -I's allowed)",
-"-l[octal] enable line ending processing, specifies line terminator",
-"-[mM][-]module execute \"use/no module...\" before executing program",
-"-n assume \"while (<>) { ... }\" loop around program",
-"-p assume loop like -n but print line also, like sed",
-"-P run program through C preprocessor before compilation",
-"-s enable rudimentary parsing for switches after programfile",
-"-S look for programfile using PATH environment variable",
-"-t enable tainting warnings",
-"-T enable tainting checks",
-"-u dump core after parsing program",
-"-U allow unsafe operations",
-"-v print version, subversion (includes VERY IMPORTANT perl info)",
-"-V[:variable] print configuration summary (or a single Config.pm variable)",
-"-w enable many useful warnings (RECOMMENDED)",
-"-W enable all warnings",
-"-x[directory] strip off text before #!perl line and perhaps cd to directory",
-"-X disable all warnings",
+"-0[octal] specify record separator (\\0, if no argument)",
+"-A[mod][=pattern] activate all/given assertions",
+"-a autosplit mode with -n or -p (splits $_ into @F)",
+"-C[number/list] enables the listed Unicode features",
+"-c check syntax only (runs BEGIN and CHECK blocks)",
+"-d[:debugger] run program under debugger",
+"-D[number/list] set debugging flags (argument is a bit mask or alphabets)",
+"-e program one line of program (several -e's allowed, omit programfile)",
+"-f don't do $sitelib/sitecustomize.pl at startup",
+"-F/pattern/ split() pattern for -a switch (//'s are optional)",
+"-i[extension] edit <> files in place (makes backup if extension supplied)",
+"-Idirectory specify @INC/#include directory (several -I's allowed)",
+"-l[octal] enable line ending processing, specifies line terminator",
+"-[mM][-]module execute \"use/no module...\" before executing program",
+"-n assume \"while (<>) { ... }\" loop around program",
+"-p assume loop like -n but print line also, like sed",
+"-P run program through C preprocessor before compilation",
+"-s enable rudimentary parsing for switches after programfile",
+"-S look for programfile using PATH environment variable",
+"-t enable tainting warnings",
+"-T enable tainting checks",
+"-u dump core after parsing program",
+"-U allow unsafe operations",
+"-v print version, subversion (includes VERY IMPORTANT perl info)",
+"-V[:variable] print configuration summary (or a single Config.pm variable)",
+"-w enable many useful warnings (RECOMMENDED)",
+"-W enable all warnings",
+"-x[directory] strip off text before #!perl line and perhaps cd to directory",
+"-X disable all warnings",
"\n",
NULL
};
"Recompile perl with -DDEBUGGING to use -D switch (did you mean -d ?)\n");
for (s++; isALNUM(*s); s++) ;
#endif
- /*SUPPRESS 530*/
return s;
}
case 'h':
}
#endif /* __CYGWIN__ */
PL_inplace = savepv(s+1);
- /*SUPPRESS 530*/
- for (s = PL_inplace; *s && !isSPACE(*s); s++) ;
+ for (s = PL_inplace; *s && !isSPACE(*s); s++)
+ ;
if (*s) {
*s++ = '\0';
if (*s == '-') /* Additional switches on #! line. */
forbid_setid("-A");
if (!PL_preambleav)
PL_preambleav = newAV();
- if (*++s) {
- SV *sv = newSVpv("use assertions::activate split(/,/,q", 0);
- sv_catpvn(sv, "\0", 1); /* Use NUL as q//-delimiter. */
- sv_catpv(sv,s);
- sv_catpvn(sv, "\0)", 2);
- s+=strlen(s);
+ s++;
+ {
+ char *start = s;
+ SV *sv = newSVpv("use assertions::activate", 24);
+ while(isALNUM(*s) || *s == ':') ++s;
+ if (s != start) {
+ sv_catpvn(sv, "::", 2);
+ sv_catpvn(sv, start, s-start);
+ }
+ if (*s == '=') {
+ sv_catpvn(sv, " split(/,/,q\0", 13);
+ sv_catpv(sv, s+1);
+ sv_catpvn(sv, "\0)", 2);
+ s+=strlen(s);
+ }
+ else if (*s != '\0') {
+ Perl_croak(aTHX_ "Can't use '%c' after -A%.*s", *s, s-start, start);
+ }
av_push(PL_preambleav, sv);
+ return s;
}
- else
- av_push(PL_preambleav, newSVpvn("use assertions::activate",24));
- return s;
case 'M':
forbid_setid("-M"); /* XXX ? */
/* FALL THROUGH */
(void *)upg_version(PL_patchlevel);
#if !defined(DGUX)
PerlIO_printf(PerlIO_stdout(),
- Perl_form(aTHX_ "\nThis is perl, v%"SVf" built for %s",
+ Perl_form(aTHX_ "\nThis is perl, %"SVf" built for %s",
vstringify(PL_patchlevel),
ARCHNAME));
#else /* DGUX */
/* Adjust verbose output as in the perl that ships with the DG/UX OS from EMC */
PerlIO_printf(PerlIO_stdout(),
- Perl_form(aTHX_ "\nThis is perl, v%"SVf"\n",
+ Perl_form(aTHX_ "\nThis is perl, %"SVf"\n",
vstringify(PL_patchlevel)));
PerlIO_printf(PerlIO_stdout(),
Perl_form(aTHX_ " built under %s at %s %s\n",
DEBUG_P(PerlIO_printf(Perl_debug_log,
"PL_preprocess: scriptname=\"%s\", cpp=\"%s\", sv=\"%s\", CPPMINUS=\"%s\"\n",
- scriptname, SvPVX (cpp), SvPVX (sv), CPPMINUS));
+ scriptname, SvPVX_const (cpp), SvPVX_const (sv),
+ CPPMINUS));
# if defined(MSDOS) || defined(WIN32) || defined(VMS)
quote = "\"";
DEBUG_P(PerlIO_printf(Perl_debug_log,
"PL_preprocess: cmd=\"%s\"\n",
- SvPVX(cmd)));
+ SvPVX_const(cmd)));
- PL_rsfp = PerlProc_popen(SvPVX(cmd), (char *)"r");
+ PL_rsfp = PerlProc_popen((char *)SvPVX_const(cmd), (char *)"r");
SvREFCNT_dec(cmd);
SvREFCNT_dec(cpp);
}
*/
#ifdef DOSUID
- char *s, *s2;
+ const char *s, *s2;
if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0) /* normal stat is insecure */
Perl_croak(aTHX_ "Can't stat script \"%s\"",PL_origfilename);
if (PL_statbuf.st_mode & (S_ISUID|S_ISGID)) {
I32 len;
- STRLEN n_a;
+ const char *linestr;
#ifdef IAMSUID
if (PL_fdscript < 0 || PL_suidscript != 1)
PL_doswitches = FALSE; /* -s is insecure in suid */
/* PSz 13 Nov 03 But -s was caught elsewhere ... so unsetting it here is useless(?!) */
CopLINE_inc(PL_curcop);
+ linestr = SvPV_nolen_const(PL_linestr);
if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch ||
- strnNE(SvPV(PL_linestr,n_a),"#!",2) ) /* required even on Sys V */
+ strnNE(linestr,"#!",2) ) /* required even on Sys V */
Perl_croak(aTHX_ "No #! line");
- s = SvPV(PL_linestr,n_a)+2;
+ linestr+=2;
+ s = linestr;
/* PSz 27 Feb 04 */
/* Sanity check on line length */
if (strlen(s) < 1 || strlen(s) > 4000)
while (isSPACE(*s)) s++;
/* Sanity check on buffer end */
while ((*s) && !isSPACE(*s)) s++;
- for (s2 = s; (s2 > SvPV(PL_linestr,n_a)+2 &&
+ for (s2 = s; (s2 > linestr &&
(isDIGIT(s2[-1]) || s2[-1] == '.' || s2[-1] == '_'
|| s2[-1] == '-')); s2--) ;
/* Sanity check on buffer start */
- if ( (s2-4 < SvPV(PL_linestr,n_a)+2 || strnNE(s2-4,"perl",4)) &&
- (s-9 < SvPV(PL_linestr,n_a)+2 || strnNE(s-9,"perl",4)) )
+ if ( (s2-4 < linestr || strnNE(s2-4,"perl",4)) &&
+ (s-9 < linestr || strnNE(s-9,"perl",4)) )
Perl_croak(aTHX_ "Not a perl script");
while (*s == ' ' || *s == '\t') s++;
/*
while (isDIGIT(s2[-1]) || s2[-1] == '-' || s2[-1] == '.'
|| s2[-1] == '_') s2--;
if (strnEQ(s2-4,"perl",4))
- /*SUPPRESS 530*/
while ((s = moreswitches(s)))
;
}
S_incpush_if_exists(pTHX_ SV *dir)
{
Stat_t tmpstatbuf;
- if (PerlLIO_stat(SvPVX(dir), &tmpstatbuf) >= 0 &&
+ if (PerlLIO_stat(SvPVX_const(dir), &tmpstatbuf) >= 0 &&
S_ISDIR(tmpstatbuf.st_mode)) {
av_push(GvAVn(PL_incgv), dir);
dir = NEWSV(0,0);
}
JMPENV_JUMP(2);
+ PERL_UNUSED_VAR(gimme);
+ PERL_UNUSED_VAR(newsp);
}
static I32
read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen)
{
- char *p, *nl;
- (void)idx;
- (void)maxlen;
+ const char * const p = SvPVX_const(PL_e_script);
+ const char *nl = strchr(p, '\n');
+
+ PERL_UNUSED_ARG(idx);
+ PERL_UNUSED_ARG(maxlen);
- p = SvPVX(PL_e_script);
- nl = strchr(p, '\n');
nl = (nl) ? nl+1 : SvEND(PL_e_script);
if (nl-p == 0) {
filter_del(read_e_script);