("__environ", (unsigned long *) &environ_pointer, NULL);
#endif /* environ */
-#ifdef USE_ENVIRON_ARRAY
+#ifndef PERL_MICRO
+# ifdef USE_ENVIRON_ARRAY
PL_origenviron = environ;
+# endif
#endif
/* Use sysconf(_SC_CLK_TCK) if available, if not
/* Destroy the main CV and syntax tree */
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);
+ }
op_free(PL_main_root);
PL_main_root = Nullop;
}
* Non-referenced objects are on their own.
*/
sv_clean_objs();
+ PL_sv_objcount = 0;
}
/* unhook hooks which will soon be, or use, destroyed data */
/* if PERL_USE_SAFE_PUTENV is defined environ will not have been copied
* so we certainly shouldn't free it here
*/
+#ifndef PERL_MICRO
#if defined(USE_ENVIRON_ARRAY) && !defined(PERL_USE_SAFE_PUTENV)
if (environ != PL_origenviron
#ifdef USE_ITHREADS
environ = PL_origenviron;
}
#endif
+#endif /* !PERL_MICRO */
#ifdef USE_ITHREADS
/* the syntax tree is shared between clones
PL_e_script = Nullsv;
}
+ PL_perldb = 0;
+
/* magical thingies */
SvREFCNT_dec(PL_ofs_sv); /* $, */
PL_stderrgv = Nullgv;
PL_last_in_gv = Nullgv;
PL_replgv = Nullgv;
+ PL_DBgv = Nullgv;
+ PL_DBline = Nullgv;
+ PL_DBsub = Nullgv;
+ PL_DBsingle = Nullsv;
+ PL_DBtrace = Nullsv;
+ PL_DBsignal = Nullsv;
+ PL_DBassertion = Nullsv;
+ PL_DBcv = Nullcv;
+ PL_dbargs = Nullav;
PL_debstash = Nullhv;
/* reset so print() ends up where we expect */
Safefree(PL_numeric_name);
PL_numeric_name = Nullch;
SvREFCNT_dec(PL_numeric_radix_sv);
+ PL_numeric_radix_sv = Nullsv;
#endif
/* clear utf8 character classes */
#ifdef USE_ITHREADS
/* free the pointer table used for cloning */
ptr_table_free(PL_ptr_table);
+ PL_ptr_table = (PTR_TBL_t*)NULL;
#endif
/* free special SVs */
}
}
#endif
+ PL_sv_count = 0;
#if defined(PERLIO_LAYERS)
SvREFCNT(&PL_sv_undef) = 0;
SvREADONLY_off(&PL_sv_undef);
- SvREFCNT(&PL_sv_placeholder) = 0;
- SvREADONLY_off(&PL_sv_placeholder);
-
Safefree(PL_origfilename);
+ PL_origfilename = Nullch;
Safefree(PL_reg_start_tmp);
+ PL_reg_start_tmp = (char**)NULL;
+ PL_reg_start_tmpl = 0;
if (PL_reg_curpm)
Safefree(PL_reg_curpm);
Safefree(PL_reg_poscache);
free_tied_hv_pool();
Safefree(PL_op_mask);
Safefree(PL_psig_ptr);
+ PL_psig_ptr = (SV**)NULL;
Safefree(PL_psig_name);
+ PL_psig_name = (SV**)NULL;
Safefree(PL_bitcount);
+ PL_bitcount = Nullch;
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;
PL_hints = 0; /* Reset hints. Should hints be per-interpreter ? */
+ PL_debug = 0;
DEBUG_P(debprofdump());
#if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT)
/* [perl #22371] Algorimic Complexity Attack on Perl 5.6.1, 5.8.0
* This MUST be done before any hash stores or fetches take place.
- * If you set PL_hash_seed (and assumedly also PL_hash_seed_set) yourself,
- * it is your responsibility to provide a good random seed!
+ * If you set PL_rehash_seed (and assumedly also PL_rehash_seed_set)
+ * yourself, it is your responsibility to provide a good random seed!
* You can also define PERL_HASH_SEED in compile time, see hv.h. */
- if (!PL_hash_seed_set)
- PL_hash_seed = get_hash_seed();
+ if (!PL_rehash_seed_set)
+ PL_rehash_seed = get_hash_seed();
{
char *s = PerlEnv_getenv("PERL_HASH_SEED_DEBUG");
if (i == 1)
PerlIO_printf(Perl_debug_log, "HASH_SEED = %"UVuf"\n",
- PL_hash_seed);
+ PL_rehash_seed);
}
}
#endif /* #if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT) */
{
/* 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:mg_set()
+ * 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.)
}
}
}
- PL_origalen = s - PL_origargv[0];
+ PL_origalen = s - PL_origargv[0] + 1;
}
if (PL_do_undump) {
}
}
switch_end:
- sv_setsv(get_sv("/", TRUE), PL_rs);
if (
#ifndef SECURE_INTERNAL_GETENV
boot_core_PerlIO();
boot_core_UNIVERSAL();
-#ifndef PERL_MICRO
boot_core_xsutils();
-#endif
if (xsinit)
(*xsinit)(aTHX); /* in case linked C routines want magical variables */
if (!PL_restartop) {
DEBUG_x(dump_all());
- DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
+ if (!DEBUG_q_TEST)
+ PERL_DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
DEBUG_S(PerlIO_printf(Perl_debug_log, "main thread is 0x%"UVxf"\n",
PTR2UV(thr)));
static char *usage_msg[] = {
"-0[octal] specify record separator (\\0, if no argument)",
"-a autosplit mode with -n or -p (splits $_ into @F)",
-"-C enable native wide character system interfaces",
+"-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 'command' one line of program (several -e's allowed, omit programfile)",
+"-e program one line of program (several -e's allowed, omit programfile)",
"-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)",
"-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 checks",
"-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 disable all warnings",
"-x[directory] strip off text before #!perl line and perhaps cd to directory",
+"-X disable all warnings",
"\n",
NULL
};
int i = 0;
if (isALPHA(**s)) {
/* if adding extra options, remember to update DEBUG_MASK */
- static char debopts[] = "psltocPmfrxu HXDSTRJvC";
+ static char debopts[] = "psltocPmfrxu HXDSTRJvCAq";
for (; isALNUM(**s); (*s)++) {
char *d = strchr(debopts,**s);
PL_rs = newSVpvn(&ch, 1);
}
}
+ sv_setsv(get_sv("/", TRUE), PL_rs);
return s + numlen;
}
case 'C':
sv_catpvn(sv, start, s-start);
sv_catpv(sv, " split(/,/,q{");
sv_catpv(sv, ++s);
- sv_catpv(sv, "})");
+ sv_catpv(sv, "})");
}
s += strlen(s);
my_setenv("PERL5DB", SvPV(sv, PL_na));
if (!PL_preambleav)
PL_preambleav = newAV();
if (*++s) {
- SV *sv = newSVpvn("use assertions::activate split(/,/,q{",37);
+ SV *sv = newSVpv("use assertions::activate split(/,/,q", 0);
+ sv_catpvn(sv, "\0", 1); /* Use NUL as q//-delimiter. */
sv_catpv(sv,s);
- sv_catpv(sv,"})");
+ sv_catpvn(sv, "\0)", 2);
s+=strlen(s);
av_push(PL_preambleav, sv);
}
Perl_croak(aTHX_ "Module name required with -%c option",
s[-1]);
sv_catpvn(sv, start, s-start);
- sv_catpv(sv, " split(/,/,q{");
+ sv_catpv(sv, " split(/,/,q");
+ sv_catpvn(sv, "\0)", 1); /* Use NUL as q//-delimiter. */
sv_catpv(sv, ++s);
- sv_catpv(sv, "})");
+ sv_catpvn(sv, "\0)", 2);
}
s += strlen(s);
if (!PL_preambleav)
SV *cpp = newSVpvn("",0);
SV *cmd = NEWSV(0,0);
+ if (cpp_cfg[0] == 0) /* PERL_MICRO? */
+ Perl_croak(aTHX_ "Can't run with cpp -P with CPPSTDIN undefined");
if (strEQ(cpp_cfg, "cppstdin"))
Perl_sv_catpvf(aTHX_ cpp, "%s/", BIN_EXP);
sv_catpv(cpp, cpp_cfg);
# endif
# ifdef IAMSUID
errno = EPERM;
- Perl_croak(aTHX_ "Can't open perl script: %s\n",
- Strerror(errno));
+ Perl_croak(aTHX_ "Permission denied\n");
# else
Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
CopFILE(PL_curcop), Strerror(errno));
* But I don't think it's too important. The manual lies when
* it says access() is useful in setuid programs.
*/
- if (PerlLIO_access(CopFILE(PL_curcop),1)) /*double check*/
- Perl_croak(aTHX_ "Permission denied");
+ if (PerlLIO_access(CopFILE(PL_curcop),1)) { /*double check*/
+ errno = EPERM;
+ Perl_croak(aTHX_ "Permission denied\n");
+ }
#else
/* If we can swap euid and uid, then we can determine access rights
* with a simple stat of the file, and then compare device and
#endif
|| PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid)
Perl_croak(aTHX_ "Can't swap uid and euid"); /* really paranoid */
- if (PerlLIO_stat(CopFILE(PL_curcop),&tmpstatbuf) < 0)
- Perl_croak(aTHX_ "Permission denied"); /* testing full pathname here */
+ if (PerlLIO_stat(CopFILE(PL_curcop),&tmpstatbuf) < 0) {
+ errno = EPERM;
+ Perl_croak(aTHX_ "Permission denied\n"); /* testing full pathname here */
+ }
#if defined(IAMSUID) && !defined(NO_NOSUID_CHECK)
- if (fd_on_nosuid_fs(PerlIO_fileno(PL_rsfp)))
- Perl_croak(aTHX_ "Permission denied");
+ if (fd_on_nosuid_fs(PerlIO_fileno(PL_rsfp))) {
+ errno = EPERM;
+ Perl_croak(aTHX_ "Permission denied\n");
+ }
#endif
if (tmpstatbuf.st_dev != PL_statbuf.st_dev ||
tmpstatbuf.st_ino != PL_statbuf.st_ino) {
(void)PerlIO_close(PL_rsfp);
+ errno = EPERM;
Perl_croak(aTHX_ "Permission denied\n");
}
if (
#endif /* HAS_SETREUID */
#endif /* IAMSUID */
- if (!S_ISREG(PL_statbuf.st_mode))
- Perl_croak(aTHX_ "Permission denied");
+ if (!S_ISREG(PL_statbuf.st_mode)) {
+ errno = EPERM;
+ Perl_croak(aTHX_ "Permission denied\n");
+ }
if (PL_statbuf.st_mode & S_IWOTH)
Perl_croak(aTHX_ "Setuid/gid script is writable by world");
PL_doswitches = FALSE; /* -s is insecure in suid */
PL_euid == PL_statbuf.st_uid)
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");
+FIX YOUR KERNEL, OR PUT A C WRAPPER AROUND THIS SCRIPT!\n");
#endif /* IAMSUID */
if (PL_euid) { /* oops, we're not the setuid root perl */
Perl_croak(aTHX_ "-P not allowed for setuid/setgid script\n");
else if (fdscript >= 0)
Perl_croak(aTHX_ "fd script not allowed in suidperl\n");
- else
- Perl_croak(aTHX_ "Script is not setuid/setgid in suidperl\n");
+ else {
+ errno = EPERM;
+ Perl_croak(aTHX_ "Permission denied\n");
+ }
/* We absolutely must clear out any saved ids here, so we */
/* exec the real perl, substituting fd script for scriptname. */
PerlIO_rewind(PL_rsfp);
PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0); /* just in case rewind didn't */
for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ;
- if (!PL_origargv[which])
- Perl_croak(aTHX_ "Permission denied");
+ if (!PL_origargv[which]) {
+ errno = EPERM;
+ Perl_croak(aTHX_ "Permission denied\n");
+ }
PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s",
PerlIO_fileno(PL_rsfp), PL_origargv[which]));
#if defined(HAS_FCNTL) && defined(F_SETFD)
sv_setiv(PL_DBtrace, 0);
PL_DBsignal = GvSV((gv_fetchpv("DB::signal", GV_ADDMULTI, SVt_PV)));
sv_setiv(PL_DBsignal, 0);
- PL_DBassertion = GvSV((gv_fetchpv("assertion", GV_ADDMULTI, SVt_PV)));
+ PL_DBassertion = GvSV((gv_fetchpv("DB::assertion", GV_ADDMULTI, SVt_PV)));
sv_setiv(PL_DBassertion, 0);
PL_curstash = ostash;
}
GvMULTI_on(PL_envgv);
hv = GvHVn(PL_envgv);
hv_magic(hv, Nullgv, 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
for (; *env; env++) {
if (!(s = strchr(*env,'=')))
continue;
-#if defined(MSDOS)
+#if defined(MSDOS) && !defined(DJGPP)
*s = '\0';
(void)strupr(*env);
*s = '=';
mg_set(sv);
}
#endif /* USE_ENVIRON_ARRAY */
+#endif /* !PERL_MICRO */
}
TAINT_NOT;
if ((tmpgv = gv_fetchpv("$",TRUE, SVt_PV))) {
projects / p5sagit/p5-mst-13.2.git / blobdiff