/* perl.c
*
* Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001
- * 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 by Larry Wall
- * and others
+ * 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
+ * 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.
* function of the interpreter; that can be found in perlmain.c
*/
+#ifdef PERL_IS_MINIPERL
+# define USE_SITECUSTOMIZE
+#endif
+
#include "EXTERN.h"
#define PERL_IN_PERL_C
#include "perl.h"
JMPENV_PUSH(x);
PERL_UNUSED_VAR(x);
- if (PL_endav && !PL_minus_c)
+ if (PL_endav && !PL_minus_c) {
+ PL_phase = PERL_PHASE_END;
call_list(PL_scopestack_ix, PL_endav);
+ }
JMPENV_POP;
}
LEAVE;
* destruct_level > 0 */
SvREFCNT_dec(PL_main_cv);
PL_main_cv = NULL;
- PL_dirty = TRUE;
+ PL_phase = PERL_PHASE_DESTRUCT;
/* Tell PerlIO we are about to tear things apart in case
we have layers which are using resources that should
SvREFCNT_dec(PL_utf8_tofold);
SvREFCNT_dec(PL_utf8_idstart);
SvREFCNT_dec(PL_utf8_idcont);
+ SvREFCNT_dec(PL_utf8_foldclosures);
PL_utf8_alnum = NULL;
PL_utf8_ascii = NULL;
PL_utf8_alpha = NULL;
PL_utf8_tofold = NULL;
PL_utf8_idstart = NULL;
PL_utf8_idcont = NULL;
+ PL_utf8_foldclosures = NULL;
if (!specialWARN(PL_compiling.cop_warnings))
PerlMemShared_free(PL_compiling.cop_warnings);
PL_compiling.cop_warnings = NULL;
- Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash);
- PL_compiling.cop_hints_hash = NULL;
+ cophh_free(CopHINTHASH_get(&PL_compiling));
+ CopHINTHASH_set(&PL_compiling, cophh_new_empty());
CopFILE_free(&PL_compiling);
CopSTASH_free(&PL_compiling);
#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_rehash_seed (and assumedly also PL_rehash_seed_set)
+ * If you set PL_rehash_seed (and presumably 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_rehash_seed_set)
switch (ret) {
case 0:
parse_body(env,xsinit);
- if (PL_unitcheckav)
+ if (PL_unitcheckav) {
call_list(oldscope, PL_unitcheckav);
- if (PL_checkav)
+ }
+ if (PL_checkav) {
+ PL_phase = PERL_PHASE_CHECK;
call_list(oldscope, PL_checkav);
+ }
ret = 0;
break;
case 1:
LEAVE;
FREETMPS;
PL_curstash = PL_defstash;
- if (PL_unitcheckav)
+ if (PL_unitcheckav) {
call_list(oldscope, PL_unitcheckav);
- if (PL_checkav)
+ }
+ if (PL_checkav) {
+ PL_phase = PERL_PHASE_CHECK;
call_list(oldscope, PL_checkav);
+ }
ret = STATUS_EXIT;
break;
case 3:
# ifdef PERL_MEM_LOG_NOIMPL
" PERL_MEM_LOG_NOIMPL"
# endif
+# ifdef PERL_PRESERVE_IVUV
+ " PERL_PRESERVE_IVUV"
+# endif
# ifdef PERL_USE_DEVEL
" PERL_USE_DEVEL"
# endif
SV *linestr_sv = newSV_type(SVt_PVIV);
bool add_read_e_script = FALSE;
+ PL_phase = PERL_PHASE_START;
+
SvGROW(linestr_sv, 80);
sv_setpvs(linestr_sv,"");
}
}
-#if defined(USE_SITECUSTOMIZE) && !defined(PERL_IS_MINIPERL)
+#if defined(USE_SITECUSTOMIZE)
if (!minus_f) {
- /* SITELIB_EXP is a function call on Win32.
- The games with local $! are to avoid setting errno if there is no
+ /* The games with local $! are to avoid setting errno if there is no
sitecustomize script. */
+# ifdef PERL_IS_MINIPERL
+ AV *const inc = GvAV(PL_incgv);
+ SV **const inc0 = inc ? av_fetch(inc, 0, FALSE) : NULL;
+
+ if (inc0) {
+ (void)Perl_av_create_and_unshift_one(aTHX_ &PL_preambleav,
+ Perl_newSVpvf(aTHX_
+ "BEGIN { do {local $!; -f '%"SVf"/buildcustomize.pl'} && do '%"SVf"/buildcustomize.pl' }", *inc0, *inc0));
+ }
+# else
+ /* SITELIB_EXP is a function call on Win32. */
const char *const sitelib = SITELIB_EXP;
(void)Perl_av_create_and_unshift_one(aTHX_ &PL_preambleav,
Perl_newSVpvf(aTHX_
"BEGIN { do {local $!; -f '%s/sitecustomize.pl'} && do '%s/sitecustomize.pl' }", sitelib, sitelib));
+# endif
}
#endif
}
#endif
- lex_start(linestr_sv, rsfp);
+ lex_start(linestr_sv, rsfp, 0);
PL_subname = newSVpvs("main");
if (add_read_e_script)
FREETMPS;
PL_curstash = PL_defstash;
if (!(PL_exit_flags & PERL_EXIT_DESTRUCT_END) &&
- PL_endav && !PL_minus_c)
+ PL_endav && !PL_minus_c) {
+ PL_phase = PERL_PHASE_END;
call_list(oldscope, PL_endav);
+ }
#ifdef MYMALLOC
if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
dump_mstats("after execution: ");
}
if (PERLDB_SINGLE && PL_DBsingle)
sv_setiv(PL_DBsingle, 1);
- if (PL_initav)
+ if (PL_initav) {
+ PL_phase = PERL_PHASE_INIT;
call_list(oldscope, PL_initav);
+ }
#ifdef PERL_DEBUG_READONLY_OPS
Perl_pending_Slabs_to_ro(aTHX);
#endif
/* do it */
+ PL_phase = PERL_PHASE_RUN;
+
if (PL_restartop) {
PL_restartjmpenv = NULL;
PL_op = PL_restartop;
/* The following permits -d:Mod to accepts arguments following an =
in the fashion that -MSome::Mod does. */
if (*s == ':' || *s == '=') {
- const char *start = ++s;
- const char *const end = s + strlen(s);
- SV * const sv = newSVpvs("use Devel::");
+ const char *start;
+ const char *end;
+ SV *sv;
+
+ if (*++s == '-') {
+ ++s;
+ sv = newSVpvs("no Devel::");
+ } else {
+ sv = newSVpvs("use Devel::");
+ }
- /* We now allow -d:Module=Foo,Bar */
+ start = s;
+ end = s + strlen(s);
+
+ /* We now allow -d:Module=Foo,Bar and -d:-Module */
while(isALNUM(*s) || *s==':') ++s;
if (*s != '=')
sv_catpvn(sv, start, end - start);
#endif
PerlIO_printf(PerlIO_stdout(),
- "\n\nCopyright 1987-2010, Larry Wall\n");
+ "\n\nCopyright 1987-2011, Larry Wall\n");
#ifdef MSDOS
PerlIO_printf(PerlIO_stdout(),
"\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
# define PERLLIB_MANGLE(s,n) (s)
#endif
+#ifndef PERL_IS_MINIPERL
/* Push a directory onto @INC if it exists.
Generate a new SV if we do this, to save needing to copy the SV we push
onto @INC */
}
return dir;
}
+#endif
STATIC void
S_incpush(pTHX_ const char *const dir, STRLEN len, U32 flags)
{
dVAR;
+#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);
#ifdef PERL_INC_VERSION_LIST
const U8 addoldvers = (U8)flags & INCPUSH_ADD_OLD_VERS;
#endif
+#endif
const U8 canrelocate = (U8)flags & INCPUSH_CAN_RELOCATE;
const U8 unshift = (U8)flags & INCPUSH_UNSHIFT;
const U8 push_basedir = (flags & INCPUSH_NOT_BASEDIR) ? 0 : 1;
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;
+#endif
if (len) {
/* I am not convinced that this is valid when PERLLIB_MANGLE is
libdir = newSVpv(PERLLIB_MANGLE(dir, 0), 0);
}
+#ifdef VMS
+ char *unix;
+ STRLEN len;
+
+ if ((unix = tounixspec_ts(SvPV(libdir,len),NULL)) != NULL) {
+ len = strlen(unix);
+ while (unix[len-1] == '/') len--; /* Cosmetic */
+ sv_usepvn(libdir,unix,len);
+ }
+ else
+ PerlIO_printf(Perl_error_log,
+ "Failed to unixify @INC element \"%s\"\n",
+ SvPV(libdir,len));
+#endif
+
/* Do the if() outside the #ifdef to avoid warnings about an unused
parameter. */
if (canrelocate) {
libdir = tempsv;
if (PL_tainting &&
(PL_uid != PL_euid || PL_gid != PL_egid)) {
- /* Need to taint reloccated paths if running set ID */
+ /* Need to taint relocated paths if running set ID */
SvTAINTED_on(libdir);
}
}
}
#endif
}
+#ifndef PERL_IS_MINIPERL
/*
* BEFORE pushing libdir onto @INC we may first push version- and
* archname-specific sub-directories.
const char * const incverlist[] = { PERL_INC_VERSION_LIST };
const char * const *incver;
#endif
-#ifdef VMS
- char *unix;
- STRLEN len;
-
-
- if ((unix = tounixspec_ts(SvPV(libdir,len),NULL)) != NULL) {
- len = strlen(unix);
- while (unix[len-1] == '/') len--; /* Cosmetic */
- sv_usepvn(libdir,unix,len);
- }
- else
- PerlIO_printf(Perl_error_log,
- "Failed to unixify @INC element \"%s\"\n",
- SvPV(libdir,len));
-#endif
-
subdir = newSVsv(libdir);
if (add_versioned_sub_dirs) {
assert (SvREFCNT(subdir) == 1);
SvREFCNT_dec(subdir);
}
-
+#endif /* !PERL_IS_MINIPERL */
/* finally add this lib directory at the end of @INC */
if (unshift) {
+#ifdef PERL_IS_MINIPERL
+ const U32 extra = 0;
+#else
U32 extra = av_len(av) + 1;
+#endif
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.
av_store(inc, extra, SvREFCNT_inc(*av_fetch(av, extra, FALSE)));
}
SvREFCNT_dec(av);
+#endif
}
else if (push_basedir) {
av_push(inc, libdir);
PERL_ARGS_ASSERT_INCPUSH_USE_SEP;
+ /* perl compiled with -DPERL_RELOCATABLE_INCPUSH will ignore the len
+ * argument to incpush_use_sep. This allows creation of relocatable
+ * Perl distributions that patch the binary at install time. Those
+ * distributions will have to provide their own relocation tools; this
+ * is not a feature otherwise supported by core Perl.
+ */
+#ifndef PERL_RELOCATABLE_INCPUSH
if (!len)
+#endif
len = strlen(p);
end = p + len;
https://perl5.git.perl.org / perl5.git / blobdiff