/* perl.c
*
* Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999,
- * 2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others
+ * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007 by Larry Wall and others
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
MUTEX_INIT(&PL_my_ctx_mutex);
# endif
}
- else {
+#if defined(USE_ITHREADS)
+ else
+#else
+ /* This always happens for non-ithreads */
+#endif
+ {
PERL_SET_THX(my_perl);
}
}
+
+/* these implement the PERL_SYS_INIT, PERL_SYS_INIT3, PERL_SYS_TERM macros */
+
+void
+Perl_sys_init(int* argc, char*** argv)
+{
+ dVAR;
+ PERL_UNUSED_ARG(argc); /* may not be used depending on _BODY macro */
+ PERL_UNUSED_ARG(argv);
+ PERL_SYS_INIT_BODY(argc, argv);
+}
+
+void
+Perl_sys_init3(int* argc, char*** argv, char*** env)
+{
+ dVAR;
+ PERL_UNUSED_ARG(argc); /* may not be used depending on _BODY macro */
+ PERL_UNUSED_ARG(argv);
+ PERL_UNUSED_ARG(env);
+ PERL_SYS_INIT3_BODY(argc, argv, env);
+}
+
+void
+Perl_sys_term()
+{
+ dVAR;
+ if (!PL_veto_cleanup) {
+ PERL_SYS_TERM_BODY();
+ }
+}
+
+
#ifdef PERL_IMPLICIT_SYS
PerlInterpreter *
perl_alloc_using(struct IPerlMem* ipM, struct IPerlMem* ipMS,
if (PL_perl_destruct_level > 0)
init_interp();
#endif
- /* Init the real globals (and main thread)? */
- if (!PL_linestr) {
- PL_curcop = &PL_compiling; /* needed by ckWARN, right away */
-
- PL_linestr = newSV(79);
- sv_upgrade(PL_linestr,SVt_PVIV);
+ PL_curcop = &PL_compiling; /* needed by ckWARN, right away */
- if (!SvREADONLY(&PL_sv_undef)) {
- /* set read-only and try to insure than we wont see REFCNT==0
- very often */
+ /* set read-only and try to insure than we wont see REFCNT==0
+ very often */
- SvREADONLY_on(&PL_sv_undef);
- SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
+ SvREADONLY_on(&PL_sv_undef);
+ SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
- sv_setpv(&PL_sv_no,PL_No);
- /* value lookup in void context - happens to have the side effect
- of caching the numeric forms. */
- SvIV(&PL_sv_no);
- SvNV(&PL_sv_no);
- SvREADONLY_on(&PL_sv_no);
- SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
+ sv_setpv(&PL_sv_no,PL_No);
+ /* value lookup in void context - happens to have the side effect
+ of caching the numeric forms. */
+ SvIV(&PL_sv_no);
+ SvNV(&PL_sv_no);
+ SvREADONLY_on(&PL_sv_no);
+ SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
- sv_setpv(&PL_sv_yes,PL_Yes);
- SvIV(&PL_sv_yes);
- SvNV(&PL_sv_yes);
- SvREADONLY_on(&PL_sv_yes);
- SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
+ sv_setpv(&PL_sv_yes,PL_Yes);
+ SvIV(&PL_sv_yes);
+ SvNV(&PL_sv_yes);
+ SvREADONLY_on(&PL_sv_yes);
+ SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
- SvREADONLY_on(&PL_sv_placeholder);
- SvREFCNT(&PL_sv_placeholder) = (~(U32)0)/2;
- }
+ SvREADONLY_on(&PL_sv_placeholder);
+ SvREFCNT(&PL_sv_placeholder) = (~(U32)0)/2;
- PL_sighandlerp = (Sighandler_t) Perl_sighandler;
+ PL_sighandlerp = (Sighandler_t) Perl_sighandler;
#ifdef PERL_USES_PL_PIDSTATUS
- PL_pidstatus = newHV();
+ PL_pidstatus = newHV();
#endif
- }
PL_rs = newSVpvs("\n");
init_stacks();
init_ids();
- PL_lex_state = LEX_NOTPARSING;
JMPENV_BOOTSTRAP;
STATUS_ALL_SUCCESS;
sv_setpvn(PERL_DEBUG_PAD(1), "", 0); /* ext/re needs these */
sv_setpvn(PERL_DEBUG_PAD(2), "", 0); /* even without DEBUGGING. */
#ifdef USE_ITHREADS
- PL_regex_padav = newAV();
- av_push(PL_regex_padav,(SV*)newAV()); /* First entry is an array of empty elements */
+ /* First entry is an array of empty elements */
+ Perl_av_create_and_push(aTHX_ &PL_regex_padav,(SV*)newAV());
PL_regex_pad = AvARRAY(PL_regex_padav);
#endif
#ifdef USE_REENTRANT_API
PL_stashcache = newHV();
- PL_patchlevel = Perl_newSVpvf(aTHX_ "%d.%d.%d", (int)PERL_REVISION,
+ PL_patchlevel = Perl_newSVpvf(aTHX_ "v%d.%d.%d", (int)PERL_REVISION,
(int)PERL_VERSION, (int)PERL_SUBVERSION);
#ifdef HAS_MMAP
PL_timesbase.tms_cstime = 0;
#endif
-#ifdef PERL_MAD
- PL_curforce = -1;
-#endif
-
ENTER;
}
perl_destruct(pTHXx)
{
dVAR;
- VOL int destruct_level; /* 0=none, 1=full, 2=full with checks */
+ VOL signed char destruct_level; /* see possible values in intrpvar.h */
HV *hv;
#ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
pid_t child;
if (CALL_FPTR(PL_threadhook)(aTHX)) {
/* Threads hook has vetoed further cleanup */
+ PL_veto_cleanup = TRUE;
return STATUS_EXIT;
}
PL_exitlist = NULL;
PL_exitlistlen = 0;
- if (destruct_level == 0){
-
- DEBUG_P(debprofdump());
-
-#if defined(PERLIO_LAYERS)
- /* No more IO - including error messages ! */
- PerlIO_cleanup(aTHX);
-#endif
-
- /* The exit() function will do everything that needs doing. */
- return STATUS_EXIT;
- }
-
/* jettison our possibly duplicated environment */
/* if PERL_USE_SAFE_PUTENV is defined environ will not have been copied
* so we certainly shouldn't free it here
#endif
#endif /* !PERL_MICRO */
+ if (destruct_level == 0) {
+
+ DEBUG_P(debprofdump());
+
+#if defined(PERLIO_LAYERS)
+ /* No more IO - including error messages ! */
+ PerlIO_cleanup(aTHX);
+#endif
+
+ CopFILE_free(&PL_compiling);
+ CopSTASH_free(&PL_compiling);
+
+ /* The exit() function will do everything that needs doing. */
+ return STATUS_EXIT;
+ }
+
/* reset so print() ends up where we expect */
setdefout(NULL);
/* loosen bonds of global variables */
- if(PL_rsfp) {
- (void)PerlIO_close(PL_rsfp);
- PL_rsfp = NULL;
+ /* 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;
}
- /* Filters for program text */
- SvREFCNT_dec(PL_rsfp_filters);
- PL_rsfp_filters = NULL;
-
if (PL_minus_F) {
Safefree(PL_splitstr);
PL_splitstr = NULL;
PL_DBsingle = NULL;
PL_DBtrace = NULL;
PL_DBsignal = NULL;
- PL_DBassertion = NULL;
PL_DBcv = NULL;
PL_dbargs = NULL;
PL_debstash = NULL;
PL_preambleav = NULL;
SvREFCNT_dec(PL_subname);
PL_subname = NULL;
- SvREFCNT_dec(PL_linestr);
- PL_linestr = NULL;
#ifdef PERL_USES_PL_PIDSTATUS
SvREFCNT_dec(PL_pidstatus);
PL_pidstatus = NULL;
SvREFCNT_dec(PL_errors);
PL_errors = NULL;
+ SvREFCNT_dec(PL_isarev);
+
FREETMPS;
if (destruct_level >= 2 && ckWARN_d(WARN_INTERNAL)) {
if (PL_scopestack_ix != 0)
" flags=0x%"UVxf
" refcnt=%"UVuf pTHX__FORMAT "\n"
"\tallocated at %s:%d %s %s%s\n",
- sv, sv->sv_flags, sv->sv_refcnt pTHX__VALUE,
+ (void*)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",
#endif
PL_sv_count = 0;
+#ifdef PERL_DEBUG_READONLY_OPS
+ free(PL_slabs);
+ PL_slabs = NULL;
+ PL_slab_count = 0;
+#endif
#if defined(PERLIO_LAYERS)
/* No more IO - including error messages ! */
void
perl_free(pTHXx)
{
+ dVAR;
+
+ if (PL_veto_cleanup)
+ return;
+
#ifdef PERL_TRACK_MEMPOOL
{
/*
perl_fini(void)
{
dVAR;
- if (PL_curinterp)
+ if (PL_curinterp && !PL_veto_cleanup)
FREE_THREAD_KEY;
}
break;
}
}
+
+#ifndef PERL_USE_SAFE_PUTENV
/* Can we grab env area too to be used as the area for $0? */
- if (s && PL_origenviron) {
- if ((PL_origenviron[0] == s + 1
-#ifdef OS2
- || (PL_origenviron[0] == s + 9 && (s += 8))
-#endif
- )
+ if (s && PL_origenviron && !PL_use_safe_putenv) {
+ if ((PL_origenviron[0] == s + 1)
||
(aligned &&
(PL_origenviron[0] > s &&
INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask)))
)
{
-#ifndef OS2
+#ifndef OS2 /* ENVIRON is read by the kernel too. */
s = PL_origenviron[0];
while (*s) s++;
#endif
}
}
}
+#endif /* !defined(PERL_USE_SAFE_PUTENV) */
+
PL_origalen = s ? s - PL_origargv[0] + 1 : 0;
}
S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
{
dVAR;
+ PerlIO *rsfp;
int argc = PL_origargc;
char **argv = PL_origargv;
const char *scriptname = NULL;
VOL bool dosearch = FALSE;
const char *validarg = "";
register SV *sv;
- register char *s, c;
+ register char c;
const char *cddir = NULL;
#ifdef USE_SITECUSTOMIZE
bool minus_f = FALSE;
#endif
+ SV *linestr_sv = newSV_type(SVt_PVIV);
+ bool add_read_e_script = FALSE;
+
+ SvGROW(linestr_sv, 80);
+ sv_setpvn(linestr_sv,"",0);
- sv_setpvn(PL_linestr,"",0);
sv = newSVpvs(""); /* first used for -I flags */
SAVEFREESV(sv);
init_main_stash();
+ {
+ const char *s;
for (argc--,argv++; argc > 0; argc--,argv++) {
if (argv[0][0] != '-' || !argv[0][1])
break;
case 'W':
case 'X':
case 'w':
- case 'A':
if ((s = moreswitches(s)))
goto reswitch;
break;
forbid_setid('e', -1);
if (!PL_e_script) {
PL_e_script = newSVpvs("");
- filter_add(read_e_script, NULL);
+ add_read_e_script = TRUE;
}
if (*++s)
sv_catpv(PL_e_script, s);
forbid_setid('P', -1);
PL_preprocess = TRUE;
s++;
+ deprecate("-P");
goto reswitch;
case 'S':
forbid_setid('S', -1);
{
SV *opts_prog;
- if (!PL_preambleav)
- PL_preambleav = newAV();
- av_push(PL_preambleav,
- newSVpvs("use Config;"));
+ Perl_av_create_and_push(aTHX_ &PL_preambleav, newSVpvs("use Config;"));
if (*++s != ':') {
- STRLEN opts;
-
- opts_prog = newSVpvs("print Config::myconfig(),");
-#ifdef VMS
- sv_catpvs(opts_prog,"\"\\nCharacteristics of this PERLSHR image: \\n\",");
-#else
- sv_catpvs(opts_prog,"\"\\nCharacteristics of this binary (from libperl): \\n\",");
-#endif
- opts = SvCUR(opts_prog);
-
- Perl_sv_catpv(aTHX_ opts_prog,"\" Compile-time options:"
+ /* Can't do newSVpvs() as that would involve pre-processor
+ condititionals inside a macro expansion. */
+ opts_prog = Perl_newSVpv(aTHX_ "$_ = join ' ', sort qw("
# ifdef DEBUGGING
" DEBUGGING"
# endif
-# ifdef DEBUG_LEAKING_SCALARS
- " DEBUG_LEAKING_SCALARS"
-# endif
-# ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
- " DEBUG_LEAKING_SCALARS_FORK_DUMP"
-# endif
-# ifdef FAKE_THREADS
- " FAKE_THREADS"
-# endif
-# ifdef MULTIPLICITY
- " MULTIPLICITY"
-# endif
-# ifdef MYMALLOC
- " MYMALLOC"
-# endif
# ifdef NO_MATHOMS
" NO_MATHOMS"
# endif
# ifdef PERL_DONT_CREATE_GVSV
" PERL_DONT_CREATE_GVSV"
# endif
-# ifdef PERL_GLOBAL_STRUCT
- " PERL_GLOBAL_STRUCT"
-# endif
-# ifdef PERL_IMPLICIT_CONTEXT
- " PERL_IMPLICIT_CONTEXT"
-# endif
-# ifdef PERL_IMPLICIT_SYS
- " PERL_IMPLICIT_SYS"
-# endif
-# ifdef PERL_MAD
- " PERL_MAD"
-# endif
# ifdef PERL_MALLOC_WRAP
" PERL_MALLOC_WRAP"
# endif
-# ifdef PERL_NEED_APPCTX
- " PERL_NEED_APPCTX"
+# ifdef PERL_MEM_LOG
+ " PERL_MEM_LOG"
# endif
-# ifdef PERL_NEED_TIMESBASE
- " PERL_NEED_TIMESBASE"
+# ifdef PERL_MEM_LOG_ENV
+ " PERL_MEM_LOG_ENV"
# endif
-# ifdef PERL_OLD_COPY_ON_WRITE
- " PERL_OLD_COPY_ON_WRITE"
+# ifdef PERL_MEM_LOG_ENV_FD
+ " PERL_MEM_LOG_ENV_FD"
# endif
-# ifdef PERL_TRACK_MEMPOOL
- " PERL_TRACK_MEMPOOL"
+# ifdef PERL_MEM_LOG_STDERR
+ " PERL_MEM_LOG_STDERR"
+# endif
+# ifdef PERL_MEM_LOG_TIMESTAMP
+ " PERL_MEM_LOG_TIMESTAMP"
# endif
# ifdef PERL_USE_SAFE_PUTENV
" PERL_USE_SAFE_PUTENV"
# endif
-#ifdef PERL_USES_PL_PIDSTATUS
- " PERL_USES_PL_PIDSTATUS"
-#endif
-# ifdef PL_OP_SLAB_ALLOC
- " PL_OP_SLAB_ALLOC"
-# endif
-# ifdef THREADS_HAVE_PIDS
- " THREADS_HAVE_PIDS"
-# endif
-# ifdef USE_64_BIT_ALL
- " USE_64_BIT_ALL"
-# endif
-# ifdef USE_64_BIT_INT
- " USE_64_BIT_INT"
-# endif
-# ifdef USE_ITHREADS
- " USE_ITHREADS"
-# endif
-# ifdef USE_LARGE_FILES
- " USE_LARGE_FILES"
-# endif
-# ifdef USE_LONG_DOUBLE
- " USE_LONG_DOUBLE"
-# endif
-# ifdef USE_PERLIO
- " USE_PERLIO"
-# endif
-# ifdef USE_REENTRANT_API
- " USE_REENTRANT_API"
-# endif
-# ifdef USE_SFIO
- " USE_SFIO"
-# endif
# ifdef USE_SITECUSTOMIZE
" USE_SITECUSTOMIZE"
# endif
-# ifdef USE_SOCKS
- " USE_SOCKS"
-# endif
- );
+ , 0);
- while (SvCUR(opts_prog) > opts+76) {
- /* find last space after "options: " and before col 76
- */
-
- const char *space;
- char * const pv = SvPV_nolen(opts_prog);
- const char c = pv[opts+76];
- pv[opts+76] = '\0';
- space = strrchr(pv+opts+26, ' ');
- pv[opts+76] = c;
- if (!space) break; /* "Can't happen" */
-
- /* break the line before that space */
-
- opts = space - pv;
- Perl_sv_insert(aTHX_ opts_prog, opts, 0,
- STR_WITH_LEN("\\n "));
- }
+ sv_catpv(opts_prog, PL_bincompat_options);
+ /* Terminate the qw(, and then wrap at 76 columns. */
+ sv_catpvs(opts_prog, "); s/(?=.{53})(.{1,53}) /$1\\n /mg;print Config::myconfig(),");
+#ifdef VMS
+ sv_catpvs(opts_prog,"\"\\nCharacteristics of this PERLSHR image: \\n");
+#else
+ sv_catpvs(opts_prog,"\"\\nCharacteristics of this binary (from libperl): \\n");
+#endif
- sv_catpvs(opts_prog,"\\n\",");
+ sv_catpvs(opts_prog," Compile-time options: $_\\n\",");
#if defined(LOCAL_PATCH_COUNT)
if (LOCAL_PATCH_COUNT > 0) {
}
#endif
Perl_sv_catpvf(aTHX_ opts_prog,
- "\" Built under %s\\n\"",OSNAME);
+ "\" Built under %s\\n",OSNAME);
#ifdef __DATE__
# ifdef __TIME__
Perl_sv_catpvf(aTHX_ opts_prog,
- ",\" Compiled at %s %s\\n\"",__DATE__,
+ " Compiled at %s %s\\n\"",__DATE__,
__TIME__);
# else
- Perl_sv_catpvf(aTHX_ opts_prog,",\" Compiled on %s\\n\"",
+ Perl_sv_catpvf(aTHX_ opts_prog," Compiled on %s\\n\"",
__DATE__);
# endif
#endif
Perl_croak(aTHX_ "Unrecognized switch: -%s (-h will show valid options)",s);
}
}
+ }
+
switch_end:
+ {
+ char *s;
+
if (
#ifndef SECURE_INTERNAL_GETENV
!PL_tainting &&
d = s;
if (!*s)
break;
- if (!strchr("CDIMUdmtwA", *s))
+ if (!strchr("CDIMUdmtw", *s))
Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s);
while (++s && *s) {
if (isSPACE(*s)) {
}
}
}
+ }
#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));
+ (void)Perl_av_create_and_unshift_one(aTHX_ &PL_preambleav,
+ 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
- = Perl_new_warnings_bitfield(aTHX_ NULL, WARN_TAINTstring, WARNsize);
- }
-
if (!scriptname)
scriptname = argv[0];
if (PL_e_script) {
{
int suidscript;
const int fdscript
- = open_script(scriptname, dosearch, sv, &suidscript);
+ = open_script(scriptname, dosearch, sv, &suidscript, &rsfp);
- validate_suid(validarg, scriptname, fdscript, suidscript);
+ validate_suid(validarg, scriptname, fdscript, suidscript,
+ linestr_sv, rsfp);
#ifndef PERL_MICRO
# if defined(SIGCHLD) || defined(SIGCLD)
forbid_setid('x', suidscript);
/* Hence you can't get here if suidscript >= 0 */
- find_beginning();
+ 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 = (CV*)newSV(0);
- sv_upgrade((SV *)PL_compcv, SVt_PVCV);
+ PL_main_cv = PL_compcv = (CV*)newSV_type(SVt_PVCV);
CvUNIQUE_on(PL_compcv);
CvPADLIST(PL_compcv) = pad_new(0);
+ PL_isarev = newHV();
+
boot_core_PerlIO();
boot_core_UNIVERSAL();
boot_core_xsutils();
+ boot_core_mro();
if (xsinit)
(*xsinit)(aTHX); /* in case linked C routines want magical variables */
}
}
+ {
+ const char *s;
if ((s = PerlEnv_getenv("PERL_SIGNALS"))) {
if (strEQ(s, "unsafe"))
PL_signals |= PERL_SIGNALS_UNSAFE_FLAG;
else
Perl_croak(aTHX_ "PERL_SIGNALS illegal: \"%s\"", s);
}
+ }
#ifdef PERL_MAD
+ {
+ const char *s;
if ((s = PerlEnv_getenv("PERL_XMLDUMP"))) {
PL_madskills = 1;
PL_minus_c = 1;
if (!PL_xmlfp)
Perl_croak(aTHX_ "Can't open %s", s);
}
- my_setenv("PERL_XMLDUMP", Nullch); /* hide from subprocs */
+ my_setenv("PERL_XMLDUMP", NULL); /* hide from subprocs */
+ }
}
+
+ {
+ const char *s;
if ((s = PerlEnv_getenv("PERL_MADSKILLS"))) {
PL_madskills = atoi(s);
- my_setenv("PERL_MADSKILLS", Nullch); /* hide from subprocs */
+ my_setenv("PERL_MADSKILLS", NULL); /* hide from subprocs */
+ }
}
#endif
- init_lexer();
+ lex_start(linestr_sv, rsfp, TRUE);
+ PL_subname = newSVpvs("main");
+
+ if (add_read_e_script)
+ filter_add(read_e_script, NULL);
/* now parse the script */
SETERRNO(0,SS_NORMAL);
- PL_error_count = 0;
#ifdef MACOS_TRADITIONAL
- if (gMacPerl_SyntaxError = (yyparse() || PL_error_count)) {
+ if (gMacPerl_SyntaxError = (yyparse() || PL_parser->error_count)) {
if (PL_minus_c)
Perl_croak(aTHX_ "%s had compilation errors.\n", MacPerl_MPWFileName(PL_origfilename));
else {
}
}
#else
- if (yyparse() || PL_error_count) {
+ if (yyparse() || PL_parser->error_count) {
if (PL_minus_c)
Perl_croak(aTHX_ "%s had compilation errors.\n", PL_origfilename);
else {
FREETMPS;
#ifdef MYMALLOC
+ {
+ const char *s;
if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
dump_mstats("after compilation:");
+ }
#endif
ENTER;
return ret;
}
-
STATIC void
S_run_body(pTHX_ I32 oldscope)
{
sv_setiv(PL_DBsingle, 1);
if (PL_initav)
call_list(oldscope, PL_initav);
+#ifdef PERL_DEBUG_READONLY_OPS
+ Perl_pending_Slabs_to_ro(aTHX);
+#endif
}
/* do it */
/*
=head1 CV Manipulation Functions
+=for apidoc p||get_cvn_flags
+
+Returns the CV of the specified Perl subroutine. C<flags> are passed to
+C<gv_fetchpvn_flags>. If C<GV_ADD> is set and the Perl subroutine does not
+exist then it will be declared (which has the same effect as saying
+C<sub name;>). If C<GV_ADD> is not set and the subroutine does not exist
+then NULL is returned.
+
=for apidoc p||get_cv
-Returns the CV of the specified Perl subroutine. If C<create> is set and
-the Perl subroutine does not exist then it will be declared (which has the
-same effect as saying C<sub name;>). If C<create> is not set and the
-subroutine does not exist then NULL is returned.
+Uses C<strlen> to get the length of C<name>, then calls C<get_cvn_flags>.
=cut
*/
CV*
-Perl_get_cv(pTHX_ const char *name, I32 create)
+Perl_get_cvn_flags(pTHX_ const char *name, STRLEN len, I32 flags)
{
- GV* const gv = gv_fetchpv(name, create, SVt_PVCV);
- /* XXX unsafe for threads if eval_owner isn't held */
+ GV* const gv = gv_fetchpvn_flags(name, len, flags, SVt_PVCV);
/* 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 (create && !GvCVu(gv))
+ if ((flags & ~GV_NOADD_MASK) && !GvCVu(gv)) {
+ SV *const sv = newSVpvn(name,len);
+ SvFLAGS(sv) |= flags & SVf_UTF8;
return newSUB(start_subparse(FALSE, 0),
- newSVOP(OP_CONST, 0, newSVpv(name,0)),
+ newSVOP(OP_CONST, 0, sv),
NULL, NULL);
+ }
if (gv)
return GvCVu(gv);
return NULL;
}
+CV*
+Perl_get_cv(pTHX_ const char *name, I32 flags)
+{
+ return get_cvn_flags(name, strlen(name), flags);
+}
+
/* Be sure to refetch the stack pointer after calling these routines. */
/*
static const char * const usage_msg[] = {
"-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)",
/* This routine handles any switches that can be given during run */
-char *
-Perl_moreswitches(pTHX_ char *s)
+const char *
+Perl_moreswitches(pTHX_ const char *s)
{
dVAR;
UV rschar;
/* 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 *start = ++s;
+ const char *const end = s + strlen(s);
SV * const sv = newSVpvs("use Devel::");
- start = ++s;
+
/* We now allow -d:Module=Foo,Bar */
while(isALNUM(*s) || *s==':') ++s;
if (*s != '=')
- sv_catpv(sv, start);
+ 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 += strlen(s);
+ s = end;
my_setenv("PERL5DB", SvPV_nolen_const(sv));
+ SvREFCNT_dec(sv);
}
if (!PL_perldb) {
PL_perldb = PERLDB_ALL;
while (*s && isSPACE(*s))
++s;
if (*s) {
- char *e, *p;
+ const char *e, *p;
p = s;
/* ignore trailing spaces (possibly followed by other switches) */
do {
}
}
return s;
- case 'A':
- forbid_setid('A', -1);
- if (!PL_preambleav)
- PL_preambleav = newAV();
- s++;
- {
- char * const start = s;
- SV * const sv = newSVpvs("use assertions::activate");
- while(isALNUM(*s) || *s == ':') ++s;
- if (s != start) {
- sv_catpvs(sv, "::");
- sv_catpvn(sv, start, s-start);
- }
- if (*s == '=') {
- Perl_sv_catpvf(aTHX_ sv, " split(/,/,q%c%s%c)", 0, ++s, 0);
- s+=strlen(s);
- }
- else if (*s != '\0') {
- Perl_croak(aTHX_ "Can't use '%c' after -A%.*s", *s, (int)(s-start), start);
- }
- av_push(PL_preambleav, sv);
- return s;
- }
case 'M':
forbid_setid('M', -1); /* XXX ? */
/* FALL THROUGH */
case 'm':
forbid_setid('m', -1); /* XXX ? */
if (*++s) {
- char *start;
+ const char *start;
+ const char *end;
SV *sv;
const char *use = "use ";
/* -M-foo == 'no foo' */
start = s;
/* We allow -M'Module qw(Foo Bar)' */
while(isALNUM(*s) || *s==':') ++s;
+ end = s + strlen(s);
if (*s != '=') {
- sv_catpv(sv, start);
+ sv_catpvn(sv, start, end - start);
if (*(start-1) == 'm') {
if (*s != '\0')
Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
Perl_croak(aTHX_ "Module name required with -%c option",
s[-1]);
sv_catpvn(sv, start, s-start);
- sv_catpvs(sv, " split(/,/,q");
- sv_catpvs(sv, "\0"); /* Use NUL as q//-delimiter. */
- sv_catpv(sv, ++s);
+ /* Use NUL as q''-delimiter. */
+ sv_catpvs(sv, " split(/,/,q\0");
+ ++s;
+ sv_catpvn(sv, s, end - s);
sv_catpvs(sv, "\0)");
}
- s += strlen(s);
- if (!PL_preambleav)
- PL_preambleav = newAV();
- av_push(PL_preambleav, sv);
+ s = end;
+ Perl_av_create_and_push(aTHX_ &PL_preambleav, sv);
}
else
Perl_croak(aTHX_ "Missing argument to -%c", *(s-1));
return s;
case 'v':
if (!sv_derived_from(PL_patchlevel, "version"))
- upg_version(PL_patchlevel);
+ upg_version(PL_patchlevel, TRUE);
#if !defined(DGUX)
PerlIO_printf(PerlIO_stdout(),
Perl_form(aTHX_ "\nThis is perl, %"SVf
" DEVEL" STRINGIFY(PERL_PATCHNUM)
#endif
" built for %s",
- (void*)vstringify(PL_patchlevel),
+ SVfARG(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, %"SVf"\n",
- vstringify(PL_patchlevel)));
+ SVfARG(vstringify(PL_patchlevel))));
PerlIO_printf(PerlIO_stdout(),
Perl_form(aTHX_ " built under %s at %s %s\n",
OSNAME, __DATE__, __TIME__));
#endif
PerlIO_printf(PerlIO_stdout(),
- "\n\nCopyright 1987-2006, Larry Wall\n");
+ "\n\nCopyright 1987-2007, Larry Wall\n");
#ifdef MACOS_TRADITIONAL
PerlIO_printf(PerlIO_stdout(),
"\nMac OS port Copyright 1991-2002, Matthias Neeracher;\n"
Internet, point your browser at http://www.perl.org/, the Perl Home Page.\n\n");
my_exit(0);
case 'w':
- if (! (PL_dowarn & G_WARN_ALL_MASK))
+ if (! (PL_dowarn & G_WARN_ALL_MASK)) {
PL_dowarn |= G_WARN_ON;
+ }
s++;
return s;
case 'W':
# define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
# endif
# include "intrpvar.h"
-# include "thrdvar.h"
# undef PERLVAR
# undef PERLVARA
# undef PERLVARI
# define PERLVARI(var,type,init) PL_##var = init;
# define PERLVARIC(var,type,init) PL_##var = init;
# include "intrpvar.h"
-# include "thrdvar.h"
# undef PERLVAR
# undef PERLVARA
# undef PERLVARI
SvREADONLY_on(gv);
PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpvs("INC", GV_ADD|GV_NOTQUAL,
SVt_PVAV)));
- SvREFCNT_inc_simple(PL_incgv); /* Don't allow it to be freed */
+ 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 */
GvMULTI_on(PL_hintgv);
PL_defgv = gv_fetchpvs("_", GV_ADD|GV_NOTQUAL, SVt_PVAV);
- SvREFCNT_inc_simple(PL_defgv);
+ SvREFCNT_inc_simple_void(PL_defgv);
PL_errgv = gv_HVadd(gv_fetchpvs("@", GV_ADD|GV_NOTQUAL, SVt_PV));
- SvREFCNT_inc_simple(PL_errgv);
+ SvREFCNT_inc_simple_void(PL_errgv);
GvMULTI_on(PL_errgv);
PL_replgv = gv_fetchpvs("\022", GV_ADD|GV_NOTQUAL, SVt_PV); /* ^R */
GvMULTI_on(PL_replgv);
STATIC int
S_open_script(pTHX_ const char *scriptname, bool dosearch, SV *sv,
- int *suidscript)
+ int *suidscript, PerlIO **rsfpp)
{
#ifndef IAMSUID
const char *quote;
if (*PL_origfilename == '-' && PL_origfilename[1] == '\0')
scriptname = (char *)"";
if (fdscript >= 0) {
- PL_rsfp = PerlIO_fdopen(fdscript,PERL_SCRIPT_MODE);
+ *rsfpp = PerlIO_fdopen(fdscript,PERL_SCRIPT_MODE);
# if defined(HAS_FCNTL) && defined(F_SETFD)
- if (PL_rsfp)
+ if (*rsfpp)
/* ensure close-on-exec */
- fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);
+ fcntl(PerlIO_fileno(*rsfpp),F_SETFD,1);
# endif
}
#ifdef IAMSUID
Perl_sv_setpvf(aTHX_ cmd, "\
%s -ne%s%s%s %s | %"SVf" %s %"SVf" %s",
- perl, quote, code, quote, scriptname, (void*)cpp,
- cpp_discard_flag, (void*)sv, CPPMINUS);
+ perl, quote, code, quote, scriptname, SVfARG(cpp),
+ cpp_discard_flag, SVfARG(sv), CPPMINUS);
PL_doextract = FALSE;
"PL_preprocess: cmd=\"%s\"\n",
SvPVX_const(cmd)));
- PL_rsfp = PerlProc_popen((char *)SvPVX_const(cmd), (char *)"r");
+ *rsfpp = PerlProc_popen((char *)SvPVX_const(cmd), (char *)"r");
SvREFCNT_dec(cmd);
SvREFCNT_dec(cpp);
}
else if (!*scriptname) {
forbid_setid(0, *suidscript);
- PL_rsfp = PerlIO_stdin();
+ *rsfpp = PerlIO_stdin();
}
else {
- PL_rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
+#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. */
+#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)) {
+#ifdef HAS_MKSTEMP /* Hopefully mkstemp() is safe here. */
+ int tmpfd = mkstemp(tmpname);
+ if (tmpfd > -1) {
+ scriptname = tmpname;
+ close(tmpfd);
+ } else
+ Perl_croak(aTHX_ err);
+#else
+# ifdef HAS_MKTEMP
+ scriptname = mktemp(tmpname);
+ if (!scriptname)
+ Perl_croak(aTHX_ err);
+# endif
+#endif
+ }
+#endif
+ *rsfpp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
+#ifdef FAKE_BIT_BUCKET
+ if (memEQ(scriptname, FAKE_BIT_BUCKET_PREFIX,
+ sizeof(FAKE_BIT_BUCKET_PREFIX) - 1)
+ && strlen(scriptname) == sizeof(tmpname) - 1) {
+ unlink(scriptname);
+ }
+ scriptname = BIT_BUCKET;
+#endif
# if defined(HAS_FCNTL) && defined(F_SETFD)
- if (PL_rsfp)
+ if (*rsfpp)
/* ensure close-on-exec */
- fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);
+ fcntl(PerlIO_fileno(*rsfpp),F_SETFD,1);
# endif
}
#endif /* IAMSUID */
- if (!PL_rsfp) {
+ if (!*rsfpp) {
/* PSz 16 Sep 03 Keep neat error message */
if (PL_e_script)
Perl_croak(aTHX_ "Can't open "BIT_BUCKET": %s\n", Strerror(errno));
STATIC void
S_validate_suid(pTHX_ const char *validarg, const char *scriptname,
- int fdscript, int suidscript)
+ int fdscript, int suidscript, SV *linestr_sv, PerlIO *rsfp)
{
dVAR;
#ifdef IAMSUID
#ifdef DOSUID
const char *s, *s2;
- if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0) /* normal stat is insecure */
+ if (PerlLIO_fstat(PerlIO_fileno(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;
const char *linestr;
const char *s_end;
-#ifdef IAMSUID
+# ifdef IAMSUID
if (fdscript < 0 || suidscript != 1)
Perl_croak(aTHX_ "Need (suid) fdscript in suidperl\n"); /* We already checked this */
/* PSz 11 Nov 03
/* PSz 27 Feb 04
* Do checks even for systems with no HAS_SETREUID.
* We used to swap, then re-swap UIDs with
-#ifdef HAS_SETREUID
+# ifdef HAS_SETREUID
if (setreuid(PL_euid,PL_uid) < 0
|| PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid)
Perl_croak(aTHX_ "Can't swap uid and euid");
-#endif
-#ifdef HAS_SETREUID
+# endif
+# ifdef HAS_SETREUID
if (setreuid(PL_uid,PL_euid) < 0
|| PerlProc_getuid() != PL_uid || PerlProc_geteuid() != PL_euid)
Perl_croak(aTHX_ "Can't reswap uid and euid");
-#endif
+# endif
*/
/* On this access check to make sure the directories are readable,
* operating systems do not have such mount options anyway...)
* Seems safe enough to do as root.
*/
-#if !defined(NO_NOSUID_CHECK)
- if (fd_on_nosuid_fs(PerlIO_fileno(PL_rsfp))) {
+# if !defined(NO_NOSUID_CHECK)
+ if (fd_on_nosuid_fs(PerlIO_fileno(rsfp))) {
Perl_croak(aTHX_ "Setuid script on nosuid or noexec filesystem\n");
}
-#endif
-#endif /* IAMSUID */
+# endif
+# endif /* IAMSUID */
if (!S_ISREG(PL_statbuf.st_mode)) {
Perl_croak(aTHX_ "Setuid script not plain file\n");
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);
- if (sv_gets(PL_linestr, PL_rsfp, 0) == NULL)
+ if (sv_gets(linestr_sv, rsfp, 0) == NULL)
Perl_croak(aTHX_ "No #! line");
- linestr = SvPV_nolen_const(PL_linestr);
+ linestr = SvPV_nolen_const(linestr_sv);
/* required even on Sys V */
if (!*linestr || !linestr[1] || strnNE(linestr,"#!",2))
Perl_croak(aTHX_ "No #! line");
|| ((s_end - s) == len+2 && isSPACE(s[len+1]))))
Perl_croak(aTHX_ "Args must match #! line");
-#ifndef IAMSUID
+# ifndef IAMSUID
if (fdscript < 0 &&
PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) &&
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, OR PUT A C WRAPPER AROUND THIS SCRIPT!\n");
-#endif /* IAMSUID */
+# endif /* IAMSUID */
if (fdscript < 0 &&
PL_euid) { /* oops, we're not the setuid root perl */
* fdscript to avoid loops), and do the execs
* even for root.
*/
-#ifndef IAMSUID
+# ifndef IAMSUID
int which;
/* PSz 11 Nov 03
* Pass fd script to suidperl.
* in fact will use that to distinguish this from "normal"
* usage, see comments above.
*/
- PerlIO_rewind(PL_rsfp);
- PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0); /* just in case rewind didn't */
+ PerlIO_rewind(rsfp);
+ PerlLIO_lseek(PerlIO_fileno(rsfp),(Off_t)0,0); /* just in case rewind didn't */
/* PSz 27 Feb 04 Sanity checks on scriptname */
if ((!scriptname) || (!*scriptname) ) {
Perl_croak(aTHX_ "No setuid script name\n");
Perl_croak(aTHX_ "Can't change argv to have fd script\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)
- fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0); /* ensure no close-on-exec */
-#endif
+ PerlIO_fileno(rsfp), PL_origargv[which]));
+# if defined(HAS_FCNTL) && defined(F_SETFD)
+ fcntl(PerlIO_fileno(rsfp),F_SETFD,0); /* ensure no close-on-exec */
+# endif
PERL_FPU_PRE_EXEC
PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT, BIN_EXP,
(int)PERL_REVISION, (int)PERL_VERSION,
(int)PERL_SUBVERSION), PL_origargv);
PERL_FPU_POST_EXEC
-#endif /* IAMSUID */
+# endif /* IAMSUID */
Perl_croak(aTHX_ "Can't do setuid (cannot exec sperl)\n");
}
* in the sense that we only want to set EGID; but are there any machines
* with either of the latter, but not the former? Same with UID, later.
*/
-#ifdef HAS_SETEGID
+# ifdef HAS_SETEGID
(void)setegid(PL_statbuf.st_gid);
-#else
-#ifdef HAS_SETREGID
+# else
+# ifdef HAS_SETREGID
(void)setregid((Gid_t)-1,PL_statbuf.st_gid);
-#else
-#ifdef HAS_SETRESGID
+# else
+# ifdef HAS_SETRESGID
(void)setresgid((Gid_t)-1,PL_statbuf.st_gid,(Gid_t)-1);
-#else
+# else
PerlProc_setgid(PL_statbuf.st_gid);
-#endif
-#endif
-#endif
+# endif
+# endif
+# endif
if (PerlProc_getegid() != PL_statbuf.st_gid)
Perl_croak(aTHX_ "Can't do setegid!\n");
}
if (PL_statbuf.st_mode & S_ISUID) {
if (PL_statbuf.st_uid != PL_euid)
-#ifdef HAS_SETEUID
+# ifdef HAS_SETEUID
(void)seteuid(PL_statbuf.st_uid); /* all that for this */
-#else
-#ifdef HAS_SETREUID
+# else
+# ifdef HAS_SETREUID
(void)setreuid((Uid_t)-1,PL_statbuf.st_uid);
-#else
-#ifdef HAS_SETRESUID
+# else
+# ifdef HAS_SETRESUID
(void)setresuid((Uid_t)-1,PL_statbuf.st_uid,(Uid_t)-1);
-#else
+# else
PerlProc_setuid(PL_statbuf.st_uid);
-#endif
-#endif
-#endif
+# endif
+# endif
+# endif
if (PerlProc_geteuid() != PL_statbuf.st_uid)
Perl_croak(aTHX_ "Can't do seteuid!\n");
}
else if (PL_uid) { /* oops, mustn't run as root */
-#ifdef HAS_SETEUID
+# ifdef HAS_SETEUID
(void)seteuid((Uid_t)PL_uid);
-#else
-#ifdef HAS_SETREUID
+# else
+# ifdef HAS_SETREUID
(void)setreuid((Uid_t)-1,(Uid_t)PL_uid);
-#else
-#ifdef HAS_SETRESUID
+# else
+# ifdef HAS_SETRESUID
(void)setresuid((Uid_t)-1,(Uid_t)PL_uid,(Uid_t)-1);
-#else
+# else
PerlProc_setuid((Uid_t)PL_uid);
-#endif
-#endif
-#endif
+# endif
+# endif
+# endif
if (PerlProc_geteuid() != PL_uid)
Perl_croak(aTHX_ "Can't do seteuid!\n");
}
if (!cando(S_IXUSR,TRUE,&PL_statbuf))
Perl_croak(aTHX_ "Effective UID cannot exec script\n"); /* they can't do this */
}
-#ifdef IAMSUID
+# ifdef IAMSUID
else if (PL_preprocess) /* PSz 13 Nov 03 Caught elsewhere, useless(?!) here */
Perl_croak(aTHX_ "-P not allowed for setuid/setgid script\n");
else if (fdscript < 0 || suidscript != 1)
* #endif
* into the perly bits.
*/
- PerlIO_rewind(PL_rsfp);
- PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0); /* just in case rewind didn't */
+ PerlIO_rewind(rsfp);
+ PerlLIO_lseek(PerlIO_fileno(rsfp),(Off_t)0,0); /* just in case rewind didn't */
/* PSz 11 Nov 03
* Keep original arguments: suidperl already has fd script.
*/
/* 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)
- fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0); /* ensure no close-on-exec */
-#endif
+/* PerlIO_fileno(rsfp), PL_origargv[which])); */
+# if defined(HAS_FCNTL) && defined(F_SETFD)
+ fcntl(PerlIO_fileno(rsfp),F_SETFD,0); /* ensure no close-on-exec */
+# endif
PERL_FPU_PRE_EXEC
PerlProc_execv(Perl_form(aTHX_ "%s/perl"PERL_FS_VER_FMT, BIN_EXP,
(int)PERL_REVISION, (int)PERL_VERSION,
(int)PERL_SUBVERSION), PL_origargv);/* try again */
PERL_FPU_POST_EXEC
Perl_croak(aTHX_ "Can't do setuid (suidperl cannot exec perl)\n");
-#endif /* IAMSUID */
+# endif /* IAMSUID */
#else /* !DOSUID */
PERL_UNUSED_ARG(fdscript);
PERL_UNUSED_ARG(suidscript);
if (PL_euid != PL_uid || PL_egid != PL_gid) { /* (suidperl doesn't exist, in fact) */
-#ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
- PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf); /* may be either wrapped or real suid */
+# ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
+ PERL_UNUSED_ARG(rsfp);
+# else
+ PerlLIO_fstat(PerlIO_fileno(rsfp),&PL_statbuf); /* may be either wrapped or real suid */
if ((PL_euid != PL_uid && PL_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
||
(PL_egid != PL_gid && PL_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
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");
-#endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
+# endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
/* not set-id, must be wrapped */
}
#endif /* DOSUID */
PERL_UNUSED_ARG(validarg);
PERL_UNUSED_ARG(scriptname);
+ PERL_UNUSED_ARG(linestr_sv);
}
STATIC void
-S_find_beginning(pTHX)
+S_find_beginning(pTHX_ SV* linestr_sv, PerlIO *rsfp)
{
dVAR;
- register char *s;
+ const char *s;
register const char *s2;
#ifdef MACOS_TRADITIONAL
int maclines = 0;
/* Since the Mac OS does not honor #! arguments for us, we do it ourselves */
while (PL_doextract || gMacPerl_AlwaysExtract) {
- if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == NULL) {
+ if ((s = sv_gets(linestr_sv, rsfp, 0)) == NULL) {
if (!gMacPerl_AlwaysExtract)
Perl_croak(aTHX_ "No Perl script found in input\n");
PL_doextract = FALSE;
/* Pater peccavi, file does not have #! */
- PerlIO_rewind(PL_rsfp);
+ PerlIO_rewind(rsfp);
break;
}
#else
while (PL_doextract) {
- if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == NULL)
+ if ((s = sv_gets(linestr_sv, rsfp, 0)) == NULL)
Perl_croak(aTHX_ "No Perl script found in input\n");
#endif
s2 = s;
if (*s == '#' && s[1] == '!' && ((s = instr(s,"perl")) || (s = instr(s2,"PERL")))) {
- PerlIO_ungetc(PL_rsfp, '\n'); /* to keep line count right */
+ PerlIO_ungetc(rsfp, '\n'); /* to keep line count right */
PL_doextract = FALSE;
while (*s && !(isSPACE (*s) || *s == '#')) s++;
s2 = s;
* by counting lines we already skipped over
*/
for (; maclines > 0 ; maclines--)
- PerlIO_ungetc(PL_rsfp, '\n');
+ PerlIO_ungetc(rsfp, '\n');
break;
sv_setiv(PL_DBtrace, 0);
PL_DBsignal = GvSV((gv_fetchpvs("DB::signal", GV_ADDMULTI, SVt_PV)));
sv_setiv(PL_DBsignal, 0);
- PL_DBassertion = GvSV((gv_fetchpvs("DB::assertion", GV_ADDMULTI, SVt_PV)));
- sv_setiv(PL_DBassertion, 0);
PL_curstash = ostash;
}
Safefree(PL_savestack);
}
-STATIC void
-S_init_lexer(pTHX)
-{
- dVAR;
- PerlIO *tmpfp;
- tmpfp = PL_rsfp;
- PL_rsfp = NULL;
- lex_start(PL_linestr);
- PL_rsfp = tmpfp;
- PL_subname = newSVpvs("main");
-}
STATIC void
S_init_predump_symbols(pTHX)
dVAR;
GV* tmpgv;
- PL_toptarget = newSV(0);
- sv_upgrade(PL_toptarget, SVt_PVFM);
+ PL_toptarget = newSV_type(SVt_PVFM);
sv_setpvn(PL_toptarget, "", 0);
- PL_bodytarget = newSV(0);
- sv_upgrade(PL_bodytarget, SVt_PVFM);
+ PL_bodytarget = newSV_type(SVt_PVFM);
sv_setpvn(PL_bodytarget, "", 0);
PL_formtarget = PL_bodytarget;
}
if ((PL_envgv = gv_fetchpvs("ENV", GV_ADD|GV_NOTQUAL, SVt_PVHV))) {
HV *hv;
+ bool env_is_not_environ;
GvMULTI_on(PL_envgv);
hv = GvHVn(PL_envgv);
hv_magic(hv, NULL, PERL_MAGIC_env);
*/
if (!env)
env = environ;
- if (env != environ
+ env_is_not_environ = env != environ;
+ if (env_is_not_environ
# ifdef USE_ITHREADS
&& PL_curinterp == aTHX
# endif
environ[0] = NULL;
}
if (env) {
- char** origenv = environ;
char *s;
SV *sv;
for (; *env; env++) {
#endif
sv = newSVpv(s+1, 0);
(void)hv_store(hv, *env, s - *env, sv, 0);
- if (env != environ)
+ if (env_is_not_environ)
mg_set(sv);
- if (origenv != environ) {
- /* realloc has shifted us */
- env = (env - origenv) + environ;
- origenv = environ;
- }
}
}
#endif /* USE_ENVIRON_ARRAY */
if (PL_minus_a) {
(void) get_av("main::F", TRUE | GV_ADDMULTI);
}
- /* touch @- and @+ arrays to prevent spurious warnings 20020415 MJD */
- (void) get_av("main::-", TRUE | GV_ADDMULTI);
- (void) get_av("main::+", TRUE | GV_ADDMULTI);
}
STATIC void
#endif
/* .../version/archname if -d .../version/archname */
Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PATH PERL_ARCH_FMT,
- (void*)libdir,
+ SVfARG(libdir),
(int)PERL_REVISION, (int)PERL_VERSION,
(int)PERL_SUBVERSION, ARCHNAME);
subdir = S_incpush_if_exists(aTHX_ subdir);
/* .../version if -d .../version */
Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PATH,
- (void*)libdir,
+ SVfARG(libdir),
(int)PERL_REVISION, (int)PERL_VERSION,
(int)PERL_SUBVERSION);
subdir = S_incpush_if_exists(aTHX_ subdir);
/* .../archname if -d .../archname */
Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT,
- (void*)libdir, ARCHNAME);
+ SVfARG(libdir), ARCHNAME);
subdir = S_incpush_if_exists(aTHX_ subdir);
}
if (addoldvers) {
for (incver = incverlist; *incver; incver++) {
/* .../xxx if -d .../xxx */
- Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, (void *)libdir, *incver);
+ Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT,
+ SVfARG(libdir), *incver);
subdir = S_incpush_if_exists(aTHX_ subdir);
}
}
{
dVAR;
SV *atsv;
- const line_t oldline = CopLINE(PL_curcop);
+ volatile const line_t oldline = PL_curcop ? CopLINE(PL_curcop) : 0;
CV *cv;
STRLEN len;
int ret;
if (PL_savebegin) {
if (paramList == PL_beginav) {
/* save PL_beginav for compiler */
- if (! PL_beginav_save)
- PL_beginav_save = newAV();
- av_push(PL_beginav_save, (SV*)cv);
+ Perl_av_create_and_push(aTHX_ &PL_beginav_save, (SV*)cv);
}
else if (paramList == PL_checkav) {
/* save PL_checkav for compiler */
- if (! PL_checkav_save)
- PL_checkav_save = newAV();
- av_push(PL_checkav_save, (SV*)cv);
+ Perl_av_create_and_push(aTHX_ &PL_checkav_save, (SV*)cv);
}
else if (paramList == PL_unitcheckav) {
/* save PL_unitcheckav for compiler */
- if (! PL_unitcheckav_save)
- PL_unitcheckav_save = newAV();
- av_push(PL_unitcheckav_save, (SV*)cv);
+ Perl_av_create_and_push(aTHX_ &PL_unitcheckav_save, (SV*)cv);
}
} else {
if (!PL_madskills)
#endif
atsv = ERRSV;
(void)SvPV_const(atsv, len);
- if (PL_madskills && PL_minus_c && paramList == PL_beginav)
- break; /* not really trying to run, so just wing it */
if (len) {
PL_curcop = &PL_compiling;
CopLINE_set(PL_curcop, oldline);
while (PL_scopestack_ix > oldscope)
LEAVE;
JMPENV_POP;
- Perl_croak(aTHX_ "%"SVf"", (void*)atsv);
+ Perl_croak(aTHX_ "%"SVf"", SVfARG(atsv));
}
break;
case 1:
PL_curcop = &PL_compiling;
CopLINE_set(PL_curcop, oldline);
JMPENV_POP;
- if (PL_madskills && PL_minus_c && paramList == PL_beginav)
- return; /* not really trying to run, so just wing it */
if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED)) {
if (paramList == PL_beginav)
Perl_croak(aTHX_ "BEGIN failed--compilation aborted");
{
dVAR;
DEBUG_S(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
- thr, (unsigned long) status));
+ (void*)thr, (unsigned long) status));
switch (status) {
case 0:
STATUS_ALL_SUCCESS;
https://perl5.git.perl.org / perl5.git / blobdiff