/* perl.c
*
- * Copyright (c) 1987-2002 Larry Wall
+ * Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999,
+ * 2000, 2001, 2002, 2003, 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.
#include <unistd.h>
#endif
+#ifdef __BEOS__
+# define HZ 1000000
+#endif
+
+#ifndef HZ
+# ifdef CLK_TCK
+# define HZ CLK_TCK
+# else
+# define HZ 60
+# endif
+#endif
+
#if !defined(STANDARD_C) && !defined(HAS_GETENV_PROTOTYPE) && !defined(PERL_MICRO)
char *getenv (char *); /* Usually in <stdlib.h> */
#endif
#endif
#endif
-#if defined(USE_5005THREADS)
-# define INIT_TLS_AND_INTERP \
- STMT_START { \
- if (!PL_curinterp) { \
- PERL_SET_INTERP(my_perl); \
- INIT_THREADS; \
- ALLOC_THREAD_KEY; \
- } \
- } STMT_END
-#else
-# if defined(USE_ITHREADS)
+#if defined(USE_ITHREADS)
# define INIT_TLS_AND_INTERP \
STMT_START { \
if (!PL_curinterp) { \
ALLOC_THREAD_KEY; \
PERL_SET_THX(my_perl); \
OP_REFCNT_INIT; \
+ MUTEX_INIT(&PL_dollarzero_mutex); \
} \
else { \
PERL_SET_THX(my_perl); \
} \
} STMT_END
-# else
+#else
# define INIT_TLS_AND_INTERP \
STMT_START { \
if (!PL_curinterp) { \
PERL_SET_THX(my_perl); \
} STMT_END
# endif
-#endif
#ifdef PERL_IMPLICIT_SYS
PerlInterpreter *
void
perl_construct(pTHXx)
{
-#ifdef USE_5005THREADS
-#ifndef FAKE_THREADS
- struct perl_thread *thr = NULL;
-#endif /* FAKE_THREADS */
-#endif /* USE_5005THREADS */
-
#ifdef MULTIPLICITY
init_interp();
PL_perl_destruct_level = 1;
/* Init the real globals (and main thread)? */
if (!PL_linestr) {
-#ifdef USE_5005THREADS
- MUTEX_INIT(&PL_sv_mutex);
- /*
- * Safe to use basic SV functions from now on (though
- * not things like mortals or tainting yet).
- */
- MUTEX_INIT(&PL_eval_mutex);
- COND_INIT(&PL_eval_cond);
- MUTEX_INIT(&PL_threads_mutex);
- COND_INIT(&PL_nthreads_cond);
-# ifdef EMULATE_ATOMIC_REFCOUNTS
- MUTEX_INIT(&PL_svref_mutex);
-# endif /* EMULATE_ATOMIC_REFCOUNTS */
-
- MUTEX_INIT(&PL_cred_mutex);
- MUTEX_INIT(&PL_sv_lock_mutex);
- MUTEX_INIT(&PL_fdpid_mutex);
-
- thr = init_main_thread();
-#endif /* USE_5005THREADS */
-
#ifdef PERL_FLEXIBLE_EXCEPTIONS
PL_protect = MEMBER_TO_FPTR(Perl_default_protect); /* for exceptions */
#endif
*s = '\0';
SvCUR_set(PL_patchlevel, s - (U8*)SvPVX(PL_patchlevel));
SvPOK_on(PL_patchlevel);
- SvNVX(PL_patchlevel) = (NV)PERL_REVISION
- + ((NV)PERL_VERSION / (NV)1000)
-#if defined(PERL_SUBVERSION) && PERL_SUBVERSION > 0
- + ((NV)PERL_SUBVERSION / (NV)1000000)
-#endif
- ;
+ SvNVX(PL_patchlevel) = (NV)PERL_REVISION +
+ ((NV)PERL_VERSION / (NV)1000) +
+ ((NV)PERL_SUBVERSION / (NV)1000000);
SvNOK_on(PL_patchlevel); /* dual valued */
SvUTF8_on(PL_patchlevel);
SvREADONLY_on(PL_patchlevel);
It is properly deallocated in perl_destruct() */
PL_strtab = newHV();
-#ifdef USE_5005THREADS
- MUTEX_INIT(&PL_strtab_mutex);
-#endif
HvSHAREKEYS_off(PL_strtab); /* mandatory */
hv_ksplit(PL_strtab, 512);
PL_origenviron = environ;
#endif
+ /* Use sysconf(_SC_CLK_TCK) if available, if not
+ * available or if the sysconf() fails, use the HZ. */
+#if defined(HAS_SYSCONF) && defined(_SC_CLK_TCK)
+ PL_clocktick = sysconf(_SC_CLK_TCK);
+ if (PL_clocktick <= 0)
+#endif
+ PL_clocktick = HZ;
+
+ PL_stashcache = newHV();
+
ENTER;
}
volatile int destruct_level; /* 0=none, 1=full, 2=full with checks */
HV *hv;
#ifdef USE_5005THREADS
- Thread t;
dTHX;
#endif /* USE_5005THREADS */
/* wait for all pseudo-forked children to finish */
PERL_WAIT_FOR_CHILDREN;
-#ifdef USE_5005THREADS
-#ifndef FAKE_THREADS
- /* Pass 1 on any remaining threads: detach joinables, join zombies */
- retry_cleanup:
- MUTEX_LOCK(&PL_threads_mutex);
- DEBUG_S(PerlIO_printf(Perl_debug_log,
- "perl_destruct: waiting for %d threads...\n",
- PL_nthreads - 1));
- for (t = thr->next; t != thr; t = t->next) {
- MUTEX_LOCK(&t->mutex);
- switch (ThrSTATE(t)) {
- AV *av;
- case THRf_ZOMBIE:
- DEBUG_S(PerlIO_printf(Perl_debug_log,
- "perl_destruct: joining zombie %p\n", t));
- ThrSETSTATE(t, THRf_DEAD);
- MUTEX_UNLOCK(&t->mutex);
- PL_nthreads--;
- /*
- * The SvREFCNT_dec below may take a long time (e.g. av
- * may contain an object scalar whose destructor gets
- * called) so we have to unlock threads_mutex and start
- * all over again.
- */
- MUTEX_UNLOCK(&PL_threads_mutex);
- JOIN(t, &av);
- SvREFCNT_dec((SV*)av);
- DEBUG_S(PerlIO_printf(Perl_debug_log,
- "perl_destruct: joined zombie %p OK\n", t));
- goto retry_cleanup;
- case THRf_R_JOINABLE:
- DEBUG_S(PerlIO_printf(Perl_debug_log,
- "perl_destruct: detaching thread %p\n", t));
- ThrSETSTATE(t, THRf_R_DETACHED);
- /*
- * We unlock threads_mutex and t->mutex in the opposite order
- * from which we locked them just so that DETACH won't
- * deadlock if it panics. It's only a breach of good style
- * not a bug since they are unlocks not locks.
- */
- MUTEX_UNLOCK(&PL_threads_mutex);
- DETACH(t);
- MUTEX_UNLOCK(&t->mutex);
- goto retry_cleanup;
- default:
- DEBUG_S(PerlIO_printf(Perl_debug_log,
- "perl_destruct: ignoring %p (state %u)\n",
- t, ThrSTATE(t)));
- MUTEX_UNLOCK(&t->mutex);
- /* fall through and out */
- }
- }
- /* We leave the above "Pass 1" loop with threads_mutex still locked */
-
- /* Pass 2 on remaining threads: wait for the thread count to drop to one */
- while (PL_nthreads > 1)
- {
- DEBUG_S(PerlIO_printf(Perl_debug_log,
- "perl_destruct: final wait for %d threads\n",
- PL_nthreads - 1));
- COND_WAIT(&PL_nthreads_cond, &PL_threads_mutex);
- }
- /* At this point, we're the last thread */
- MUTEX_UNLOCK(&PL_threads_mutex);
- DEBUG_S(PerlIO_printf(Perl_debug_log, "perl_destruct: armageddon has arrived\n"));
- MUTEX_DESTROY(&PL_threads_mutex);
- COND_DESTROY(&PL_nthreads_cond);
- PL_nthreads--;
-#endif /* !defined(FAKE_THREADS) */
-#endif /* USE_5005THREADS */
-
destruct_level = PL_perl_destruct_level;
#ifdef DEBUGGING
{
FREETMPS;
/* Need to flush since END blocks can produce output */
- PerlIO_flush((PerlIO*)NULL);
+ my_fflush_all();
if (CALL_FPTR(PL_threadhook)(aTHX)) {
/* Threads hook has vetoed further cleanup */
- return STATUS_NATIVE_EXPORT;;
+ return STATUS_NATIVE_EXPORT;
}
/* We must account for everything. */
/* Destroy the main CV and syntax tree */
if (PL_main_root) {
- PL_curpad = AvARRAY(PL_comppad);
op_free(PL_main_root);
PL_main_root = Nullop;
}
Safefree(PL_exitlist);
+ PL_exitlist = NULL;
+ PL_exitlistlen = 0;
+
if (destruct_level == 0){
DEBUG_P(debprofdump());
#endif
/* The exit() function will do everything that needs doing. */
- return STATUS_NATIVE_EXPORT;;
+ return STATUS_NATIVE_EXPORT;
}
/* jettison our possibly duplicated environment */
* so we certainly shouldn't free it here
*/
#if defined(USE_ENVIRON_ARRAY) && !defined(PERL_USE_SAFE_PUTENV)
- if (environ != PL_origenviron) {
+ if (environ != PL_origenviron
+#ifdef USE_ITHREADS
+ /* only main thread can free environ[0] contents */
+ && PL_curinterp == aTHX
+#endif
+ )
+ {
I32 i;
for (i = 0; environ[i]; i++)
PL_regex_pad = NULL;
#endif
+ SvREFCNT_dec((SV*) PL_stashcache);
+ PL_stashcache = NULL;
+
/* loosen bonds of global variables */
if(PL_rsfp) {
PL_e_script = Nullsv;
}
- while (--PL_origargc >= 0) {
- Safefree(PL_origargv[PL_origargc]);
- }
- Safefree(PL_origargv);
-
/* magical thingies */
SvREFCNT_dec(PL_ofs_sv); /* $, */
SvREFCNT_dec(PL_beginav_save);
SvREFCNT_dec(PL_endav);
SvREFCNT_dec(PL_checkav);
+ SvREFCNT_dec(PL_checkav_save);
SvREFCNT_dec(PL_initav);
PL_beginav = Nullav;
PL_beginav_save = Nullav;
PL_endav = Nullav;
PL_checkav = Nullav;
+ PL_checkav_save = Nullav;
PL_initav = Nullav;
/* shortcuts just get cleared */
if (PL_sv_count != 0 && ckWARN_d(WARN_INTERNAL))
Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Scalars leaked: %ld\n", (long)PL_sv_count);
+#ifdef DEBUG_LEAKING_SCALARS
+ if (PL_sv_count != 0) {
+ SV* sva;
+ SV* sv;
+ register SV* svend;
+
+ for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) {
+ svend = &sva[SvREFCNT(sva)];
+ for (sv = sva + 1; sv < svend; ++sv) {
+ if (SvTYPE(sv) != SVTYPEMASK) {
+ PerlIO_printf(Perl_debug_log, "leaked: 0x%p\n", sv);
+ }
+ }
+ }
+ }
+#endif
+
+
#if defined(PERLIO_LAYERS)
/* No more IO - including error messages ! */
PerlIO_cleanup(aTHX);
if (PL_reg_curpm)
Safefree(PL_reg_curpm);
Safefree(PL_reg_poscache);
- Safefree(HeKEY_hek(&PL_hv_fetch_ent_mh));
+ free_tied_hv_pool();
Safefree(PL_op_mask);
Safefree(PL_psig_ptr);
Safefree(PL_psig_name);
PL_hints = 0; /* Reset hints. Should hints be per-interpreter ? */
DEBUG_P(debprofdump());
-#ifdef USE_5005THREADS
- MUTEX_DESTROY(&PL_strtab_mutex);
- MUTEX_DESTROY(&PL_sv_mutex);
- MUTEX_DESTROY(&PL_eval_mutex);
- MUTEX_DESTROY(&PL_cred_mutex);
- MUTEX_DESTROY(&PL_fdpid_mutex);
- COND_DESTROY(&PL_eval_cond);
-#ifdef EMULATE_ATOMIC_REFCOUNTS
- MUTEX_DESTROY(&PL_svref_mutex);
-#endif /* EMULATE_ATOMIC_REFCOUNTS */
-
- /* As the penultimate thing, free the non-arena SV for thrsv */
- Safefree(SvPVX(PL_thrsv));
- Safefree(SvANY(PL_thrsv));
- Safefree(PL_thrsv);
- PL_thrsv = Nullsv;
-#endif /* USE_5005THREADS */
#ifdef USE_REENTRANT_API
Perl_reentrant_free(aTHX);
#endif
PL_origargc = argc;
- {
- /* we copy rather than point to argv
- * since perl_clone will copy and perl_destruct
- * has no way of knowing if we've made a copy or
- * just point to argv
- */
- int i = PL_origargc;
- New(0, PL_origargv, i+1, char*);
- PL_origargv[i] = '\0';
- while (i-- > 0) {
- PL_origargv[i] = savepv(argv[i]);
- }
- }
-
-
+ PL_origargv = argv;
if (PL_do_undump) {
}
if (PL_main_root) {
- PL_curpad = AvARRAY(PL_comppad);
op_free(PL_main_root);
PL_main_root = Nullop;
}
int fdscript = -1;
VOL bool dosearch = FALSE;
char *validarg = "";
- AV* comppadlist;
register SV *sv;
register char *s;
char *cddir = Nullch;
reswitch:
switch (*s) {
case 'C':
-#ifdef WIN32
- win32_argv2utf8(argc-1, argv+1);
- /* FALL THROUGH */
-#endif
#ifndef PERL_STRICT_CR
case '\r':
#endif
case 'W':
case 'X':
case 'w':
+ case 'A':
if ((s = moreswitches(s)))
goto reswitch;
break;
#ifdef MACOS_TRADITIONAL
/* ignore -e for Dev:Pseudo argument */
if (argv[1] && !strcmp(argv[1], "Dev:Pseudo"))
- break;
+ break;
#endif
if (PL_euid != PL_uid || PL_egid != PL_gid)
Perl_croak(aTHX_ "No -e allowed in setuid scripts");
char *p;
STRLEN len = strlen(s);
p = savepvn(s, len);
- incpush(p, TRUE, TRUE);
+ incpush(p, TRUE, TRUE, FALSE);
sv_catpvn(sv, "-I", 2);
sv_catpvn(sv, p, len);
sv_catpvn(sv, " ", 1);
}
}
switch_end:
+ sv_setsv(get_sv("/", TRUE), PL_rs);
if (
#ifndef SECURE_INTERNAL_GETENV
d = s;
if (!*s)
break;
- if (!strchr("DIMUdmtw", *s))
+ if (!strchr("DIMUdmtwA", *s))
Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s);
while (++s && *s) {
if (isSPACE(*s)) {
sv_upgrade((SV *)PL_compcv, SVt_PVCV);
CvUNIQUE_on(PL_compcv);
- PL_comppad = newAV();
- av_push(PL_comppad, Nullsv);
- PL_curpad = AvARRAY(PL_comppad);
- PL_comppad_name = newAV();
- PL_comppad_name_fill = 0;
- PL_min_intro_pending = 0;
- PL_padix = 0;
+ CvPADLIST(PL_compcv) = pad_new(0);
#ifdef USE_5005THREADS
- av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
- PL_curpad[0] = (SV*)newAV();
- SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
CvOWNER(PL_compcv) = 0;
New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
MUTEX_INIT(CvMUTEXP(PL_compcv));
#endif /* USE_5005THREADS */
- comppadlist = newAV();
- AvREAL_off(comppadlist);
- av_store(comppadlist, 0, (SV*)PL_comppad_name);
- av_store(comppadlist, 1, (SV*)PL_comppad);
- CvPADLIST(PL_compcv) = comppadlist;
-
boot_core_PerlIO();
boot_core_UNIVERSAL();
#ifndef PERL_MICRO
if (!PL_do_undump)
init_postdump_symbols(argc,argv,env);
- if (PL_wantutf8) { /* Requires init_predump_symbols(). */
- IO* io;
- PerlIO* fp;
- SV* sv;
- if (PL_stdingv && (io = GvIO(PL_stdingv)) && (fp = IoIFP(io)))
- PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
- if (PL_defoutgv && (io = GvIO(PL_defoutgv)) && (fp = IoOFP(io)))
- PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
- if (PL_stderrgv && (io = GvIO(PL_stderrgv)) && (fp = IoOFP(io)))
- PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
- if ((sv = GvSV(gv_fetchpv("\017PEN", TRUE, SVt_PV)))) {
- sv_setpvn(sv, ":utf8\0:utf8", 11);
- SvSETMAGIC(sv);
+ /* PL_unicode is turned on by -C or by $ENV{PERL_UNICODE}.
+ * PL_utf8locale is conditionally turned on by
+ * locale.c:Perl_init_i18nl10n() if the environment
+ * look like the user wants to use UTF-8. */
+ if (PL_unicode) {
+ /* Requires init_predump_symbols(). */
+ if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) {
+ IO* io;
+ PerlIO* fp;
+ SV* sv;
+
+ /* Turn on UTF-8-ness on STDIN, STDOUT, STDERR
+ * and the default open disciplines. */
+ if ((PL_unicode & PERL_UNICODE_STDIN_FLAG) &&
+ PL_stdingv && (io = GvIO(PL_stdingv)) &&
+ (fp = IoIFP(io)))
+ PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
+ if ((PL_unicode & PERL_UNICODE_STDOUT_FLAG) &&
+ PL_defoutgv && (io = GvIO(PL_defoutgv)) &&
+ (fp = IoOFP(io)))
+ PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
+ if ((PL_unicode & PERL_UNICODE_STDERR_FLAG) &&
+ PL_stderrgv && (io = GvIO(PL_stderrgv)) &&
+ (fp = IoOFP(io)))
+ PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
+ if ((PL_unicode & PERL_UNICODE_INOUT_FLAG) &&
+ (sv = GvSV(gv_fetchpv("\017PEN", TRUE, SVt_PV)))) {
+ U32 in = PL_unicode & PERL_UNICODE_IN_FLAG;
+ U32 out = PL_unicode & PERL_UNICODE_OUT_FLAG;
+ if (in) {
+ if (out)
+ sv_setpvn(sv, ":utf8\0:utf8", 11);
+ else
+ sv_setpvn(sv, ":utf8\0", 6);
+ }
+ else if (out)
+ sv_setpvn(sv, "\0:utf8", 6);
+ SvSETMAGIC(sv);
+ }
}
}
+ if ((s = PerlEnv_getenv("PERL_SIGNALS"))) {
+ if (strEQ(s, "unsafe"))
+ PL_signals |= PERL_SIGNALS_UNSAFE_FLAG;
+ else if (strEQ(s, "safe"))
+ PL_signals &= ~PERL_SIGNALS_UNSAFE_FLAG;
+ else
+ Perl_croak(aTHX_ "PERL_SIGNALS illegal: \"%s\"", s);
+ }
+
init_lexer();
/* now parse the script */
- SETERRNO(0,SS$_NORMAL);
+ SETERRNO(0,SS_NORMAL);
PL_error_count = 0;
#ifdef MACOS_TRADITIONAL
if (gMacPerl_SyntaxError = (yyparse() || PL_error_count)) {
PL_e_script = Nullsv;
}
-/*
- Not sure that this is still the right place to do this now that we
- no longer use PL_nrs. HVDS 2001/09/09
-*/
- sv_setsv(get_sv("/", TRUE), PL_rs);
-
if (PL_do_undump)
my_unexec();
if (PL_minus_c) {
#ifdef MACOS_TRADITIONAL
- PerlIO_printf(Perl_error_log, "# %s syntax OK\n", MacPerl_MPWFileName(PL_origfilename));
+ PerlIO_printf(Perl_error_log, "%s%s syntax OK\n",
+ (gMacPerl_ErrorFormat ? "# " : ""),
+ MacPerl_MPWFileName(PL_origfilename));
#else
PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename);
#endif
Tells Perl to C<require> the file named by the string argument. It is
analogous to the Perl code C<eval "require '$file'">. It's even
-implemented that way; consider using Perl_load_module instead.
+implemented that way; consider using load_module instead.
=cut */
Perl_moreswitches(pTHX_ char *s)
{
STRLEN numlen;
- U32 rschar;
+ UV rschar;
switch (*s) {
case '0':
{
- I32 flags = 0;
- numlen = 4;
- rschar = (U32)grok_oct(s, &numlen, &flags, NULL);
- SvREFCNT_dec(PL_rs);
- if (rschar & ~((U8)~0))
- PL_rs = &PL_sv_undef;
- else if (!rschar && numlen >= 2)
- PL_rs = newSVpvn("", 0);
- else {
- char ch = (char)rschar;
- PL_rs = newSVpvn(&ch, 1);
- }
- return s + numlen;
+ I32 flags = 0;
+
+ SvREFCNT_dec(PL_rs);
+ if (s[1] == 'x' && s[2]) {
+ char *e;
+ U8 *tmps;
+
+ for (s += 2, e = s; *e; e++);
+ numlen = e - s;
+ flags = PERL_SCAN_SILENT_ILLDIGIT;
+ rschar = (U32)grok_hex(s, &numlen, &flags, NULL);
+ if (s + numlen < e) {
+ rschar = 0; /* Grandfather -0xFOO as -0 -xFOO. */
+ numlen = 0;
+ s--;
+ }
+ PL_rs = newSVpvn("", 0);
+ SvGROW(PL_rs, (STRLEN)(UNISKIP(rschar) + 1));
+ tmps = (U8*)SvPVX(PL_rs);
+ uvchr_to_utf8(tmps, rschar);
+ SvCUR_set(PL_rs, UNISKIP(rschar));
+ SvUTF8_on(PL_rs);
+ }
+ else {
+ numlen = 4;
+ rschar = (U32)grok_oct(s, &numlen, &flags, NULL);
+ if (rschar & ~((U8)~0))
+ PL_rs = &PL_sv_undef;
+ else if (!rschar && numlen >= 2)
+ PL_rs = newSVpvn("", 0);
+ else {
+ char ch = (char)rschar;
+ PL_rs = newSVpvn(&ch, 1);
+ }
+ }
+ return s + numlen;
}
case 'C':
- PL_widesyscalls = TRUE;
- s++;
+ s++;
+ PL_unicode = parse_unicode_opts(&s);
return s;
case 'F':
PL_minus_F = TRUE;
forbid_setid("-D");
if (isALPHA(s[1])) {
/* if adding extra options, remember to update DEBUG_MASK */
- static char debopts[] = "psltocPmfrxuLHXDSTRJ";
+ static char debopts[] = "psltocPmfrxu HXDSTRJvC";
char *d;
for (s++; *s && (d = strchr(debopts,*s)); s++)
}
case 'h':
usage(PL_origargv[0]);
- PerlProc_exit(0);
+ my_exit(0);
case 'i':
if (PL_inplace)
Safefree(PL_inplace);
+#if defined(__CYGWIN__) /* do backup extension automagically */
+ if (*(s+1) == '\0') {
+ PL_inplace = savepv(".bak");
+ return s+1;
+ }
+#endif /* __CYGWIN__ */
PL_inplace = savepv(s+1);
/*SUPPRESS 530*/
for (s = PL_inplace; *s && !isSPACE(*s); s++) ;
p++;
} while (*p && *p != '-');
e = savepvn(s, e-s);
- incpush(e, TRUE, TRUE);
+ incpush(e, TRUE, TRUE, FALSE);
Safefree(e);
s = p;
if (*s == '-')
}
}
return s;
+ case 'A':
+ forbid_setid("-A");
+ if (!PL_preambleav)
+ PL_preambleav = newAV();
+ if (*++s) {
+ SV *sv = newSVpvn("use assertions::activate split(/,/,q{",37);
+ sv_catpv(sv,s);
+ sv_catpv(sv,"})");
+ s+=strlen(s);
+ av_push(PL_preambleav, sv);
+ }
+ else
+ av_push(PL_preambleav, newSVpvn("use assertions::activate",24));
+ return s;
case 'M':
forbid_setid("-M"); /* XXX ? */
/* FALL THROUGH */
#endif
PerlIO_printf(PerlIO_stdout(),
- "\n\nCopyright 1987-2002, Larry Wall\n");
+ "\n\nCopyright 1987-2003, Larry Wall\n");
#ifdef MACOS_TRADITIONAL
PerlIO_printf(PerlIO_stdout(),
"\nMac OS port Copyright 1991-2002, Matthias Neeracher;\n"
"EPOC port by Olaf Flebbe, 1999-2002\n");
#endif
#ifdef UNDER_CE
- printf("WINCE port by Rainer Keuchel, 2001-2002\n");
- printf("Built on " __DATE__ " " __TIME__ "\n\n");
+ PerlIO_printf(PerlIO_stdout(),"WINCE port by Rainer Keuchel, 2001-2002\n");
+ PerlIO_printf(PerlIO_stdout(),"Built on " __DATE__ " " __TIME__ "\n\n");
wce_hitreturn();
#endif
#ifdef BINARY_BUILD_NOTICE
Complete documentation for Perl, including FAQ lists, should be found on\n\
this system using `man perl' or `perldoc perl'. If you have access to the\n\
Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n");
- PerlProc_exit(0);
+ my_exit(0);
case 'w':
if (! (PL_dowarn & G_WARN_ALL_MASK))
PL_dowarn |= G_WARN_ON;
CopSTASH_set(&PL_compiling, PL_defstash);
PL_debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
PL_globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
- PL_nullstash = GvHV(gv_fetchpv("<none>::", GV_ADDMULTI, SVt_PVHV));
/* We must init $/ before switches are processed. */
sv_setpvn(get_sv("/", TRUE), "\n", 1);
}
S_find_beginning(pTHX)
{
register char *s, *s2;
+#ifdef MACOS_TRADITIONAL
+ int maclines = 0;
+#endif
/* skip forward in input to the real script? */
if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
if (!gMacPerl_AlwaysExtract)
Perl_croak(aTHX_ "No Perl script found in input\n");
-
+
if (PL_doextract) /* require explicit override ? */
if (!OverrideExtract(PL_origfilename))
Perl_croak(aTHX_ "User aborted script\n");
else
PL_doextract = FALSE;
-
+
/* Pater peccavi, file does not have #! */
PerlIO_rewind(PL_rsfp);
-
+
break;
}
#else
;
}
#ifdef MACOS_TRADITIONAL
+ /* We are always searching for the #!perl line in MacPerl,
+ * so if we find it, still keep the line count correct
+ * by counting lines we already skipped over
+ */
+ for (; maclines > 0 ; maclines--)
+ PerlIO_ungetc(PL_rsfp, '\n');
+
break;
+
+ /* gMacPerl_AlwaysExtract is false in MPW tool */
+ } else if (gMacPerl_AlwaysExtract) {
+ ++maclines;
#endif
}
}
sv_setiv(PL_DBtrace, 0);
PL_DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
sv_setiv(PL_DBsignal, 0);
+ PL_DBassertion = GvSV((gv_fetchpv("assertion", GV_ADDMULTI, SVt_PV)));
+ sv_setiv(PL_DBassertion, 0);
PL_curstash = ostash;
}
for (; argc > 0; argc--,argv++) {
SV *sv = newSVpv(argv[0],0);
av_push(GvAVn(PL_argvgv),sv);
- if (PL_widesyscalls)
- (void)sv_utf8_decode(sv);
+ if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) {
+ if (PL_unicode & PERL_UNICODE_ARGV_FLAG)
+ SvUTF8_on(sv);
+ }
+ if (PL_unicode & PERL_UNICODE_WIDESYSCALLS_FLAG) /* Sarathy? */
+ (void)sv_utf8_decode(sv);
}
}
}
{
char buf[MAXPATHLEN];
int len = readlink(PROCSELFEXE_PATH, buf, sizeof(buf) - 1);
+
+ /* On Playstation2 Linux V1.0 (kernel 2.2.1) readlink(/proc/self/exe)
+ includes a spurious NUL which will cause $^X to fail in system
+ or backticks (this will prevent extensions from being built and
+ many tests from working). readlink is not meant to add a NUL.
+ Normal readlink works fine.
+ */
+ if (len > 0 && buf[len-1] == '\0') {
+ len--;
+ }
+
/* FreeBSD's implementation is acknowledged to be imperfect, sometimes
returning the text "unknown" from the readlink rather than the path
to the executable (or returning an error from the readlink). Any valid
char *s;
SV *sv;
GV* tmpgv;
+#ifdef NEED_ENVIRON_DUP_FOR_MODIFY
+ char **dup_env_base = 0;
+ int dup_env_count = 0;
+#endif
PL_toptarget = NEWSV(0,0);
sv_upgrade(PL_toptarget, SVt_PVFM);
*/
if (!env)
env = environ;
- if (env != environ)
+ if (env != environ
+# ifdef USE_ITHREADS
+ && PL_curinterp == aTHX
+# endif
+ )
+ {
environ[0] = Nullch;
+ }
+#ifdef NEED_ENVIRON_DUP_FOR_MODIFY
+ {
+ char **env_base;
+ for (env_base = env; *env; env++)
+ dup_env_count++;
+ if ((dup_env_base = (char **)
+ safesysmalloc( sizeof(char *) * (dup_env_count+1) ))) {
+ char **dup_env;
+ for (env = env_base, dup_env = dup_env_base;
+ *env;
+ env++, dup_env++) {
+ /* With environ one needs to use safesysmalloc(). */
+ *dup_env = safesysmalloc(strlen(*env) + 1);
+ (void)strcpy(*dup_env, *env);
+ }
+ *dup_env = Nullch;
+ env = dup_env_base;
+ } /* else what? */
+ }
+#endif /* NEED_ENVIRON_DUP_FOR_MODIFY */
if (env)
for (; *env; env++) {
if (!(s = strchr(*env,'=')))
if (env != environ)
mg_set(sv);
}
+#ifdef NEED_ENVIRON_DUP_FOR_MODIFY
+ if (dup_env_base) {
+ char **dup_env;
+ for (dup_env = dup_env_base; *dup_env; dup_env++)
+ safesysfree(*dup_env);
+ safesysfree(dup_env_base);
+ }
+#endif /* NEED_ENVIRON_DUP_FOR_MODIFY */
#endif /* USE_ENVIRON_ARRAY */
}
TAINT_NOT;
sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
SvREADONLY_on(GvSV(tmpgv));
}
+#ifdef THREADS_HAVE_PIDS
+ PL_ppid = (IV)getppid();
+#endif
/* touch @F array to prevent spurious warnings 20020415 MJD */
if (PL_minus_a) {
#ifndef VMS
s = PerlEnv_getenv("PERL5LIB");
if (s)
- incpush(s, TRUE, TRUE);
+ incpush(s, TRUE, TRUE, TRUE);
else
- incpush(PerlEnv_getenv("PERLLIB"), FALSE, FALSE);
+ incpush(PerlEnv_getenv("PERLLIB"), FALSE, FALSE, TRUE);
#else /* VMS */
/* Treat PERL5?LIB as a possible search list logical name -- the
* "natural" VMS idiom for a Unix path string. We allow each
char buf[256];
int idx = 0;
if (my_trnlnm("PERL5LIB",buf,0))
- do { incpush(buf,TRUE,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
+ do { incpush(buf,TRUE,TRUE,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
else
- while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE,FALSE);
+ while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE,FALSE,TRUE);
#endif /* VMS */
}
ARCHLIB PRIVLIB SITEARCH SITELIB VENDORARCH and VENDORLIB
*/
#ifdef APPLLIB_EXP
- incpush(APPLLIB_EXP, TRUE, TRUE);
+ incpush(APPLLIB_EXP, TRUE, TRUE, TRUE);
#endif
#ifdef ARCHLIB_EXP
- incpush(ARCHLIB_EXP, FALSE, FALSE);
+ incpush(ARCHLIB_EXP, FALSE, FALSE, TRUE);
#endif
#ifdef MACOS_TRADITIONAL
{
Perl_sv_setpvf(aTHX_ privdir, "%slib:", macperl);
if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode))
- incpush(SvPVX(privdir), TRUE, FALSE);
+ incpush(SvPVX(privdir), TRUE, FALSE, TRUE);
Perl_sv_setpvf(aTHX_ privdir, "%ssite_perl:", macperl);
if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode))
- incpush(SvPVX(privdir), TRUE, FALSE);
+ incpush(SvPVX(privdir), TRUE, FALSE, TRUE);
SvREFCNT_dec(privdir);
}
if (!PL_tainting)
- incpush(":", FALSE, FALSE);
+ incpush(":", FALSE, FALSE, TRUE);
#else
#ifndef PRIVLIB_EXP
# define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
#endif
#if defined(WIN32)
- incpush(PRIVLIB_EXP, TRUE, FALSE);
+ incpush(PRIVLIB_EXP, TRUE, FALSE, TRUE);
#else
- incpush(PRIVLIB_EXP, FALSE, FALSE);
+ incpush(PRIVLIB_EXP, FALSE, FALSE, TRUE);
#endif
#ifdef SITEARCH_EXP
/* sitearch is always relative to sitelib on Windows for
* DLL-based path intuition to work correctly */
# if !defined(WIN32)
- incpush(SITEARCH_EXP, FALSE, FALSE);
+ incpush(SITEARCH_EXP, FALSE, FALSE, TRUE);
# endif
#endif
#ifdef SITELIB_EXP
# if defined(WIN32)
- incpush(SITELIB_EXP, TRUE, FALSE); /* this picks up sitearch as well */
+ /* this picks up sitearch as well */
+ incpush(SITELIB_EXP, TRUE, FALSE, TRUE);
# else
- incpush(SITELIB_EXP, FALSE, FALSE);
+ incpush(SITELIB_EXP, FALSE, FALSE, TRUE);
# endif
#endif
#ifdef SITELIB_STEM /* Search for version-specific dirs below here */
- incpush(SITELIB_STEM, FALSE, TRUE);
+ incpush(SITELIB_STEM, FALSE, TRUE, TRUE);
#endif
#ifdef PERL_VENDORARCH_EXP
/* vendorarch is always relative to vendorlib on Windows for
* DLL-based path intuition to work correctly */
# if !defined(WIN32)
- incpush(PERL_VENDORARCH_EXP, FALSE, FALSE);
+ incpush(PERL_VENDORARCH_EXP, FALSE, FALSE, TRUE);
# endif
#endif
#ifdef PERL_VENDORLIB_EXP
# if defined(WIN32)
- incpush(PERL_VENDORLIB_EXP, TRUE, FALSE); /* this picks up vendorarch as well */
+ incpush(PERL_VENDORLIB_EXP, TRUE, FALSE, TRUE); /* this picks up vendorarch as well */
# else
- incpush(PERL_VENDORLIB_EXP, FALSE, FALSE);
+ incpush(PERL_VENDORLIB_EXP, FALSE, FALSE, TRUE);
# endif
#endif
#ifdef PERL_VENDORLIB_STEM /* Search for version-specific dirs below here */
- incpush(PERL_VENDORLIB_STEM, FALSE, TRUE);
+ incpush(PERL_VENDORLIB_STEM, FALSE, TRUE, TRUE);
#endif
#ifdef PERL_OTHERLIBDIRS
- incpush(PERL_OTHERLIBDIRS, TRUE, TRUE);
+ incpush(PERL_OTHERLIBDIRS, TRUE, TRUE, TRUE);
#endif
if (!PL_tainting)
- incpush(".", FALSE, FALSE);
+ incpush(".", FALSE, FALSE, TRUE);
#endif /* MACOS_TRADITIONAL */
}
#endif
STATIC void
-S_incpush(pTHX_ char *p, int addsubdirs, int addoldvers)
+S_incpush(pTHX_ char *p, int addsubdirs, int addoldvers, int usesep)
{
SV *subdir = Nullsv;
char *s;
/* skip any consecutive separators */
- while ( *p == PERLLIB_SEP ) {
- /* Uncomment the next line for PATH semantics */
- /* av_push(GvAVn(PL_incgv), newSVpvn(".", 1)); */
- p++;
+ if (usesep) {
+ while ( *p == PERLLIB_SEP ) {
+ /* Uncomment the next line for PATH semantics */
+ /* av_push(GvAVn(PL_incgv), newSVpvn(".", 1)); */
+ p++;
+ }
}
- if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
+ if ( usesep && (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
(STRLEN)(s - p));
p = s + 1;
p = Nullch; /* break out */
}
#ifdef MACOS_TRADITIONAL
- if (!strchr(SvPVX(libdir), ':'))
- sv_insert(libdir, 0, 0, ":", 1);
+ if (!strchr(SvPVX(libdir), ':')) {
+ char buf[256];
+
+ sv_setpv(libdir, MacPerl_CanonDir(SvPVX(libdir), buf, 0));
+ }
if (SvPVX(libdir)[SvCUR(libdir)-1] != ':')
sv_catpv(libdir, ":");
#endif
while (AvFILL(paramList) >= 0) {
cv = (CV*)av_shift(paramList);
- if (PL_savebegin && (paramList == PL_beginav)) {
+ 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);
+ if (! PL_beginav_save)
+ PL_beginav_save = newAV();
+ av_push(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);
+ }
} else {
SAVEFREESV(cv);
}
atsv = ERRSV;
(void)SvPV(atsv, len);
if (len) {
- STRLEN n_a;
PL_curcop = &PL_compiling;
CopLINE_set(PL_curcop, oldline);
if (paramList == PL_beginav)
while (PL_scopestack_ix > oldscope)
LEAVE;
JMPENV_POP;
- Perl_croak(aTHX_ "%s", SvPVx(atsv, n_a));
+ Perl_croak(aTHX_ "%"SVf"", atsv);
}
break;
case 1: