{
char *s;
if ((s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL"))) {
- int i = atoi(s);
+ const int i = atoi(s);
if (destruct_level < i)
destruct_level = i;
}
if (SvTYPE(sv) != SVTYPEMASK) {
PerlIO_printf(Perl_debug_log, "leaked: sv=0x%p"
" flags=0x08%"UVxf
- " refcnt=%"UVuf pTHX__FORMAT "\n",
- sv, sv->sv_flags, sv->sv_refcnt pTHX__VALUE);
+ " refcnt=%"UVuf pTHX__FORMAT "\n"
+ "\tallocated at %s:%d %s %s%s\n",
+ sv, sv->sv_flags, 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)",
+ sv->sv_debug_cloned ? " (cloned)" : ""
+ );
}
}
}
#endif
}
+#if defined(USE_5005THREADS) || defined(USE_ITHREADS)
+/* provide destructors to clean up the thread key when libperl is unloaded */
+#ifndef WIN32 /* handled during DLL_PROCESS_DETACH in win32/perllib.c */
+
+#if defined(__hpux) && !defined(__GNUC__)
+#pragma fini "perl_fini"
+#endif
+
+#if defined(__GNUC__) && defined(__attribute__)
+/* want to make sure __attribute__ works here even
+ * for -Dd_attribut=undef builds.
+ */
+#undef __attribute__
+#endif
+
+static void __attribute__((destructor))
+perl_fini()
+{
+ if (PL_curinterp)
+ FREE_THREAD_KEY;
+}
+
+#endif /* WIN32 */
+#endif /* THREADS */
+
void
Perl_call_atexit(pTHX_ ATEXIT_t fn, void *ptr)
{
bytes of stack longer than necessary
*/
STATIC void
-S_procself_val(pTHX_ SV *sv, char *arg0)
+S_procself_val(pTHX_ SV *sv, const char *arg0)
{
char buf[MAXPATHLEN];
int len = readlink(PROCSELFEXE_PATH, buf, sizeof(buf) - 1);
* the area we are able to modify is limited to the size of
* the original argv[0]. (See below for 'contiguous', though.)
* --jhi */
- char *s = NULL;
+ const char *s = NULL;
int i;
UV mask =
~(UV)(PTRSIZE == 4 ? 3 : PTRSIZE == 8 ? 7 : PTRSIZE == 16 ? 15 : 0);
{
int argc = PL_origargc;
char **argv = PL_origargv;
- char *scriptname = NULL;
+ const char *scriptname = NULL;
VOL bool dosearch = FALSE;
- char *validarg = "";
+ const char *validarg = "";
register SV *sv;
register char *s;
- char *cddir = Nullch;
+ const char *cddir = Nullch;
+ bool minus_f = FALSE;
PL_fdscript = -1;
PL_suidscript = -1;
sv_catpv(PL_e_script, "\n");
break;
+ case 'f':
+ minus_f = TRUE;
+ s++;
+ goto reswitch;
+
case 'I': /* -I handled both here and in moreswitches() */
forbid_setid("-I");
if (!*++s && (s=argv[1]) != Nullch) {
PL_preambleav = newAV();
av_push(PL_preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
if (*++s != ':') {
+ STRLEN opts;
+
PL_Sv = newSVpv("print myconfig();",0);
#ifdef VMS
sv_catpv(PL_Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
#else
sv_catpv(PL_Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
#endif
+ opts = SvCUR(PL_Sv);
+
sv_catpv(PL_Sv,"\" Compile-time options:");
# ifdef DEBUGGING
sv_catpv(PL_Sv," DEBUGGING");
# ifdef USE_SOCKS
sv_catpv(PL_Sv," USE_SOCKS");
# endif
+# ifdef USE_SITECUSTOMIZE
+ sv_catpv(PL_Sv," USE_SITECUSTOMIZE");
+# endif
# ifdef PERL_IMPLICIT_CONTEXT
sv_catpv(PL_Sv," PERL_IMPLICIT_CONTEXT");
# endif
# ifdef PERL_IMPLICIT_SYS
sv_catpv(PL_Sv," PERL_IMPLICIT_SYS");
# endif
+
+ while (SvCUR(PL_Sv) > opts+76) {
+ /* find last space after "options: " and before col 76 */
+
+ const char *space;
+ char *pv = SvPV_nolen(PL_Sv);
+ const char c = pv[opts+76];
+ pv[opts+76] = '\0';
+ space = strrchr(pv+opts+26, ' ');
+ pv[opts+76] = c;
+ if (!space) break; /* "Can't happen" */
+
+ /* break the line before that space */
+
+ opts = space - pv;
+ sv_insert(PL_Sv, opts, 0,
+ "\\n ", 25);
+ }
+
sv_catpv(PL_Sv,"\\n\",");
#if defined(LOCAL_PATCH_COUNT)
}
/* catch use of gnu style long options */
if (strEQ(s, "version")) {
- s = "v";
+ s = (char *)"v";
goto reswitch;
}
if (strEQ(s, "help")) {
- s = "h";
+ s = (char *)"h";
goto reswitch;
}
s--;
#endif
(s = PerlEnv_getenv("PERL5OPT")))
{
- char *popt = s;
+ const char *popt = s;
while (isSPACE(*s))
s++;
if (*s == '-' && *(s+1) == 'T') {
}
}
+#ifdef USE_SITECUSTOMIZE
+ if (!minus_f) {
+ if (!PL_preambleav)
+ PL_preambleav = newAV();
+ av_unshift(PL_preambleav, 1);
+ (void)av_store(PL_preambleav, 0, Perl_newSVpvf(aTHX_ "BEGIN { do '%s/sitecustomize.pl' }", SITELIB_EXP));
+ }
+#endif
+
if (PL_taint_warn && PL_dowarn != G_WARN_ALL_OFF) {
PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
}
if (PL_doextract) {
#endif
find_beginning();
- if (cddir && PerlDir_chdir(cddir) < 0)
+ if (cddir && PerlDir_chdir( (char *)cddir ) < 0)
Perl_croak(aTHX_ "Can't chdir to %s",cddir);
}
}
-STATIC void *
+STATIC void
S_run_body(pTHX_ I32 oldscope)
{
DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
my_exit(0);
/* NOTREACHED */
- return NULL;
}
/*
}
STATIC void
-S_call_body(pTHX_ OP *myop, int is_eval)
+S_call_body(pTHX_ const OP *myop, bool is_eval)
{
if (PL_op == myop) {
if (is_eval)
}
void
-Perl_magicname(pTHX_ char *sym, char *name, I32 namlen)
+Perl_magicname(pTHX_ const char *sym, const char *name, I32 namlen)
{
register GV *gv;
}
STATIC void
-S_usage(pTHX_ char *name) /* XXX move this out into a module ? */
+S_usage(pTHX_ const char *name) /* XXX move this out into a module ? */
{
/* This message really ought to be max 23 lines.
* Removed -h because the user already knows that option. Others? */
- static char *usage_msg[] = {
+ static const char *usage_msg[] = {
"-0[octal] specify record separator (\\0, if no argument)",
"-a autosplit mode with -n or -p (splits $_ into @F)",
"-C[number/list] enables the listed Unicode features",
"-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)",
"\n",
NULL
};
- char **p = usage_msg;
+ const char **p = usage_msg;
PerlIO_printf(PerlIO_stdout(),
"\nUsage: %s [switches] [--] [programfile] [arguments]",
#ifdef DEBUGGING
int
-Perl_get_debug_opts(pTHX_ char **s, bool givehelp)
+Perl_get_debug_opts(pTHX_ const char **s, bool givehelp)
{
- static char *usage_msgd[] = {
+ static const char *usage_msgd[] = {
" Debugging flag values: (see also -d)",
" p Tokenizing and parsing (with v, displays parse stack)",
" s Stack snapshots (with v, displays all stacks)",
int i = 0;
if (isALPHA(**s)) {
/* if adding extra options, remember to update DEBUG_MASK */
- static char debopts[] = "psltocPmfrxu HXDSTRJvCAq";
+ static const char debopts[] = "psltocPmfrxu HXDSTRJvCAq";
for (; isALNUM(**s); (*s)++) {
- char *d = strchr(debopts,**s);
+ const char *d = strchr(debopts,**s);
if (d)
i |= 1 << (d - debopts);
else if (ckWARN_d(WARN_DEBUGGING))
for (; isALNUM(**s); (*s)++) ;
}
else if (givehelp) {
- char **p = usage_msgd;
+ const char **p = usage_msgd;
while (*p) PerlIO_printf(PerlIO_stdout(), "%s\n", *p++);
}
# ifdef EBCDIC
}
case 'C':
s++;
- PL_unicode = parse_unicode_opts(&s);
+ PL_unicode = parse_unicode_opts( (const char **)&s );
return s;
case 'F':
PL_minus_F = TRUE;
/* The following permits -d:Mod to accepts arguments following an =
in the fashion that -MSome::Mod does. */
if (*s == ':' || *s == '=') {
- char *start;
+ const char *start;
SV *sv;
sv = newSVpv("use Devel::", 0);
start = ++s;
#ifdef DEBUGGING
forbid_setid("-D");
s++;
- PL_debug = get_debug_opts(&s, 1) | DEBUG_TOP_FLAG;
+ 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),
if (*++s) {
char *start;
SV *sv;
- char *use = "use ";
+ const char *use = "use ";
/* -M-foo == 'no foo' */
if (*s == '-') { use = "no "; ++s; }
sv = newSVpv(use,0);
(void *)upg_version(PL_patchlevel);
#if !defined(DGUX)
PerlIO_printf(PerlIO_stdout(),
- Perl_form(aTHX_ "\nThis is perl, v%_ built for %s",
+ Perl_form(aTHX_ "\nThis is perl, v%"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%_\n",
+ Perl_form(aTHX_ "\nThis is perl, v%"SVf"\n",
vstringify(PL_patchlevel)));
PerlIO_printf(PerlIO_stdout(),
Perl_form(aTHX_ " built under %s at %s %s\n",
#endif
PerlIO_printf(PerlIO_stdout(),
- "\n\nCopyright 1987-2004, Larry Wall\n");
+ "\n\nCopyright 1987-2005, Larry Wall\n");
#ifdef MACOS_TRADITIONAL
PerlIO_printf(PerlIO_stdout(),
"\nMac OS port Copyright 1991-2002, Matthias Neeracher;\n"
/* PSz 18 Nov 03 fdscript now global but do not change prototype */
STATIC void
-S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv)
+S_open_script(pTHX_ const char *scriptname, bool dosearch, SV *sv)
{
#ifndef IAMSUID
- char *quote;
- char *code;
- char *cpp_discard_flag;
- char *perl;
+ const char *quote;
+ const char *code;
+ const char *cpp_discard_flag;
+ const char *perl;
#endif
PL_fdscript = -1;
}
else {
/* if find_script() returns, it returns a malloc()-ed value */
- PL_origfilename = scriptname = find_script(scriptname, dosearch, NULL, 1);
+ scriptname = PL_origfilename = find_script(scriptname, dosearch, NULL, 1);
if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
- char *s = scriptname + 8;
+ const char *s = scriptname + 8;
PL_fdscript = atoi(s);
while (isDIGIT(*s))
s++;
}
scriptname = savepv(s + 1);
Safefree(PL_origfilename);
- PL_origfilename = scriptname;
+ PL_origfilename = (char *)scriptname;
}
}
}
CopFILE_free(PL_curcop);
CopFILE_set(PL_curcop, PL_origfilename);
if (*PL_origfilename == '-' && PL_origfilename[1] == '\0')
- scriptname = "";
+ scriptname = (char *)"";
if (PL_fdscript >= 0) {
PL_rsfp = PerlIO_fdopen(PL_fdscript,PERL_SCRIPT_MODE);
# if defined(HAS_FCNTL) && defined(F_SETFD)
}
#else /* IAMSUID */
else if (PL_preprocess) {
- char *cpp_cfg = CPPSTDIN;
+ const char *cpp_cfg = CPPSTDIN;
SV *cpp = newSVpvn("",0);
SV *cmd = NEWSV(0,0);
"PL_preprocess: cmd=\"%s\"\n",
SvPVX(cmd)));
- PL_rsfp = PerlProc_popen(SvPVX(cmd), "r");
+ PL_rsfp = PerlProc_popen(SvPVX(cmd), (char *)"r");
SvREFCNT_dec(cmd);
SvREFCNT_dec(cpp);
}
#endif /* IAMSUID */
STATIC void
-S_validate_suid(pTHX_ char *validarg, char *scriptname)
+S_validate_suid(pTHX_ const char *validarg, const char *scriptname)
{
#ifdef IAMSUID
/* int which; */
/* not set-id, must be wrapped */
}
#endif /* DOSUID */
+ (void)validarg;
+ (void)scriptname;
}
STATIC void
S_find_beginning(pTHX)
{
- register char *s, *s2;
+ register char *s;
+ register const char *s2;
#ifdef MACOS_TRADITIONAL
int maclines = 0;
#endif
int euid = PerlProc_geteuid();
int gid = PerlProc_getgid();
int egid = PerlProc_getegid();
+ (void)envp;
#ifdef VMS
uid |= gid << 16;
}
STATIC void
-S_forbid_setid(pTHX_ char *s)
+S_forbid_setid(pTHX_ const char *s)
{
#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
if (PL_euid != PL_uid)
}
STATIC void
-S_incpush(pTHX_ char *p, int addsubdirs, int addoldvers, int usesep,
- int canrelocate)
+S_incpush(pTHX_ const char *dir, bool addsubdirs, bool addoldvers, bool usesep,
+ bool canrelocate)
{
SV *subdir = Nullsv;
+ const char *p = dir;
if (!p || !*p)
return;
/* Break at all separators */
while (p && *p) {
SV *libdir = NEWSV(55,0);
- char *s;
+ const char *s;
/* skip any consecutive separators */
if (usesep) {
sv_catpv(libdir, ":");
#endif
+ /* 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 intent is that /usr/local/bin/perl and .../../lib/perl5
* generates /usr/local/lib/perl5
*/
- {
char *libpath = SvPVX(libdir);
STRLEN libpath_len = SvCUR(libdir);
if (libpath_len >= 4 && memEQ (libpath, ".../", 4)) {
}
SvREFCNT_dec(prefix_sv);
}
- }
#endif
+ }
/*
* BEFORE pushing libdir onto @INC we may first push version- and
* archname-specific sub-directories.
Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
{
SV *atsv;
- line_t oldline = CopLINE(PL_curcop);
+ const line_t oldline = CopLINE(PL_curcop);
CV *cv;
STRLEN len;
int ret;
dJMPENV;
- while (AvFILL(paramList) >= 0) {
+ while (av_len(paramList) >= 0) {
cv = (CV*)av_shift(paramList);
if (PL_savebegin) {
if (paramList == PL_beginav) {
read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen)
{
char *p, *nl;
+ (void)idx;
+ (void)maxlen;
+
p = SvPVX(PL_e_script);
nl = strchr(p, '\n');
nl = (nl) ? nl+1 : SvEND(PL_e_script);