diff options
author | Mark Murray <markm@FreeBSD.org> | 2000-06-25 13:05:26 +0000 |
---|---|---|
committer | Mark Murray <markm@FreeBSD.org> | 2000-06-25 13:05:26 +0000 |
commit | 2b0d64b9da1b2e24ecaf4b28514ec00c6a8ab27a (patch) | |
tree | 439edbdcd5a8f1175d63eb846db2a31fde8d4fb6 /contrib | |
parent | 5bd17c648f0bbb4ad71945d610980dae7c796874 (diff) | |
download | src-2b0d64b9da1b2e24ecaf4b28514ec00c6a8ab27a.tar.gz src-2b0d64b9da1b2e24ecaf4b28514ec00c6a8ab27a.zip |
Resolve conflicts.
Notes
Notes:
svn path=/head/; revision=62079
Diffstat (limited to 'contrib')
-rw-r--r-- | contrib/perl5/perl.c | 1876 | ||||
-rw-r--r-- | contrib/perl5/perl.h | 1932 |
2 files changed, 2596 insertions, 1212 deletions
diff --git a/contrib/perl5/perl.c b/contrib/perl5/perl.c index cc1f7edd132c..54262204dff2 100644 --- a/contrib/perl5/perl.c +++ b/contrib/perl5/perl.c @@ -1,10 +1,11 @@ /* perl.c * - * Copyright (c) 1987-1999 Larry Wall + * Copyright (c) 1987-2000 Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. * + * $FreeBSD$ */ /* @@ -12,8 +13,9 @@ */ #include "EXTERN.h" +#define PERL_IN_PERL_C #include "perl.h" -#include "patchlevel.h" +#include "patchlevel.h" /* for local_patches */ /* XXX If this causes problems, set i_unistd=undef in the hint file. */ #ifdef I_UNISTD @@ -21,15 +23,10 @@ #endif #if !defined(STANDARD_C) && !defined(HAS_GETENV_PROTOTYPE) -char *getenv _((char *)); /* Usually in <stdlib.h> */ +char *getenv (char *); /* Usually in <stdlib.h> */ #endif -#ifdef I_FCNTL -#include <fcntl.h> -#endif -#ifdef I_SYS_FILE -#include <sys/file.h> -#endif +static I32 read_e_script(pTHXo_ int idx, SV *buf_sv, int maxlen); #ifdef IAMSUID #ifndef DOSUID @@ -44,92 +41,133 @@ char *getenv _((char *)); /* Usually in <stdlib.h> */ #endif #ifdef PERL_OBJECT -static I32 read_e_script _((CPerlObj* pPerl, int idx, SV *buf_sv, int maxlen)); +#define perl_construct Perl_construct +#define perl_parse Perl_parse +#define perl_run Perl_run +#define perl_destruct Perl_destruct +#define perl_free Perl_free +#endif + +#if defined(USE_THREADS) +# define INIT_TLS_AND_INTERP \ + STMT_START { \ + if (!PL_curinterp) { \ + PERL_SET_INTERP(my_perl); \ + INIT_THREADS; \ + ALLOC_THREAD_KEY; \ + } \ + } STMT_END #else -static void find_beginning _((void)); -static void forbid_setid _((char *)); -static void incpush _((char *, int)); -static void init_interp _((void)); -static void init_ids _((void)); -static void init_debugger _((void)); -static void init_lexer _((void)); -static void init_main_stash _((void)); -#ifdef USE_THREADS -static struct perl_thread * init_main_thread _((void)); -#endif /* USE_THREADS */ -static void init_perllib _((void)); -static void init_postdump_symbols _((int, char **, char **)); -static void init_predump_symbols _((void)); -static void my_exit_jump _((void)) __attribute__((noreturn)); -static void nuke_stacks _((void)); -static void open_script _((char *, bool, SV *, int *fd)); -static void usage _((char *)); -#ifdef IAMSUID -static int fd_on_nosuid_fs _((int)); -#endif -static void validate_suid _((char *, char*, int)); -static I32 read_e_script _((int idx, SV *buf_sv, int maxlen)); +# if defined(USE_ITHREADS) +# define INIT_TLS_AND_INTERP \ + STMT_START { \ + if (!PL_curinterp) { \ + PERL_SET_INTERP(my_perl); \ + INIT_THREADS; \ + ALLOC_THREAD_KEY; \ + PERL_SET_THX(my_perl); \ + OP_REFCNT_INIT; \ + } \ + else { \ + PERL_SET_THX(my_perl); \ + } \ + } STMT_END +# else +# define INIT_TLS_AND_INTERP \ + STMT_START { \ + if (!PL_curinterp) { \ + PERL_SET_INTERP(my_perl); \ + } \ + PERL_SET_THX(my_perl); \ + } STMT_END +# endif #endif -#ifdef PERL_OBJECT -CPerlObj* perl_alloc(IPerlMem* ipM, IPerlEnv* ipE, IPerlStdIO* ipStd, - IPerlLIO* ipLIO, IPerlDir* ipD, IPerlSock* ipS, IPerlProc* ipP) +#ifdef PERL_IMPLICIT_SYS +PerlInterpreter * +perl_alloc_using(struct IPerlMem* ipM, struct IPerlMem* ipMS, + struct IPerlMem* ipMP, struct IPerlEnv* ipE, + struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO, + struct IPerlDir* ipD, struct IPerlSock* ipS, + struct IPerlProc* ipP) { - CPerlObj* pPerl = new(ipM) CPerlObj(ipM, ipE, ipStd, ipLIO, ipD, ipS, ipP); - if(pPerl != NULL) - pPerl->Init(); - - return pPerl; + PerlInterpreter *my_perl; +#ifdef PERL_OBJECT + my_perl = (PerlInterpreter*)new(ipM) CPerlObj(ipM, ipMS, ipMP, ipE, ipStd, + ipLIO, ipD, ipS, ipP); + INIT_TLS_AND_INTERP; +#else + /* New() needs interpreter, so call malloc() instead */ + my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter)); + INIT_TLS_AND_INTERP; + Zero(my_perl, 1, PerlInterpreter); + PL_Mem = ipM; + PL_MemShared = ipMS; + PL_MemParse = ipMP; + PL_Env = ipE; + PL_StdIO = ipStd; + PL_LIO = ipLIO; + PL_Dir = ipD; + PL_Sock = ipS; + PL_Proc = ipP; +#endif + + return my_perl; } #else + +/* +=for apidoc perl_alloc + +Allocates a new Perl interpreter. See L<perlembed>. + +=cut +*/ + PerlInterpreter * perl_alloc(void) { - PerlInterpreter *sv_interp; + PerlInterpreter *my_perl; + + /* New() needs interpreter, so call malloc() instead */ + my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter)); - PL_curinterp = 0; - New(53, sv_interp, 1, PerlInterpreter); - return sv_interp; + INIT_TLS_AND_INTERP; + Zero(my_perl, 1, PerlInterpreter); + return my_perl; } -#endif /* PERL_OBJECT */ +#endif /* PERL_IMPLICIT_SYS */ + +/* +=for apidoc perl_construct + +Initializes a new Perl interpreter. See L<perlembed>. + +=cut +*/ void -#ifdef PERL_OBJECT -CPerlObj::perl_construct(void) -#else -perl_construct(register PerlInterpreter *sv_interp) -#endif +perl_construct(pTHXx) { #ifdef USE_THREADS int i; #ifndef FAKE_THREADS - struct perl_thread *thr; + struct perl_thread *thr = NULL; #endif /* FAKE_THREADS */ #endif /* USE_THREADS */ - -#ifndef PERL_OBJECT - if (!(PL_curinterp = sv_interp)) - return; -#endif #ifdef MULTIPLICITY - ++PL_ninterps; - Zero(sv_interp, 1, PerlInterpreter); + init_interp(); + PL_perl_destruct_level = 1; +#else + if (PL_perl_destruct_level > 0) + init_interp(); #endif /* Init the real globals (and main thread)? */ if (!PL_linestr) { #ifdef USE_THREADS - - INIT_THREADS; -#ifdef ALLOC_THREAD_KEY - ALLOC_THREAD_KEY; -#else - if (pthread_key_create(&PL_thr_key, 0)) - croak("panic: pthread_key_create"); -#endif MUTEX_INIT(&PL_sv_mutex); - MUTEX_INIT(&PL_cred_mutex); /* * Safe to use basic SV functions from now on (though * not things like mortals or tainting yet). @@ -138,13 +176,21 @@ perl_construct(register PerlInterpreter *sv_interp) COND_INIT(&PL_eval_cond); MUTEX_INIT(&PL_threads_mutex); COND_INIT(&PL_nthreads_cond); -#ifdef EMULATE_ATOMIC_REFCOUNTS +# ifdef EMULATE_ATOMIC_REFCOUNTS MUTEX_INIT(&PL_svref_mutex); -#endif /* EMULATE_ATOMIC_REFCOUNTS */ +# endif /* EMULATE_ATOMIC_REFCOUNTS */ + MUTEX_INIT(&PL_cred_mutex); + thr = init_main_thread(); #endif /* USE_THREADS */ +#ifdef PERL_FLEXIBLE_EXCEPTIONS + PL_protect = MEMBER_TO_FPTR(Perl_default_protect); /* for exceptions */ +#endif + + PL_curcop = &PL_compiling; /* needed by ckWARN, right away */ + PL_linestr = NEWSV(65,79); sv_upgrade(PL_linestr,SVt_PVIV); @@ -170,7 +216,7 @@ perl_construct(register PerlInterpreter *sv_interp) /* TODO: */ /* PL_sighandlerp = sighandler; */ #else - PL_sighandlerp = sighandler; + PL_sighandlerp = Perl_sighandler; #endif PL_pidstatus = newHV(); @@ -185,36 +231,43 @@ perl_construct(register PerlInterpreter *sv_interp) #endif } - PL_nrs = newSVpv("\n", 1); + PL_nrs = newSVpvn("\n", 1); PL_rs = SvREFCNT_inc(PL_nrs); - init_stacks(ARGS); -#ifdef MULTIPLICITY - init_interp(); - PL_perl_destruct_level = 1; -#else - if (PL_perl_destruct_level > 0) - init_interp(); -#endif + init_stacks(); init_ids(); PL_lex_state = LEX_NOTPARSING; - PL_start_env.je_prev = NULL; - PL_start_env.je_ret = -1; - PL_start_env.je_mustcatch = TRUE; - PL_top_env = &PL_start_env; + JMPENV_BOOTSTRAP; STATUS_ALL_SUCCESS; + init_i18nl10n(1); SET_NUMERIC_STANDARD(); -#if defined(SUBVERSION) && SUBVERSION > 0 - sprintf(PL_patchlevel, "%7.5f", (double) 5 - + ((double) PATCHLEVEL / (double) 1000) - + ((double) SUBVERSION / (double) 100000)); -#else - sprintf(PL_patchlevel, "%5.3f", (double) 5 + - ((double) PATCHLEVEL / (double) 1000)); -#endif + + { + U8 *s; + PL_patchlevel = NEWSV(0,4); + (void)SvUPGRADE(PL_patchlevel, SVt_PVNV); + if (PERL_REVISION > 127 || PERL_VERSION > 127 || PERL_SUBVERSION > 127) + SvGROW(PL_patchlevel, UTF8_MAXLEN*3+1); + s = (U8*)SvPVX(PL_patchlevel); + s = uv_to_utf8(s, (UV)PERL_REVISION); + s = uv_to_utf8(s, (UV)PERL_VERSION); + s = uv_to_utf8(s, (UV)PERL_SUBVERSION); + *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 + ; + SvNOK_on(PL_patchlevel); /* dual valued */ + SvUTF8_on(PL_patchlevel); + SvREADONLY_on(PL_patchlevel); + } #if defined(LOCAL_PATCH_COUNT) PL_localpatches = local_patches; /* For possible -v */ @@ -225,20 +278,19 @@ perl_construct(register PerlInterpreter *sv_interp) PL_fdpid = newAV(); /* for remembering popen pids by fd */ PL_modglobal = newHV(); /* pointers to per-interpreter module globals */ - DEBUG( { - New(51,PL_debname,128,char); - New(52,PL_debdelim,128,char); - } ) - ENTER; } +/* +=for apidoc perl_destruct + +Shuts down a Perl interpreter. See L<perlembed>. + +=cut +*/ + void -#ifdef PERL_OBJECT -CPerlObj::perl_destruct(void) -#else -perl_destruct(register PerlInterpreter *sv_interp) -#endif +perl_destruct(pTHXx) { dTHR; int destruct_level; /* 0=none, 1=full, 2=full with checks */ @@ -246,19 +298,18 @@ perl_destruct(register PerlInterpreter *sv_interp) HV *hv; #ifdef USE_THREADS Thread t; + dTHX; #endif /* USE_THREADS */ -#ifndef PERL_OBJECT - if (!(PL_curinterp = sv_interp)) - return; -#endif + /* wait for all pseudo-forked children to finish */ + PERL_WAIT_FOR_CHILDREN; #ifdef USE_THREADS #ifndef FAKE_THREADS /* Pass 1 on any remaining threads: detach joinables, join zombies */ retry_cleanup: MUTEX_LOCK(&PL_threads_mutex); - DEBUG_S(PerlIO_printf(PerlIO_stderr(), + 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) { @@ -266,7 +317,7 @@ perl_destruct(register PerlInterpreter *sv_interp) switch (ThrSTATE(t)) { AV *av; case THRf_ZOMBIE: - DEBUG_S(PerlIO_printf(PerlIO_stderr(), + DEBUG_S(PerlIO_printf(Perl_debug_log, "perl_destruct: joining zombie %p\n", t)); ThrSETSTATE(t, THRf_DEAD); MUTEX_UNLOCK(&t->mutex); @@ -280,11 +331,11 @@ perl_destruct(register PerlInterpreter *sv_interp) MUTEX_UNLOCK(&PL_threads_mutex); JOIN(t, &av); SvREFCNT_dec((SV*)av); - DEBUG_S(PerlIO_printf(PerlIO_stderr(), + 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(PerlIO_stderr(), + DEBUG_S(PerlIO_printf(Perl_debug_log, "perl_destruct: detaching thread %p\n", t)); ThrSETSTATE(t, THRf_R_DETACHED); /* @@ -298,7 +349,7 @@ perl_destruct(register PerlInterpreter *sv_interp) MUTEX_UNLOCK(&t->mutex); goto retry_cleanup; default: - DEBUG_S(PerlIO_printf(PerlIO_stderr(), + DEBUG_S(PerlIO_printf(Perl_debug_log, "perl_destruct: ignoring %p (state %u)\n", t, ThrSTATE(t))); MUTEX_UNLOCK(&t->mutex); @@ -310,14 +361,14 @@ perl_destruct(register PerlInterpreter *sv_interp) /* Pass 2 on remaining threads: wait for the thread count to drop to one */ while (PL_nthreads > 1) { - DEBUG_S(PerlIO_printf(PerlIO_stderr(), + 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(PerlIO_stderr(), "perl_destruct: armageddon has arrived\n")); + DEBUG_S(PerlIO_printf(Perl_debug_log, "perl_destruct: armageddon has arrived\n")); MUTEX_DESTROY(&PL_threads_mutex); COND_DESTROY(&PL_nthreads_cond); #endif /* !defined(FAKE_THREADS) */ @@ -327,7 +378,7 @@ perl_destruct(register PerlInterpreter *sv_interp) #ifdef DEBUGGING { char *s; - if (s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL")) { + if ((s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL"))) { int i = atoi(s); if (destruct_level < i) destruct_level = i; @@ -338,10 +389,6 @@ perl_destruct(register PerlInterpreter *sv_interp) LEAVE; FREETMPS; -#ifdef MULTIPLICITY - --PL_ninterps; -#endif - /* We must account for everything. */ /* Destroy the main CV and syntax tree */ @@ -354,6 +401,7 @@ perl_destruct(register PerlInterpreter *sv_interp) PL_main_start = Nullop; SvREFCNT_dec(PL_main_cv); PL_main_cv = Nullcv; + PL_dirty = TRUE; if (PL_sv_objcount) { /* @@ -361,8 +409,6 @@ perl_destruct(register PerlInterpreter *sv_interp) * destructors and destructees still exist. Some sv's might remain. * Non-referenced objects are on their own. */ - - PL_dirty = TRUE; sv_clean_objs(); } @@ -371,12 +417,10 @@ perl_destruct(register PerlInterpreter *sv_interp) PL_warnhook = Nullsv; SvREFCNT_dec(PL_diehook); PL_diehook = Nullsv; - SvREFCNT_dec(PL_parsehook); - PL_parsehook = Nullsv; /* call exit list functions */ while (PL_exitlistlen-- > 0) - PL_exitlist[PL_exitlistlen].fn(PERL_OBJECT_THIS_ PL_exitlist[PL_exitlistlen].ptr); + PL_exitlist[PL_exitlistlen].fn(aTHXo_ PL_exitlist[PL_exitlistlen].ptr); Safefree(PL_exitlist); @@ -407,15 +451,14 @@ perl_destruct(register PerlInterpreter *sv_interp) PL_minus_a = FALSE; PL_minus_F = FALSE; PL_doswitches = FALSE; - PL_dowarn = FALSE; + PL_dowarn = G_WARN_OFF; PL_doextract = FALSE; PL_sawampersand = FALSE; /* must save all match strings */ - PL_sawstudy = FALSE; /* do fbm_instr on all strings */ - PL_sawvec = FALSE; PL_unsafe = FALSE; Safefree(PL_inplace); PL_inplace = Nullch; + SvREFCNT_dec(PL_patchlevel); if (PL_e_script) { SvREFCNT_dec(PL_e_script); @@ -424,10 +467,10 @@ perl_destruct(register PerlInterpreter *sv_interp) /* magical thingies */ - Safefree(PL_ofs); /* $, */ + Safefree(PL_ofs); /* $, */ PL_ofs = Nullch; - Safefree(PL_ors); /* $\ */ + Safefree(PL_ors); /* $\ */ PL_ors = Nullch; SvREFCNT_dec(PL_rs); /* $/ */ @@ -436,7 +479,9 @@ perl_destruct(register PerlInterpreter *sv_interp) SvREFCNT_dec(PL_nrs); /* $/ helper */ PL_nrs = Nullsv; - PL_multiline = 0; /* $* */ + PL_multiline = 0; /* $* */ + Safefree(PL_osname); /* $^O */ + PL_osname = Nullch; SvREFCNT_dec(PL_statname); PL_statname = Nullsv; @@ -452,61 +497,157 @@ perl_destruct(register PerlInterpreter *sv_interp) Safefree(PL_screamnext); PL_screamnext = 0; + /* float buffer */ + Safefree(PL_efloatbuf); + PL_efloatbuf = Nullch; + PL_efloatsize = 0; + /* startup and shutdown function lists */ SvREFCNT_dec(PL_beginav); SvREFCNT_dec(PL_endav); + SvREFCNT_dec(PL_checkav); SvREFCNT_dec(PL_initav); PL_beginav = Nullav; PL_endav = Nullav; + PL_checkav = Nullav; PL_initav = Nullav; /* shortcuts just get cleared */ PL_envgv = Nullgv; - PL_siggv = Nullgv; PL_incgv = Nullgv; PL_hintgv = Nullgv; PL_errgv = Nullgv; PL_argvgv = Nullgv; PL_argvoutgv = Nullgv; PL_stdingv = Nullgv; + PL_stderrgv = Nullgv; PL_last_in_gv = Nullgv; PL_replgv = Nullgv; + PL_debstash = Nullhv; /* reset so print() ends up where we expect */ setdefout(Nullgv); + SvREFCNT_dec(PL_argvout_stack); + PL_argvout_stack = Nullav; + + SvREFCNT_dec(PL_modglobal); + PL_modglobal = Nullhv; + SvREFCNT_dec(PL_preambleav); + PL_preambleav = Nullav; + SvREFCNT_dec(PL_subname); + PL_subname = Nullsv; + SvREFCNT_dec(PL_linestr); + PL_linestr = Nullsv; + SvREFCNT_dec(PL_pidstatus); + PL_pidstatus = Nullhv; + SvREFCNT_dec(PL_toptarget); + PL_toptarget = Nullsv; + SvREFCNT_dec(PL_bodytarget); + PL_bodytarget = Nullsv; + PL_formtarget = Nullsv; + + /* free locale stuff */ +#ifdef USE_LOCALE_COLLATE + Safefree(PL_collation_name); + PL_collation_name = Nullch; +#endif + +#ifdef USE_LOCALE_NUMERIC + Safefree(PL_numeric_name); + PL_numeric_name = Nullch; +#endif + + /* clear utf8 character classes */ + SvREFCNT_dec(PL_utf8_alnum); + SvREFCNT_dec(PL_utf8_alnumc); + SvREFCNT_dec(PL_utf8_ascii); + SvREFCNT_dec(PL_utf8_alpha); + SvREFCNT_dec(PL_utf8_space); + SvREFCNT_dec(PL_utf8_cntrl); + SvREFCNT_dec(PL_utf8_graph); + SvREFCNT_dec(PL_utf8_digit); + SvREFCNT_dec(PL_utf8_upper); + SvREFCNT_dec(PL_utf8_lower); + SvREFCNT_dec(PL_utf8_print); + SvREFCNT_dec(PL_utf8_punct); + SvREFCNT_dec(PL_utf8_xdigit); + SvREFCNT_dec(PL_utf8_mark); + SvREFCNT_dec(PL_utf8_toupper); + SvREFCNT_dec(PL_utf8_tolower); + PL_utf8_alnum = Nullsv; + PL_utf8_alnumc = Nullsv; + PL_utf8_ascii = Nullsv; + PL_utf8_alpha = Nullsv; + PL_utf8_space = Nullsv; + PL_utf8_cntrl = Nullsv; + PL_utf8_graph = Nullsv; + PL_utf8_digit = Nullsv; + PL_utf8_upper = Nullsv; + PL_utf8_lower = Nullsv; + PL_utf8_print = Nullsv; + PL_utf8_punct = Nullsv; + PL_utf8_xdigit = Nullsv; + PL_utf8_mark = Nullsv; + PL_utf8_toupper = Nullsv; + PL_utf8_totitle = Nullsv; + PL_utf8_tolower = Nullsv; + + if (!specialWARN(PL_compiling.cop_warnings)) + SvREFCNT_dec(PL_compiling.cop_warnings); + PL_compiling.cop_warnings = Nullsv; +#ifndef USE_ITHREADS + SvREFCNT_dec(CopFILEGV(&PL_compiling)); + CopFILEGV_set(&PL_compiling, Nullgv); +#endif + /* Prepare to destruct main symbol table. */ hv = PL_defstash; PL_defstash = 0; SvREFCNT_dec(hv); + SvREFCNT_dec(PL_curstname); + PL_curstname = Nullsv; + + /* clear queued errors */ + SvREFCNT_dec(PL_errors); + PL_errors = Nullsv; FREETMPS; - if (destruct_level >= 2) { + if (destruct_level >= 2 && ckWARN_d(WARN_INTERNAL)) { if (PL_scopestack_ix != 0) - warn("Unbalanced scopes: %ld more ENTERs than LEAVEs\n", + Perl_warner(aTHX_ WARN_INTERNAL, + "Unbalanced scopes: %ld more ENTERs than LEAVEs\n", (long)PL_scopestack_ix); if (PL_savestack_ix != 0) - warn("Unbalanced saves: %ld more saves than restores\n", + Perl_warner(aTHX_ WARN_INTERNAL, + "Unbalanced saves: %ld more saves than restores\n", (long)PL_savestack_ix); if (PL_tmps_floor != -1) - warn("Unbalanced tmps: %ld more allocs than frees\n", + Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced tmps: %ld more allocs than frees\n", (long)PL_tmps_floor + 1); if (cxstack_ix != -1) - warn("Unbalanced context: %ld more PUSHes than POPs\n", + Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced context: %ld more PUSHes than POPs\n", (long)cxstack_ix + 1); } /* Now absolutely destruct everything, somehow or other, loops or no. */ last_sv_count = 0; + SvFLAGS(PL_fdpid) |= SVTYPEMASK; /* don't clean out pid table now */ SvFLAGS(PL_strtab) |= SVTYPEMASK; /* don't clean out strtab now */ while (PL_sv_count != 0 && PL_sv_count != last_sv_count) { last_sv_count = PL_sv_count; sv_clean_all(); } + SvFLAGS(PL_fdpid) &= ~SVTYPEMASK; + SvFLAGS(PL_fdpid) |= SVt_PVAV; SvFLAGS(PL_strtab) &= ~SVTYPEMASK; SvFLAGS(PL_strtab) |= SVt_PVHV; - + + AvREAL_off(PL_fdpid); /* no surviving entries */ + SvREFCNT_dec(PL_fdpid); /* needed in io_close() */ + PL_fdpid = Nullav; + /* Destruct the global string table. */ { /* Yell and reset the HeVAL() slots that are still holding refcounts, @@ -522,8 +663,9 @@ perl_destruct(register PerlInterpreter *sv_interp) array = HvARRAY(PL_strtab); hent = array[0]; for (;;) { - if (hent) { - warn("Unbalanced string table refcount: (%d) for \"%s\"", + if (hent && ckWARN_d(WARN_INTERNAL)) { + Perl_warner(aTHX_ WARN_INTERNAL, + "Unbalanced string table refcount: (%d) for \"%s\"", HeVAL(hent) - Nullsv, HeKEY(hent)); HeVAL(hent) = Nullsv; hent = HeNEXT(hent); @@ -537,17 +679,32 @@ perl_destruct(register PerlInterpreter *sv_interp) } SvREFCNT_dec(PL_strtab); - if (PL_sv_count != 0) - warn("Scalars leaked: %ld\n", (long)PL_sv_count); + /* free special SVs */ + + SvREFCNT(&PL_sv_yes) = 0; + sv_clear(&PL_sv_yes); + SvANY(&PL_sv_yes) = NULL; + SvFLAGS(&PL_sv_yes) = 0; + + SvREFCNT(&PL_sv_no) = 0; + sv_clear(&PL_sv_no); + SvANY(&PL_sv_no) = NULL; + SvFLAGS(&PL_sv_no) = 0; + + SvREFCNT(&PL_sv_undef) = 0; + SvREADONLY_off(&PL_sv_undef); + + if (PL_sv_count != 0 && ckWARN_d(WARN_INTERNAL)) + Perl_warner(aTHX_ WARN_INTERNAL,"Scalars leaked: %ld\n", (long)PL_sv_count); sv_free_arenas(); /* No SVs have survived, need to clean out */ - PL_linestr = NULL; - PL_pidstatus = Nullhv; Safefree(PL_origfilename); - Safefree(PL_archpat_auto); Safefree(PL_reg_start_tmp); + if (PL_reg_curpm) + Safefree(PL_reg_curpm); + Safefree(PL_reg_poscache); Safefree(HeKEY_hek(&PL_hv_fetch_ent_mh)); Safefree(PL_op_mask); nuke_stacks(); @@ -557,8 +714,8 @@ perl_destruct(register PerlInterpreter *sv_interp) #ifdef USE_THREADS MUTEX_DESTROY(&PL_strtab_mutex); MUTEX_DESTROY(&PL_sv_mutex); - MUTEX_DESTROY(&PL_cred_mutex); MUTEX_DESTROY(&PL_eval_mutex); + MUTEX_DESTROY(&PL_cred_mutex); COND_DESTROY(&PL_eval_cond); #ifdef EMULATE_ATOMIC_REFCOUNTS MUTEX_DESTROY(&PL_svref_mutex); @@ -570,7 +727,7 @@ perl_destruct(register PerlInterpreter *sv_interp) Safefree(PL_thrsv); PL_thrsv = Nullsv; #endif /* USE_THREADS */ - + /* As the absolutely last thing, free the non-arena SV for mess() */ if (PL_mess_sv) { @@ -586,7 +743,7 @@ perl_destruct(register PerlInterpreter *sv_interp) } } /* we know that type >= SVt_PV */ - SvOOK_off(PL_mess_sv); + (void)SvOOK_off(PL_mess_sv); Safefree(SvPVX(PL_mess_sv)); Safefree(SvANY(PL_mess_sv)); Safefree(PL_mess_sv); @@ -594,28 +751,32 @@ perl_destruct(register PerlInterpreter *sv_interp) } } +/* +=for apidoc perl_free + +Releases a Perl interpreter. See L<perlembed>. + +=cut +*/ + void -#ifdef PERL_OBJECT -CPerlObj::perl_free(void) -#else -perl_free(PerlInterpreter *sv_interp) -#endif +perl_free(pTHXx) { -#ifdef PERL_OBJECT - Safefree(this); +#if defined(PERL_OBJECT) + PerlMem_free(this); #else - if (!(PL_curinterp = sv_interp)) - return; - Safefree(sv_interp); +# if defined(PERL_IMPLICIT_SYS) && defined(WIN32) + void *host = w32_internal_host; + PerlMem_free(aTHXx); + win32_delete_internal_host(host); +# else + PerlMem_free(aTHXx); +# endif #endif } void -#ifdef PERL_OBJECT -CPerlObj::perl_atexit(void (*fn) (CPerlObj*,void *), void *ptr) -#else -perl_atexit(void (*fn) (void *), void *ptr) -#endif +Perl_call_atexit(pTHX_ ATEXIT_t fn, void *ptr) { Renew(PL_exitlist, PL_exitlistlen+1, PerlExitListEntry); PL_exitlist[PL_exitlistlen].fn = fn; @@ -623,39 +784,34 @@ perl_atexit(void (*fn) (void *), void *ptr) ++PL_exitlistlen; } +/* +=for apidoc perl_parse + +Tells a Perl interpreter to parse a Perl script. See L<perlembed>. + +=cut +*/ + int -#ifdef PERL_OBJECT -CPerlObj::perl_parse(void (*xsinit) (CPerlObj*), int argc, char **argv, char **env) -#else -perl_parse(PerlInterpreter *sv_interp, void (*xsinit) (void), int argc, char **argv, char **env) -#endif +perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env) { dTHR; - register SV *sv; - register char *s; - char *scriptname = NULL; - VOL bool dosearch = FALSE; - char *validarg = ""; I32 oldscope; - AV* comppadlist; - dJMPENV; int ret; - int fdscript = -1; + dJMPENV; +#ifdef USE_THREADS + dTHX; +#endif #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW #ifdef IAMSUID #undef IAMSUID - croak("suidperl is no longer needed since the kernel can now execute\n\ + Perl_croak(aTHX_ "suidperl is no longer needed since the kernel can now execute\n\ setuid perl scripts securely.\n"); #endif #endif -#ifndef PERL_OBJECT - if (!(PL_curinterp = sv_interp)) - return 255; -#endif - -#if defined(NeXT) && defined(__DYNAMIC__) +#if defined(__DYNAMIC__) && (defined(NeXT) || defined(__NeXT__)) _dyld_lookup_and_bind ("__environ", (unsigned long *) &environ_pointer, NULL); #endif /* environ */ @@ -689,9 +845,22 @@ setuid perl scripts securely.\n"); time(&PL_basetime); oldscope = PL_scopestack_ix; + PL_dowarn = G_WARN_OFF; +#ifdef PERL_FLEXIBLE_EXCEPTIONS + CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vparse_body), env, xsinit); +#else JMPENV_PUSH(ret); +#endif switch (ret) { + case 0: +#ifndef PERL_FLEXIBLE_EXCEPTIONS + parse_body(env,xsinit); +#endif + if (PL_checkav) + call_list(oldscope, PL_checkav); + ret = 0; + break; case 1: STATUS_ALL_FAILURE; /* FALL THROUGH */ @@ -701,18 +870,47 @@ setuid perl scripts securely.\n"); LEAVE; FREETMPS; PL_curstash = PL_defstash; - if (PL_endav) - call_list(oldscope, PL_endav); - JMPENV_POP; - return STATUS_NATIVE_EXPORT; + if (PL_checkav) + call_list(oldscope, PL_checkav); + ret = STATUS_NATIVE_EXPORT; + break; case 3: - JMPENV_POP; - PerlIO_printf(PerlIO_stderr(), "panic: top_env\n"); - return 1; + PerlIO_printf(Perl_error_log, "panic: top_env\n"); + ret = 1; + break; } + JMPENV_POP; + return ret; +} + +#ifdef PERL_FLEXIBLE_EXCEPTIONS +STATIC void * +S_vparse_body(pTHX_ va_list args) +{ + char **env = va_arg(args, char**); + XSINIT_t xsinit = va_arg(args, XSINIT_t); + + return parse_body(env, xsinit); +} +#endif + +STATIC void * +S_parse_body(pTHX_ char **env, XSINIT_t xsinit) +{ + dTHR; + int argc = PL_origargc; + char **argv = PL_origargv; + char *scriptname = NULL; + int fdscript = -1; + VOL bool dosearch = FALSE; + char *validarg = ""; + AV* comppadlist; + register SV *sv; + register char *s; + char *cddir = Nullch; sv_setpvn(PL_linestr,"",0); - sv = newSVpv("",0); /* first used for -I flags */ + sv = newSVpvn("",0); /* first used for -I flags */ SAVEFREESV(sv); init_main_stash(); @@ -728,6 +926,11 @@ setuid perl scripts securely.\n"); s = argv[0]+1; reswitch: switch (*s) { + case 'C': +#ifdef WIN32 + win32_argv2utf8(argc-1, argv+1); + /* FALL THROUGH */ +#endif #ifndef PERL_STRICT_CR case '\r': #endif @@ -749,8 +952,10 @@ setuid perl scripts securely.\n"); case 'u': case 'U': case 'v': + case 'W': + case 'X': case 'w': - if (s = moreswitches(s)) + if ((s = moreswitches(s))) goto reswitch; break; @@ -761,9 +966,9 @@ setuid perl scripts securely.\n"); case 'e': if (PL_euid != PL_uid || PL_egid != PL_gid) - croak("No -e allowed in setuid scripts"); + Perl_croak(aTHX_ "No -e allowed in setuid scripts"); if (!PL_e_script) { - PL_e_script = newSVpv("",0); + PL_e_script = newSVpvn("",0); filter_add(read_e_script, NULL); } if (*++s) @@ -773,7 +978,7 @@ setuid perl scripts securely.\n"); argc--,argv++; } else - croak("No code specified for -e"); + Perl_croak(aTHX_ "No code specified for -e"); sv_catpv(PL_e_script, "\n"); break; @@ -782,18 +987,18 @@ setuid perl scripts securely.\n"); if (!*++s && (s=argv[1]) != Nullch) { argc--,argv++; } - while (s && isSPACE(*s)) - ++s; if (s && *s) { - char *e, *p; - for (e = s; *e && !isSPACE(*e); e++) ; - p = savepvn(s, e-s); - incpush(p, TRUE); - sv_catpv(sv,"-I"); - sv_catpv(sv,p); - sv_catpv(sv," "); + char *p; + STRLEN len = strlen(s); + p = savepvn(s, len); + incpush(p, TRUE, TRUE); + sv_catpvn(sv, "-I", 2); + sv_catpvn(sv, p, len); + sv_catpvn(sv, " ", 1); Safefree(p); - } /* XXX else croak? */ + } + else + Perl_croak(aTHX_ "No directory specified for -I"); break; case 'P': forbid_setid("-P"); @@ -816,35 +1021,61 @@ setuid perl scripts securely.\n"); #else sv_catpv(PL_Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\","); #endif -#if defined(DEBUGGING) || defined(NO_EMBED) || defined(MULTIPLICITY) sv_catpv(PL_Sv,"\" Compile-time options:"); # ifdef DEBUGGING sv_catpv(PL_Sv," DEBUGGING"); # endif -# ifdef NO_EMBED - sv_catpv(PL_Sv," NO_EMBED"); -# endif # ifdef MULTIPLICITY sv_catpv(PL_Sv," MULTIPLICITY"); # endif +# ifdef USE_THREADS + sv_catpv(PL_Sv," USE_THREADS"); +# endif +# ifdef USE_ITHREADS + sv_catpv(PL_Sv," USE_ITHREADS"); +# endif +# ifdef USE_64_BIT_INT + sv_catpv(PL_Sv," USE_64_BIT_INT"); +# endif +# ifdef USE_64_BIT_ALL + sv_catpv(PL_Sv," USE_64_BIT_ALL"); +# endif +# ifdef USE_LONG_DOUBLE + sv_catpv(PL_Sv," USE_LONG_DOUBLE"); +# endif +# ifdef USE_LARGE_FILES + sv_catpv(PL_Sv," USE_LARGE_FILES"); +# endif +# ifdef USE_SOCKS + sv_catpv(PL_Sv," USE_SOCKS"); +# endif +# ifdef PERL_OBJECT + sv_catpv(PL_Sv," PERL_OBJECT"); +# 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 sv_catpv(PL_Sv,"\\n\","); -#endif + #if defined(LOCAL_PATCH_COUNT) if (LOCAL_PATCH_COUNT > 0) { int i; sv_catpv(PL_Sv,"\" Locally applied patches:\\n\","); for (i = 1; i <= LOCAL_PATCH_COUNT; i++) { if (PL_localpatches[i]) - sv_catpvf(PL_Sv,"\" \\t%s\\n\",",PL_localpatches[i]); + Perl_sv_catpvf(aTHX_ PL_Sv,"q\" \t%s\n\",",PL_localpatches[i]); } } #endif - sv_catpvf(PL_Sv,"\" Built under %s\\n\"",OSNAME); + Perl_sv_catpvf(aTHX_ PL_Sv,"\" Built under %s\\n\"",OSNAME); #ifdef __DATE__ # ifdef __TIME__ - sv_catpvf(PL_Sv,",\" Compiled at %s %s\\n\"",__DATE__,__TIME__); + Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled at %s %s\\n\"",__DATE__,__TIME__); # else - sv_catpvf(PL_Sv,",\" Compiled on %s\\n\"",__DATE__); + Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled on %s\\n\"",__DATE__); # endif #endif sv_catpv(PL_Sv, "; \ @@ -866,7 +1097,7 @@ print \" \\@INC:\\n @INC\\n\";"); PL_doextract = TRUE; s++; if (*s) - PL_cddir = savepv(s); + cddir = s; break; case 0: break; @@ -887,25 +1118,36 @@ print \" \\@INC:\\n @INC\\n\";"); s--; /* FALL THROUGH */ default: - croak("Unrecognized switch: -%s (-h will show valid options)",s); + Perl_croak(aTHX_ "Unrecognized switch: -%s (-h will show valid options)",s); } } switch_end: - if (!PL_tainting && (s = PerlEnv_getenv("PERL5OPT"))) { - while (s && *s) { - while (isSPACE(*s)) - s++; - if (*s == '-') { - s++; - if (isSPACE(*s)) - continue; + if ( +#ifndef SECURE_INTERNAL_GETENV + !PL_tainting && +#endif + (s = PerlEnv_getenv("PERL5OPT"))) + { + while (isSPACE(*s)) + s++; + if (*s == '-' && *(s+1) == 'T') + PL_tainting = TRUE; + else { + while (s && *s) { + while (isSPACE(*s)) + s++; + if (*s == '-') { + s++; + if (isSPACE(*s)) + continue; + } + if (!*s) + break; + if (!strchr("DIMUdmw", *s)) + Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s); + s = moreswitches(s); } - if (!*s) - break; - if (!strchr("DIMUdmw", *s)) - croak("Illegal switch in PERL5OPT: -%c", *s); - s = moreswitches(s); } } @@ -929,8 +1171,27 @@ print \" \\@INC:\\n @INC\\n\";"); validate_suid(validarg, scriptname,fdscript); - if (PL_doextract) +#if defined(SIGCHLD) || defined(SIGCLD) + { +#ifndef SIGCHLD +# define SIGCHLD SIGCLD +#endif + Sighandler_t sigstate = rsignal_state(SIGCHLD); + if (sigstate == SIG_IGN) { + if (ckWARN(WARN_SIGNAL)) + Perl_warner(aTHX_ WARN_SIGNAL, + "Can't ignore signal CHLD, forcing to default"); + (void)rsignal(SIGCHLD, (Sighandler_t)SIG_DFL); + } + } +#endif + + if (PL_doextract) { find_beginning(); + if (cddir && PerlDir_chdir(cddir) < 0) + Perl_croak(aTHX_ "Can't chdir to %s",cddir); + + } PL_main_cv = PL_compcv = (CV*)NEWSV(1104,0); sv_upgrade((SV *)PL_compcv, SVt_PVCV); @@ -944,7 +1205,7 @@ print \" \\@INC:\\n @INC\\n\";"); PL_min_intro_pending = 0; PL_padix = 0; #ifdef USE_THREADS - av_store(PL_comppad_name, 0, newSVpv("@_", 2)); + av_store(PL_comppad_name, 0, newSVpvn("@_", 2)); PL_curpad[0] = (SV*)newAV(); SvPADMY_on(PL_curpad[0]); /* XXX Needed? */ CvOWNER(PL_compcv) = 0; @@ -959,13 +1220,20 @@ print \" \\@INC:\\n @INC\\n\";"); CvPADLIST(PL_compcv) = comppadlist; boot_core_UNIVERSAL(); +#ifndef PERL_MICRO + boot_core_xsutils(); +#endif if (xsinit) - (*xsinit)(PERL_OBJECT_THIS); /* in case linked C routines want magical variables */ -#if defined(VMS) || defined(WIN32) || defined(DJGPP) + (*xsinit)(aTHXo); /* in case linked C routines want magical variables */ +#if defined(VMS) || defined(WIN32) || defined(DJGPP) || defined(__CYGWIN__) init_os_extras(); #endif +#ifdef USE_SOCKS + SOCKSinit(argv[0]); +#endif + init_predump_symbols(); /* init_postdump_symbols not currently designed to be called */ /* more than once (ENV isn't cleared first, for example) */ @@ -981,13 +1249,13 @@ print \" \\@INC:\\n @INC\\n\";"); PL_error_count = 0; if (yyparse() || PL_error_count) { if (PL_minus_c) - croak("%s had compilation errors.\n", PL_origfilename); + Perl_croak(aTHX_ "%s had compilation errors.\n", PL_origfilename); else { - croak("Execution of %s aborted due to compilation errors.\n", - PL_origfilename); + Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n", + PL_origfilename); } } - PL_curcop->cop_line = 0; + CopLINE_set(PL_curcop, 0); PL_curstash = PL_defstash; PL_preprocess = FALSE; if (PL_e_script) { @@ -998,12 +1266,15 @@ print \" \\@INC:\\n @INC\\n\";"); /* now that script is parsed, we can modify record separator */ SvREFCNT_dec(PL_rs); PL_rs = SvREFCNT_inc(PL_nrs); - sv_setsv(perl_get_sv("/", TRUE), PL_rs); + sv_setsv(get_sv("/", TRUE), PL_rs); if (PL_do_undump) my_unexec(); - if (PL_dowarn) + if (isWARN_ONCE) { + SAVECOPFILE(PL_curcop); + SAVECOPLINE(PL_curcop); gv_check(PL_defstash); + } LEAVE; FREETMPS; @@ -1015,74 +1286,105 @@ print \" \\@INC:\\n @INC\\n\";"); ENTER; PL_restartop = 0; - JMPENV_POP; - return 0; + return NULL; } +/* +=for apidoc perl_run + +Tells a Perl interpreter to run. See L<perlembed>. + +=cut +*/ + int -#ifdef PERL_OBJECT -CPerlObj::perl_run(void) -#else -perl_run(PerlInterpreter *sv_interp) -#endif +perl_run(pTHXx) { - dSP; + dTHR; I32 oldscope; + int ret = 0; dJMPENV; - int ret; - -#ifndef PERL_OBJECT - if (!(PL_curinterp = sv_interp)) - return 255; +#ifdef USE_THREADS + dTHX; #endif oldscope = PL_scopestack_ix; +#ifdef PERL_FLEXIBLE_EXCEPTIONS + redo_body: + CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vrun_body), oldscope); +#else JMPENV_PUSH(ret); +#endif switch (ret) { case 1: cxstack_ix = -1; /* start context stack again */ - break; - case 2: - /* my_exit() was called */ + goto redo_body; + case 0: /* normal completion */ +#ifndef PERL_FLEXIBLE_EXCEPTIONS + redo_body: + run_body(oldscope); +#endif + /* FALL THROUGH */ + case 2: /* my_exit() */ while (PL_scopestack_ix > oldscope) LEAVE; FREETMPS; PL_curstash = PL_defstash; - if (PL_endav) + if (PL_endav && !PL_minus_c) call_list(oldscope, PL_endav); #ifdef MYMALLOC if (PerlEnv_getenv("PERL_DEBUG_MSTATS")) dump_mstats("after execution: "); #endif - JMPENV_POP; - return STATUS_NATIVE_EXPORT; + ret = STATUS_NATIVE_EXPORT; + break; case 3: - if (!PL_restartop) { - PerlIO_printf(PerlIO_stderr(), "panic: restartop\n"); - FREETMPS; - JMPENV_POP; - return 1; + if (PL_restartop) { + POPSTACK_TO(PL_mainstack); + goto redo_body; } - POPSTACK_TO(PL_mainstack); + PerlIO_printf(Perl_error_log, "panic: restartop\n"); + FREETMPS; + ret = 1; break; } + JMPENV_POP; + return ret; +} + +#ifdef PERL_FLEXIBLE_EXCEPTIONS +STATIC void * +S_vrun_body(pTHX_ va_list args) +{ + I32 oldscope = va_arg(args, I32); + + return run_body(oldscope); +} +#endif + + +STATIC void * +S_run_body(pTHX_ I32 oldscope) +{ + dTHR; + DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n", PL_sawampersand ? "Enabling" : "Omitting")); if (!PL_restartop) { DEBUG_x(dump_all()); DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n")); - DEBUG_S(PerlIO_printf(Perl_debug_log, "main thread is 0x%lx\n", - (unsigned long) thr)); + DEBUG_S(PerlIO_printf(Perl_debug_log, "main thread is 0x%"UVxf"\n", + PTR2UV(thr))); if (PL_minus_c) { - PerlIO_printf(PerlIO_stderr(), "%s syntax OK\n", PL_origfilename); + PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename); my_exit(0); } if (PERLDB_SINGLE && PL_DBsingle) - sv_setiv(PL_DBsingle, 1); + sv_setiv(PL_DBsingle, 1); if (PL_initav) call_list(oldscope, PL_initav); } @@ -1092,21 +1394,31 @@ perl_run(PerlInterpreter *sv_interp) if (PL_restartop) { PL_op = PL_restartop; PL_restartop = 0; - CALLRUNOPS(); + CALLRUNOPS(aTHX); } else if (PL_main_start) { CvDEPTH(PL_main_cv) = 1; PL_op = PL_main_start; - CALLRUNOPS(); + CALLRUNOPS(aTHX); } my_exit(0); /* NOTREACHED */ - return 0; + return NULL; } +/* +=for apidoc p||get_sv + +Returns the SV of the specified Perl scalar. If C<create> is set and the +Perl variable does not exist then it will be created. If C<create> is not +set and the variable does not exist then NULL is returned. + +=cut +*/ + SV* -perl_get_sv(char *name, I32 create) +Perl_get_sv(pTHX_ const char *name, I32 create) { GV *gv; #ifdef USE_THREADS @@ -1124,8 +1436,18 @@ perl_get_sv(char *name, I32 create) return Nullsv; } +/* +=for apidoc p||get_av + +Returns the AV of the specified Perl array. If C<create> is set and the +Perl variable does not exist then it will be created. If C<create> is not +set and the variable does not exist then NULL is returned. + +=cut +*/ + AV* -perl_get_av(char *name, I32 create) +Perl_get_av(pTHX_ const char *name, I32 create) { GV* gv = gv_fetchpv(name, create, SVt_PVAV); if (create) @@ -1135,8 +1457,18 @@ perl_get_av(char *name, I32 create) return Nullav; } +/* +=for apidoc p||get_hv + +Returns the HV of the specified Perl hash. If C<create> is set and the +Perl variable does not exist then it will be created. If C<create> is not +set and the variable does not exist then NULL is returned. + +=cut +*/ + HV* -perl_get_hv(char *name, I32 create) +Perl_get_hv(pTHX_ const char *name, I32 create) { GV* gv = gv_fetchpv(name, create, SVt_PVHV); if (create) @@ -1146,11 +1478,25 @@ perl_get_hv(char *name, I32 create) return Nullhv; } +/* +=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. + +=cut +*/ + CV* -perl_get_cv(char *name, I32 create) +Perl_get_cv(pTHX_ const char *name, I32 create) { GV* gv = gv_fetchpv(name, create, SVt_PVCV); /* XXX unsafe for threads if eval_owner isn't held */ + /* 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)) return newSUB(start_subparse(FALSE, 0), newSVOP(OP_CONST, 0, newSVpv(name,0)), @@ -1163,8 +1509,16 @@ perl_get_cv(char *name, I32 create) /* Be sure to refetch the stack pointer after calling these routines. */ +/* +=for apidoc p||call_argv + +Performs a callback to the specified Perl sub. See L<perlcall>. + +=cut +*/ + I32 -perl_call_argv(char *sub_name, I32 flags, register char **argv) +Perl_call_argv(pTHX_ const char *sub_name, I32 flags, register char **argv) /* See G_* flags in cop.h */ /* null terminated arg list */ @@ -1179,37 +1533,65 @@ perl_call_argv(char *sub_name, I32 flags, register char **argv) } PUTBACK; } - return perl_call_pv(sub_name, flags); + return call_pv(sub_name, flags); } +/* +=for apidoc p||call_pv + +Performs a callback to the specified Perl sub. See L<perlcall>. + +=cut +*/ + I32 -perl_call_pv(char *sub_name, I32 flags) +Perl_call_pv(pTHX_ const char *sub_name, I32 flags) /* name of the subroutine */ /* See G_* flags in cop.h */ { - return perl_call_sv((SV*)perl_get_cv(sub_name, TRUE), flags); + return call_sv((SV*)get_cv(sub_name, TRUE), flags); } +/* +=for apidoc p||call_method + +Performs a callback to the specified Perl method. The blessed object must +be on the stack. See L<perlcall>. + +=cut +*/ + I32 -perl_call_method(char *methname, I32 flags) +Perl_call_method(pTHX_ const char *methname, I32 flags) /* name of the subroutine */ /* See G_* flags in cop.h */ { dSP; OP myop; - if (!PL_op) + if (!PL_op) { + Zero(&myop, 1, OP); PL_op = &myop; + } XPUSHs(sv_2mortal(newSVpv(methname,0))); PUTBACK; - pp_method(ARGS); - if(PL_op == &myop) - PL_op = Nullop; - return perl_call_sv(*PL_stack_sp--, flags); + pp_method(); + if (PL_op == &myop) + PL_op = Nullop; + return call_sv(*PL_stack_sp--, flags); } /* May be called with any of a CV, a GV, or an SV containing the name. */ +/* +=for apidoc p||call_sv + +Performs a callback to the Perl sub whose name is in the SV. See +L<perlcall>. + +=cut +*/ + I32 -perl_call_sv(SV *sv, I32 flags) +Perl_call_sv(pTHX_ SV *sv, I32 flags) /* See G_* flags in cop.h */ { @@ -1219,9 +1601,9 @@ perl_call_sv(SV *sv, I32 flags) I32 retval; I32 oldscope; bool oldcatch = CATCH_GET; - dJMPENV; int ret; OP* oldop = PL_op; + dJMPENV; if (flags & G_DISCARD) { ENTER; @@ -1252,7 +1634,13 @@ perl_call_sv(SV *sv, I32 flags) && !(flags & G_NODEBUG)) PL_op->op_private |= OPpENTERSUB_DB; - if (flags & G_EVAL) { + if (!(flags & G_EVAL)) { + CATCH_SET(TRUE); + call_body((OP*)&myop, FALSE); + retval = PL_stack_sp - (PL_stack_base + oldmark); + CATCH_SET(oldcatch); + } + else { cLOGOP->op_other = PL_op; PL_markstack_ptr--; /* we're trying to emulate pp_entertry() here */ @@ -1264,21 +1652,34 @@ perl_call_sv(SV *sv, I32 flags) SAVETMPS; push_return(PL_op->op_next); - PUSHBLOCK(cx, CXt_EVAL, PL_stack_sp); + PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp); PUSHEVAL(cx, 0, 0); PL_eval_root = PL_op; /* Only needed so that goto works right. */ - PL_in_eval = 1; + PL_in_eval = EVAL_INEVAL; if (flags & G_KEEPERR) - PL_in_eval |= 4; + PL_in_eval |= EVAL_KEEPERR; else sv_setpv(ERRSV,""); } PL_markstack_ptr++; +#ifdef PERL_FLEXIBLE_EXCEPTIONS + redo_body: + CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_body), + (OP*)&myop, FALSE); +#else JMPENV_PUSH(ret); +#endif switch (ret) { case 0: +#ifndef PERL_FLEXIBLE_EXCEPTIONS + redo_body: + call_body((OP*)&myop, FALSE); +#endif + retval = PL_stack_sp - (PL_stack_base + oldmark); + if (!(flags & G_KEEPERR)) + sv_setpv(ERRSV,""); break; case 1: STATUS_ALL_FAILURE; @@ -1288,15 +1689,15 @@ perl_call_sv(SV *sv, I32 flags) PL_curstash = PL_defstash; FREETMPS; JMPENV_POP; - if (PL_statusvalue) - croak("Callback called exit"); + if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED)) + Perl_croak(aTHX_ "Callback called exit"); my_exit_jump(); /* NOTREACHED */ case 3: if (PL_restartop) { PL_op = PL_restartop; PL_restartop = 0; - break; + goto redo_body; } PL_stack_sp = PL_stack_base + oldmark; if (flags & G_ARRAY) @@ -1305,22 +1706,9 @@ perl_call_sv(SV *sv, I32 flags) retval = 1; *++PL_stack_sp = &PL_sv_undef; } - goto cleanup; + break; } - } - else - CATCH_SET(TRUE); - - if (PL_op == (OP*)&myop) - PL_op = pp_entersub(ARGS); - if (PL_op) - CALLRUNOPS(); - retval = PL_stack_sp - (PL_stack_base + oldmark); - if ((flags & G_EVAL) && !(flags & G_KEEPERR)) - sv_setpv(ERRSV,""); - cleanup: - if (flags & G_EVAL) { if (PL_scopestack_ix > oldscope) { SV **newsp; PMOP *newpm; @@ -1336,8 +1724,6 @@ perl_call_sv(SV *sv, I32 flags) } JMPENV_POP; } - else - CATCH_SET(oldcatch); if (flags & G_DISCARD) { PL_stack_sp = PL_stack_base + oldmark; @@ -1349,10 +1735,45 @@ perl_call_sv(SV *sv, I32 flags) return retval; } +#ifdef PERL_FLEXIBLE_EXCEPTIONS +STATIC void * +S_vcall_body(pTHX_ va_list args) +{ + OP *myop = va_arg(args, OP*); + int is_eval = va_arg(args, int); + + call_body(myop, is_eval); + return NULL; +} +#endif + +STATIC void +S_call_body(pTHX_ OP *myop, int is_eval) +{ + dTHR; + + if (PL_op == myop) { + if (is_eval) + PL_op = Perl_pp_entereval(aTHX); + else + PL_op = Perl_pp_entersub(aTHX); + } + if (PL_op) + CALLRUNOPS(aTHX); +} + /* Eval a string. The G_EVAL flag is always assumed. */ +/* +=for apidoc p||eval_sv + +Tells Perl to C<eval> the string in the SV. + +=cut +*/ + I32 -perl_eval_sv(SV *sv, I32 flags) +Perl_eval_sv(pTHX_ SV *sv, I32 flags) /* See G_* flags in cop.h */ { @@ -1361,9 +1782,9 @@ perl_eval_sv(SV *sv, I32 flags) I32 oldmark = SP - PL_stack_base; I32 retval; I32 oldscope; - dJMPENV; int ret; OP* oldop = PL_op; + dJMPENV; if (flags & G_DISCARD) { ENTER; @@ -1387,9 +1808,22 @@ perl_eval_sv(SV *sv, I32 flags) if (flags & G_KEEPERR) myop.op_flags |= OPf_SPECIAL; +#ifdef PERL_FLEXIBLE_EXCEPTIONS + redo_body: + CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_body), + (OP*)&myop, TRUE); +#else JMPENV_PUSH(ret); +#endif switch (ret) { case 0: +#ifndef PERL_FLEXIBLE_EXCEPTIONS + redo_body: + call_body((OP*)&myop,TRUE); +#endif + retval = PL_stack_sp - (PL_stack_base + oldmark); + if (!(flags & G_KEEPERR)) + sv_setpv(ERRSV,""); break; case 1: STATUS_ALL_FAILURE; @@ -1399,15 +1833,15 @@ perl_eval_sv(SV *sv, I32 flags) PL_curstash = PL_defstash; FREETMPS; JMPENV_POP; - if (PL_statusvalue) - croak("Callback called exit"); + if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED)) + Perl_croak(aTHX_ "Callback called exit"); my_exit_jump(); /* NOTREACHED */ case 3: if (PL_restartop) { PL_op = PL_restartop; PL_restartop = 0; - break; + goto redo_body; } PL_stack_sp = PL_stack_base + oldmark; if (flags & G_ARRAY) @@ -1416,18 +1850,9 @@ perl_eval_sv(SV *sv, I32 flags) retval = 1; *++PL_stack_sp = &PL_sv_undef; } - goto cleanup; + break; } - if (PL_op == (OP*)&myop) - PL_op = pp_entereval(ARGS); - if (PL_op) - CALLRUNOPS(); - retval = PL_stack_sp - (PL_stack_base + oldmark); - if (!(flags & G_KEEPERR)) - sv_setpv(ERRSV,""); - - cleanup: JMPENV_POP; if (flags & G_DISCARD) { PL_stack_sp = PL_stack_base + oldmark; @@ -1439,14 +1864,22 @@ perl_eval_sv(SV *sv, I32 flags) return retval; } +/* +=for apidoc p||eval_pv + +Tells Perl to C<eval> the given string and return an SV* result. + +=cut +*/ + SV* -perl_eval_pv(char *p, I32 croak_on_error) +Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error) { dSP; SV* sv = newSVpv(p, 0); PUSHMARK(SP); - perl_eval_sv(sv, G_SCALAR); + eval_sv(sv, G_SCALAR); SvREFCNT_dec(sv); SPAGAIN; @@ -1455,7 +1888,7 @@ perl_eval_pv(char *p, I32 croak_on_error) if (croak_on_error && SvTRUE(ERRSV)) { STRLEN n_a; - croak(SvPVx(ERRSV, n_a)); + Perl_croak(aTHX_ SvPVx(ERRSV, n_a)); } return sv; @@ -1463,8 +1896,16 @@ perl_eval_pv(char *p, I32 croak_on_error) /* Require a module. */ +/* +=for apidoc p||require_pv + +Tells Perl to C<require> a module. + +=cut +*/ + void -perl_require_pv(char *pv) +Perl_require_pv(pTHX_ const char *pv) { SV* sv; dSP; @@ -1474,23 +1915,22 @@ perl_require_pv(char *pv) sv_setpv(sv, "require '"); sv_catpv(sv, pv); sv_catpv(sv, "'"); - perl_eval_sv(sv, G_DISCARD); + eval_sv(sv, G_DISCARD); SPAGAIN; POPSTACK; } void -magicname(char *sym, char *name, I32 namlen) +Perl_magicname(pTHX_ char *sym, char *name, I32 namlen) { register GV *gv; - if (gv = gv_fetchpv(sym,TRUE, SVt_PV)) + if ((gv = gv_fetchpv(sym,TRUE, SVt_PV))) sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen); } STATIC void -usage(char *name) /* XXX move this out into a module ? */ - +S_usage(pTHX_ 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 opton. Others? */ @@ -1498,26 +1938,29 @@ usage(char *name) /* XXX move this out into a module ? */ 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 check syntax only (runs BEGIN and END blocks)", -"-d[:debugger] run scripts under debugger", -"-D[number/list] set debugging flags (argument is a bit mask or flags)", -"-e 'command' one line of script. Several -e's allowed. Omit [programfile].", -"-F/pattern/ split() pattern for autosplit (-a). The //'s are optional.", -"-i[extension] edit <> files in place (make backup if extension supplied)", -"-Idirectory specify @INC/#include directory (may be used more than once)", +"-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)", +"-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)", "-l[octal] enable line ending processing, specifies line terminator", -"-[mM][-]module.. executes `use/no module...' before executing your script.", -"-n assume 'while (<>) { ... }' loop around your script", -"-p assume loop like -n but print line also like sed", -"-P run script through C preprocessor before compilation", -"-s enable some switch parsing for switches after script name", -"-S look for the script using PATH environment variable", -"-T turn on tainting checks", -"-u dump core after parsing script", +"-[mM][-]module execute `use/no module...' before executing program", +"-n assume 'while (<>) { ... }' loop around program", +"-p assume loop like -n but print line also, like sed", +"-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", +"-u dump core after parsing program", "-U allow unsafe operations", -"-v print version number, patchlevel plus VERY IMPORTANT perl info", -"-V[:variable] print perl configuration information", -"-w TURN WARNINGS ON FOR COMPILATION OF YOUR SCRIPT. Recommended.", +"-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", "\n", NULL @@ -1532,7 +1975,7 @@ NULL /* This routine handles any switches that can be given during run */ char * -moreswitches(char *s) +Perl_moreswitches(pTHX_ char *s) { I32 numlen; U32 rschar; @@ -1541,18 +1984,22 @@ moreswitches(char *s) case '0': { dTHR; - rschar = scan_oct(s, 4, &numlen); + rschar = (U32)scan_oct(s, 4, &numlen); SvREFCNT_dec(PL_nrs); if (rschar & ~((U8)~0)) PL_nrs = &PL_sv_undef; else if (!rschar && numlen >= 2) - PL_nrs = newSVpv("", 0); + PL_nrs = newSVpvn("", 0); else { char ch = rschar; - PL_nrs = newSVpv(&ch, 1); + PL_nrs = newSVpvn(&ch, 1); } return s + numlen; } + case 'C': + PL_widesyscalls = TRUE; + s++; + return s; case 'F': PL_minus_F = TRUE; PL_splitstr = savepv(s + 1); @@ -1570,7 +2017,7 @@ moreswitches(char *s) forbid_setid("-d"); s++; if (*s == ':' || *s == '=') { - my_setenv("PERL5DB", form("use Devel::%s;", ++s)); + my_setenv("PERL5DB", Perl_form(aTHX_ "use Devel::%s;", ++s)); s += strlen(s); } if (!PL_perldb) { @@ -1579,6 +2026,7 @@ moreswitches(char *s) } return s; case 'D': + { #ifdef DEBUGGING forbid_setid("-D"); if (isALPHA(s[1])) { @@ -1594,11 +2042,15 @@ moreswitches(char *s) } PL_debug |= 0x80000000; #else - warn("Recompile perl with -DDEBUGGING to use -D switch\n"); + dTHR; + if (ckWARN_d(WARN_DEBUGGING)) + Perl_warner(aTHX_ WARN_DEBUGGING, + "Recompile perl with -DDEBUGGING to use -D switch\n"); for (s++; isALNUM(*s); s++) ; #endif /*SUPPRESS 530*/ return s; + } case 'h': usage(PL_origargv[0]); PerlProc_exit(0); @@ -1621,14 +2073,23 @@ moreswitches(char *s) ++s; if (*s) { char *e, *p; - for (e = s; *e && !isSPACE(*e); e++) ; - p = savepvn(s, e-s); - incpush(p, TRUE); - Safefree(p); - s = e; + p = s; + /* ignore trailing spaces (possibly followed by other switches) */ + do { + for (e = p; *e && !isSPACE(*e); e++) ; + p = e; + while (isSPACE(*p)) + p++; + } while (*p && *p != '-'); + e = savepvn(s, e-s); + incpush(e, TRUE, TRUE); + Safefree(e); + s = p; + if (*s == '-') + s++; } else - croak("No space allowed after -I"); + Perl_croak(aTHX_ "No directory specified for -I"); return s; case 'l': PL_minus_l = TRUE; @@ -1638,7 +2099,7 @@ moreswitches(char *s) if (isDIGIT(*s)) { PL_ors = savepv("\n"); PL_orslen = 1; - *PL_ors = scan_oct(s, 3 + (*s == '0'), &numlen); + *PL_ors = (char)scan_oct(s, 3 + (*s == '0'), &numlen); s += numlen; } else { @@ -1671,7 +2132,7 @@ moreswitches(char *s) sv_catpv(sv, start); if (*(start-1) == 'm') { if (*s != '\0') - croak("Can't use '%c' after -mname", *s); + Perl_croak(aTHX_ "Can't use '%c' after -mname", *s); sv_catpv( sv, " ()"); } } else { @@ -1681,12 +2142,12 @@ moreswitches(char *s) sv_catpv(sv, "})"); } s += strlen(s); - if (PL_preambleav == NULL) + if (!PL_preambleav) PL_preambleav = newAV(); av_push(PL_preambleav, sv); } else - croak("No space allowed after -%c", *(s-1)); + Perl_croak(aTHX_ "No space allowed after -%c", *(s-1)); return s; case 'n': PL_minus_n = TRUE; @@ -1703,7 +2164,7 @@ moreswitches(char *s) return s; case 'T': if (!PL_tainting) - croak("Too late for \"-T\" option"); + Perl_croak(aTHX_ "Too late for \"-T\" option"); s++; return s; case 'u': @@ -1715,48 +2176,52 @@ moreswitches(char *s) s++; return s; case 'v': -#if defined(SUBVERSION) && SUBVERSION > 0 - printf("\nThis is perl, version 5.%03d_%02d built for %s", - PATCHLEVEL, SUBVERSION, ARCHNAME); -#else - printf("\nThis is perl, version %s built for %s", - PL_patchlevel, ARCHNAME); -#endif + printf(Perl_form(aTHX_ "\nThis is perl, v%vd built for %s", + PL_patchlevel, ARCHNAME)); #if defined(LOCAL_PATCH_COUNT) if (LOCAL_PATCH_COUNT > 0) printf("\n(with %d registered patch%s, see perl -V for more detail)", - LOCAL_PATCH_COUNT, (LOCAL_PATCH_COUNT!=1) ? "es" : ""); + (int)LOCAL_PATCH_COUNT, (LOCAL_PATCH_COUNT!=1) ? "es" : ""); #endif - printf("\n\nCopyright 1987-1999, Larry Wall\n"); + printf("\n\nCopyright 1987-2000, Larry Wall\n"); #ifdef MSDOS printf("\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n"); #endif #ifdef DJGPP printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n"); - printf("djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1998\n"); + printf("djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n"); #endif #ifdef OS2 printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n" - "Version 5 port Copyright (c) 1994-1998, Andreas Kaiser, Ilya Zakharevich\n"); + "Version 5 port Copyright (c) 1994-1999, Andreas Kaiser, Ilya Zakharevich\n"); #endif #ifdef atarist printf("atariST series port, ++jrb bammi@cadence.com\n"); #endif #ifdef __BEOS__ - printf("BeOS port Copyright Tom Spindler, 1997-1998\n"); + printf("BeOS port Copyright Tom Spindler, 1997-1999\n"); #endif #ifdef MPE - printf("MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-1998\n"); + printf("MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-1999\n"); #endif #ifdef OEMVS - printf("MVS (OS390) port by Mortice Kern Systems, 1997-1998\n"); + printf("MVS (OS390) port by Mortice Kern Systems, 1997-1999\n"); #endif #ifdef __VOS__ printf("Stratus VOS port by Paul_Green@stratus.com, 1997-1999\n"); #endif +#ifdef __OPEN_VM + printf("VM/ESA port by Neale Ferguson, 1998-1999\n"); +#endif +#ifdef POSIX_BC + printf("BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n"); +#endif #ifdef __MINT__ - printf("MiNT port by Guido Flohr, 1997\n"); + printf("MiNT port by Guido Flohr, 1997-1999\n"); +#endif +#ifdef EPOC + printf("EPOC port by Olaf Flebbe, 1999-2000\n"); #endif #ifdef BINARY_BUILD_NOTICE BINARY_BUILD_NOTICE; @@ -1769,7 +2234,18 @@ 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); case 'w': - PL_dowarn = TRUE; + if (! (PL_dowarn & G_WARN_ALL_MASK)) + PL_dowarn |= G_WARN_ON; + s++; + return s; + case 'W': + PL_dowarn = G_WARN_ALL_ON|G_WARN_ON; + PL_compiling.cop_warnings = pWARN_ALL ; + s++; + return s; + case 'X': + PL_dowarn = G_WARN_ALL_OFF; + PL_compiling.cop_warnings = pWARN_NONE ; s++; return s; case '*': @@ -1794,7 +2270,7 @@ Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n"); return s+1; /* FALL THROUGH */ default: - croak("Can't emulate -%.1s on #! line",s); + Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s); } return Nullch; } @@ -1805,7 +2281,7 @@ Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n"); /* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */ void -my_unexec(void) +Perl_my_unexec(pTHX) { #ifdef UNEXEC SV* prog; @@ -1833,7 +2309,7 @@ my_unexec(void) /* initialize curinterp */ STATIC void -init_interp(void) +S_init_interp(pTHX) { #ifdef PERL_OBJECT /* XXX kludge */ @@ -1844,7 +2320,7 @@ init_interp(void) PL_curcop = &PL_compiling;\ PL_curcopdb = NULL; \ PL_dbargs = 0; \ - PL_dlmax = 128; \ + PL_dumpindent = 4; \ PL_laststatval = -1; \ PL_laststype = OP_STAT; \ PL_maxscream = -1; \ @@ -1853,7 +2329,6 @@ init_interp(void) PL_tmps_floor = -1; \ PL_tmps_ix = -1; \ PL_op_mask = NULL; \ - PL_dlmax = 128; \ PL_laststatval = -1; \ PL_laststype = OP_STAT; \ PL_mess_sv = Nullsv; \ @@ -1867,22 +2342,36 @@ init_interp(void) PL_profiledata = NULL; \ PL_rsfp = Nullfp; \ PL_rsfp_filters = Nullav; \ + PL_dirty = FALSE; \ } STMT_END I_REINIT; #else # ifdef MULTIPLICITY # define PERLVAR(var,type) -# define PERLVARI(var,type,init) PL_curinterp->var = init; -# define PERLVARIC(var,type,init) PL_curinterp->var = init; +# define PERLVARA(var,n,type) +# if defined(PERL_IMPLICIT_CONTEXT) +# if defined(USE_THREADS) +# define PERLVARI(var,type,init) PERL_GET_INTERP->var = init; +# define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init; +# else /* !USE_THREADS */ +# define PERLVARI(var,type,init) aTHX->var = init; +# define PERLVARIC(var,type,init) aTHX->var = init; +# endif /* USE_THREADS */ +# else +# define PERLVARI(var,type,init) PERL_GET_INTERP->var = init; +# define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init; +# endif # include "intrpvar.h" # ifndef USE_THREADS # include "thrdvar.h" # endif # undef PERLVAR +# undef PERLVARA # undef PERLVARI # undef PERLVARIC -# else +# else # define PERLVAR(var,type) +# define PERLVARA(var,n,type) # define PERLVARI(var,type,init) PL_##var = init; # define PERLVARIC(var,type,init) PL_##var = init; # include "intrpvar.h" @@ -1890,6 +2379,7 @@ init_interp(void) # include "thrdvar.h" # endif # undef PERLVAR +# undef PERLVARA # undef PERLVARI # undef PERLVARIC # endif @@ -1898,7 +2388,7 @@ init_interp(void) } STATIC void -init_main_stash(void) +S_init_main_stash(pTHX) { dTHR; GV *gv; @@ -1914,7 +2404,7 @@ init_main_stash(void) hv_ksplit(PL_strtab, 512); PL_curstash = PL_defstash = newHV(); - PL_curstname = newSVpv("main",4); + PL_curstname = newSVpvn("main",4); gv = gv_fetchpv("main::",TRUE, SVt_PVHV); SvREFCNT_dec(GvHV(gv)); GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash); @@ -1929,22 +2419,21 @@ init_main_stash(void) GvMULTI_on(PL_errgv); PL_replgv = gv_fetchpv("\022", TRUE, SVt_PV); /* ^R */ GvMULTI_on(PL_replgv); - (void)form("%240s",""); /* Preallocate temp - for immediate signals. */ + (void)Perl_form(aTHX_ "%240s",""); /* Preallocate temp - for immediate signals. */ sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */ sv_setpvn(ERRSV, "", 0); PL_curstash = PL_defstash; - PL_compiling.cop_stash = PL_defstash; + 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)); /* We must init $/ before switches are processed. */ - sv_setpvn(perl_get_sv("/", TRUE), "\n", 1); + sv_setpvn(get_sv("/", TRUE), "\n", 1); } STATIC void -open_script(char *scriptname, bool dosearch, SV *sv, int *fdscript) +S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript) { dTHR; - register char *s; *fdscript = -1; @@ -1968,7 +2457,7 @@ open_script(char *scriptname, bool dosearch, SV *sv, int *fdscript) } } - PL_curcop->cop_filegv = gv_fetchfile(PL_origfilename); + CopFILE_set(PL_curcop, PL_origfilename); if (strEQ(PL_origfilename,"-")) scriptname = ""; if (*fdscript >= 0) { @@ -1980,18 +2469,18 @@ open_script(char *scriptname, bool dosearch, SV *sv, int *fdscript) } else if (PL_preprocess) { char *cpp_cfg = CPPSTDIN; - SV *cpp = newSVpv("",0); + SV *cpp = newSVpvn("",0); SV *cmd = NEWSV(0,0); if (strEQ(cpp_cfg, "cppstdin")) - sv_catpvf(cpp, "%s/", BIN_EXP); + Perl_sv_catpvf(aTHX_ cpp, "%s/", BIN_EXP); sv_catpv(cpp, cpp_cfg); - sv_catpv(sv,"-I"); + sv_catpvn(sv, "-I", 2); sv_catpv(sv,PRIVLIB_EXP); #ifdef MSDOS - sv_setpvf(cmd, "\ + Perl_sv_setpvf(aTHX_ cmd, "\ sed %s -e \"/^[^#]/b\" \ -e \"/^#[ ]*include[ ]/b\" \ -e \"/^#[ ]*define[ ]/b\" \ @@ -2003,10 +2492,11 @@ sed %s -e \"/^[^#]/b\" \ -e \"/^#[ ]*undef[ ]/b\" \ -e \"/^#[ ]*endif/b\" \ -e \"s/^#.*//\" \ - %s | %_ -C %_ %s", + %s | %"SVf" -C %"SVf" %s", (PL_doextract ? "-e \"1,/^#/d\n\"" : ""), #else - sv_setpvf(cmd, "\ +# ifdef __OPEN_VM + Perl_sv_setpvf(aTHX_ cmd, "\ %s %s -e '/^[^#]/b' \ -e '/^#[ ]*include[ ]/b' \ -e '/^#[ ]*define[ ]/b' \ @@ -2018,7 +2508,22 @@ sed %s -e \"/^[^#]/b\" \ -e '/^#[ ]*undef[ ]/b' \ -e '/^#[ ]*endif/b' \ -e 's/^[ ]*#.*//' \ - %s | %_ -C %_ %s", + %s | %"SVf" %"SVf" %s", +# else + Perl_sv_setpvf(aTHX_ cmd, "\ +%s %s -e '/^[^#]/b' \ + -e '/^#[ ]*include[ ]/b' \ + -e '/^#[ ]*define[ ]/b' \ + -e '/^#[ ]*if[ ]/b' \ + -e '/^#[ ]*ifdef[ ]/b' \ + -e '/^#[ ]*ifndef[ ]/b' \ + -e '/^#[ ]*else/b' \ + -e '/^#[ ]*elif[ ]/b' \ + -e '/^#[ ]*undef[ ]/b' \ + -e '/^#[ ]*endif/b' \ + -e 's/^[ ]*#.*//' \ + %s | %"SVf" -C %"SVf" %s", +# endif #ifdef LOC_SED LOC_SED, #else @@ -2044,7 +2549,7 @@ sed %s -e \"/^[^#]/b\" \ #endif #endif if (PerlProc_geteuid() != PL_uid) - croak("Can't do seteuid!\n"); + Perl_croak(aTHX_ "Can't do seteuid!\n"); } #endif /* IAMSUID */ PL_rsfp = PerlProc_popen(SvPVX(cmd), "r"); @@ -2066,31 +2571,42 @@ sed %s -e \"/^[^#]/b\" \ #ifdef DOSUID #ifndef IAMSUID /* in case script is not readable before setuid */ if (PL_euid && - PerlLIO_stat(SvPVX(GvSV(PL_curcop->cop_filegv)),&PL_statbuf) >= 0 && + PerlLIO_stat(CopFILE(PL_curcop),&PL_statbuf) >= 0 && PL_statbuf.st_mode & (S_ISUID|S_ISGID)) { /* try again */ - PerlProc_execv(form("%s/sperl%s", BIN_EXP, PL_patchlevel), PL_origargv); - croak("Can't do setuid\n"); + 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_croak(aTHX_ "Can't do setuid\n"); } #endif #endif - croak("Can't open perl script \"%s\": %s\n", - SvPVX(GvSV(PL_curcop->cop_filegv)), Strerror(errno)); + Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n", + CopFILE(PL_curcop), Strerror(errno)); } } +/* Mention + * I_SYSSTATVFS HAS_FSTATVFS + * I_SYSMOUNT + * I_STATFS HAS_FSTATFS HAS_GETFSSTAT + * I_MNTENT HAS_GETMNTENT HAS_HASMNTOPT + * here so that metaconfig picks them up. */ + #ifdef IAMSUID -static int -fd_on_nosuid_fs(int fd) +STATIC int +S_fd_on_nosuid_fs(pTHX_ int fd) { - int on_nosuid = 0; - int check_okay = 0; + int check_okay = 0; /* able to do all the required sys/libcalls */ + int on_nosuid = 0; /* the fd is on a nosuid fs */ /* - * Preferred order: fstatvfs(), fstatfs(), getmntent(). + * Preferred order: fstatvfs(), fstatfs(), ustat()+getmnt(), getmntent(). * fstatvfs() is UNIX98. - * fstatfs() is BSD. - * getmntent() is O(number-of-mounted-filesystems) and can hang. + * fstatfs() is 4.3 BSD. + * ustat()+getmnt() is pre-4.3 BSD. + * getmntent() is O(number-of-mounted-filesystems) and can hang on + * an irrelevant filesystem while trying to reach the right one. */ # ifdef HAS_FSTATVFS @@ -2098,24 +2614,45 @@ fd_on_nosuid_fs(int fd) check_okay = fstatvfs(fd, &stfs) == 0; on_nosuid = check_okay && (stfs.f_flag & ST_NOSUID); # else -# if defined(HAS_FSTATFS) && defined(HAS_STRUCT_STATFS_FLAGS) +# ifdef PERL_MOUNT_NOSUID +# if defined(HAS_FSTATFS) && \ + defined(HAS_STRUCT_STATFS) && \ + defined(HAS_STRUCT_STATFS_F_FLAGS) struct statfs stfs; check_okay = fstatfs(fd, &stfs) == 0; -# undef PERL_MOUNT_NOSUID -# if !defined(PERL_MOUNT_NOSUID) && defined(MNT_NOSUID) -# define PERL_MOUNT_NOSUID MNT_NOSUID -# endif -# if !defined(PERL_MOUNT_NOSUID) && defined(MS_NOSUID) -# define PERL_MOUNT_NOSUID MS_NOSUID -# endif -# if !defined(PERL_MOUNT_NOSUID) && defined(M_NOSUID) -# define PERL_MOUNT_NOSUID M_NOSUID -# endif -# ifdef PERL_MOUNT_NOSUID on_nosuid = check_okay && (stfs.f_flags & PERL_MOUNT_NOSUID); -# endif +# else +# if defined(HAS_FSTAT) && \ + defined(HAS_USTAT) && \ + defined(HAS_GETMNT) && \ + defined(HAS_STRUCT_FS_DATA) && \ + defined(NOSTAT_ONE) + struct stat fdst; + if (fstat(fd, &fdst) == 0) { + struct ustat us; + if (ustat(fdst.st_dev, &us) == 0) { + struct fs_data fsd; + /* NOSTAT_ONE here because we're not examining fields which + * vary between that case and STAT_ONE. */ + if (getmnt((int*)0, &fsd, (int)0, NOSTAT_ONE, us.f_fname) == 0) { + size_t cmplen = sizeof(us.f_fname); + if (sizeof(fsd.fd_req.path) < cmplen) + cmplen = sizeof(fsd.fd_req.path); + if (strnEQ(fsd.fd_req.path, us.f_fname, cmplen) && + fdst.st_dev == fsd.fd_req.dev) { + check_okay = 1; + on_nosuid = fsd.fd_req.flags & PERL_MOUNT_NOSUID; + } + } + } + } + } +# endif /* fstat+ustat+getmnt */ +# endif /* fstatfs */ # else -# if defined(HAS_GETMNTENT) && defined(HAS_HASMNTOPT) && defined(MNTOPT_NOSUID) +# if defined(HAS_GETMNTENT) && \ + defined(HAS_HASMNTOPT) && \ + defined(MNTOPT_NOSUID) FILE *mtab = fopen("/etc/mtab", "r"); struct mntent *entry; struct stat stb, fsb; @@ -2135,20 +2672,22 @@ fd_on_nosuid_fs(int fd) } if (mtab) fclose(mtab); -# endif /* mntent */ -# endif /* statfs */ +# endif /* getmntent+hasmntopt */ +# endif /* PERL_MOUNT_NOSUID: fstatfs or fstat+ustat+statfs */ # endif /* statvfs */ + if (!check_okay) - croak("Can't check filesystem of script \"%s\" for nosuid", - PL_origfilename); + Perl_croak(aTHX_ "Can't check filesystem of script \"%s\" for nosuid", PL_origfilename); return on_nosuid; } #endif /* IAMSUID */ STATIC void -validate_suid(char *validarg, char *scriptname, int fdscript) +S_validate_suid(pTHX_ char *validarg, char *scriptname, int fdscript) { +#ifdef IAMSUID int which; +#endif /* do we need to emulate setuid on scripts? */ @@ -2175,7 +2714,7 @@ validate_suid(char *validarg, char *scriptname, int fdscript) char *s, *s2; if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0) /* normal stat is insecure */ - croak("Can't stat script \"%s\"",PL_origfilename); + Perl_croak(aTHX_ "Can't stat script \"%s\"",PL_origfilename); if (fdscript < 0 && PL_statbuf.st_mode & (S_ISUID|S_ISGID)) { I32 len; STRLEN n_a; @@ -2190,8 +2729,8 @@ validate_suid(char *validarg, char *scriptname, int fdscript) * But I don't think it's too important. The manual lies when * it says access() is useful in setuid programs. */ - if (PerlLIO_access(SvPVX(GvSV(PL_curcop->cop_filegv)),1)) /*double check*/ - croak("Permission denied"); + if (PerlLIO_access(CopFILE(PL_curcop),1)) /*double check*/ + Perl_croak(aTHX_ "Permission denied"); #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 @@ -2210,27 +2749,27 @@ validate_suid(char *validarg, char *scriptname, int fdscript) # endif #endif || PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid) - croak("Can't swap uid and euid"); /* really paranoid */ - if (PerlLIO_stat(SvPVX(GvSV(PL_curcop->cop_filegv)),&tmpstatbuf) < 0) - croak("Permission denied"); /* testing full pathname here */ + 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 defined(IAMSUID) && !defined(NO_NOSUID_CHECK) if (fd_on_nosuid_fs(PerlIO_fileno(PL_rsfp))) - croak("Permission denied"); + Perl_croak(aTHX_ "Permission denied"); #endif if (tmpstatbuf.st_dev != PL_statbuf.st_dev || tmpstatbuf.st_ino != PL_statbuf.st_ino) { (void)PerlIO_close(PL_rsfp); if (PL_rsfp = PerlProc_popen("/bin/mail root","w")) { /* heh, heh */ PerlIO_printf(PL_rsfp, -"User %ld tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\ -(Filename of set-id script was %s, uid %ld gid %ld.)\n\nSincerely,\nperl\n", - (long)PL_uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino, +"User %"Uid_t_f" tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\ +(Filename of set-id script was %s, uid %"Uid_t_f" gid %"Gid_t_f".)\n\nSincerely,\nperl\n", + PL_uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino, (long)PL_statbuf.st_dev, (long)PL_statbuf.st_ino, - SvPVX(GvSV(PL_curcop->cop_filegv)), - (long)PL_statbuf.st_uid, (long)PL_statbuf.st_gid); + CopFILE(PL_curcop), + PL_statbuf.st_uid, PL_statbuf.st_gid); (void)PerlProc_pclose(PL_rsfp); } - croak("Permission denied\n"); + Perl_croak(aTHX_ "Permission denied\n"); } if ( #ifdef HAS_SETREUID @@ -2241,29 +2780,29 @@ validate_suid(char *validarg, char *scriptname, int fdscript) # endif #endif || PerlProc_getuid() != PL_uid || PerlProc_geteuid() != PL_euid) - croak("Can't reswap uid and euid"); + Perl_croak(aTHX_ "Can't reswap uid and euid"); if (!cando(S_IXUSR,FALSE,&PL_statbuf)) /* can real uid exec? */ - croak("Permission denied\n"); + Perl_croak(aTHX_ "Permission denied\n"); } #endif /* HAS_SETREUID */ #endif /* IAMSUID */ if (!S_ISREG(PL_statbuf.st_mode)) - croak("Permission denied"); + Perl_croak(aTHX_ "Permission denied"); if (PL_statbuf.st_mode & S_IWOTH) - croak("Setuid/gid script is writable by world"); + Perl_croak(aTHX_ "Setuid/gid script is writable by world"); PL_doswitches = FALSE; /* -s is insecure in suid */ - PL_curcop->cop_line++; + CopLINE_inc(PL_curcop); if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch || strnNE(SvPV(PL_linestr,n_a),"#!",2) ) /* required even on Sys V */ - croak("No #! line"); + Perl_croak(aTHX_ "No #! line"); s = SvPV(PL_linestr,n_a)+2; if (*s == ' ') s++; while (!isSPACE(*s)) s++; for (s2 = s; (s2 > SvPV(PL_linestr,n_a)+2 && (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ; if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */ - croak("Not a perl script"); + Perl_croak(aTHX_ "Not a perl script"); while (*s == ' ' || *s == '\t') s++; /* * #! arg must be what we saw above. They can invoke it by @@ -2273,13 +2812,13 @@ validate_suid(char *validarg, char *scriptname, int fdscript) len = strlen(validarg); if (strEQ(validarg," PHOOEY ") || strnNE(s,validarg,len) || !isSPACE(s[len])) - croak("Args must match #! line"); + Perl_croak(aTHX_ "Args must match #! line"); #ifndef IAMSUID if (PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) && PL_euid == PL_statbuf.st_uid) if (!PL_do_undump) - croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\ + 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 /* IAMSUID */ @@ -2287,9 +2826,11 @@ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n"); (void)PerlIO_close(PL_rsfp); #ifndef IAMSUID /* try again */ - PerlProc_execv(form("%s/sperl%s", BIN_EXP, PL_patchlevel), PL_origargv); + PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT, BIN_EXP, + (int)PERL_REVISION, (int)PERL_VERSION, + (int)PERL_SUBVERSION), PL_origargv); #endif - croak("Can't do setuid\n"); + Perl_croak(aTHX_ "Can't do setuid\n"); } if (PL_statbuf.st_mode & S_ISGID && PL_statbuf.st_gid != PL_egid) { @@ -2307,7 +2848,7 @@ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n"); #endif #endif if (PerlProc_getegid() != PL_statbuf.st_gid) - croak("Can't do setegid!\n"); + Perl_croak(aTHX_ "Can't do setegid!\n"); } if (PL_statbuf.st_mode & S_ISUID) { if (PL_statbuf.st_uid != PL_euid) @@ -2325,7 +2866,7 @@ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n"); #endif #endif if (PerlProc_geteuid() != PL_statbuf.st_uid) - croak("Can't do seteuid!\n"); + Perl_croak(aTHX_ "Can't do seteuid!\n"); } else if (PL_uid) { /* oops, mustn't run as root */ #ifdef HAS_SETEUID @@ -2342,19 +2883,19 @@ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n"); #endif #endif if (PerlProc_geteuid() != PL_uid) - croak("Can't do seteuid!\n"); + Perl_croak(aTHX_ "Can't do seteuid!\n"); } init_ids(); if (!cando(S_IXUSR,TRUE,&PL_statbuf)) - croak("Permission denied\n"); /* they can't do this */ + Perl_croak(aTHX_ "Permission denied\n"); /* they can't do this */ } #ifdef IAMSUID else if (PL_preprocess) - croak("-P not allowed for setuid/setgid script\n"); + Perl_croak(aTHX_ "-P not allowed for setuid/setgid script\n"); else if (fdscript >= 0) - croak("fd script not allowed in suidperl\n"); + Perl_croak(aTHX_ "fd script not allowed in suidperl\n"); else - croak("Script is not setuid/setgid in suidperl\n"); + Perl_croak(aTHX_ "Script is not setuid/setgid in suidperl\n"); /* We absolutely must clear out any saved ids here, so we */ /* exec the real perl, substituting fd script for scriptname. */ @@ -2363,14 +2904,16 @@ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n"); 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]) - croak("Permission denied"); - PL_origargv[which] = savepv(form("/dev/fd/%d/%s", + Perl_croak(aTHX_ "Permission denied"); + 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 - PerlProc_execv(form("%s/perl%s", BIN_EXP, PL_patchlevel), PL_origargv);/* try again */ - croak("Can't do setuid\n"); + 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_croak(aTHX_ "Can't do setuid\n"); #endif /* IAMSUID */ #else /* !DOSUID */ if (PL_euid != PL_uid || PL_egid != PL_gid) { /* (suidperl doesn't exist, in fact) */ @@ -2382,7 +2925,7 @@ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n"); (PL_egid != PL_gid && PL_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID) ) if (!PL_do_undump) - croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\ + 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 */ /* not set-id, must be wrapped */ @@ -2391,7 +2934,7 @@ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n"); } STATIC void -find_beginning(void) +S_find_beginning(pTHX) { register char *s, *s2; @@ -2400,7 +2943,7 @@ find_beginning(void) forbid_setid("-x"); while (PL_doextract) { if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch) - croak("No Perl script found in input\n"); + Perl_croak(aTHX_ "No Perl script found in input\n"); if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) { PerlIO_ungetc(PL_rsfp, '\n'); /* to keep line count right */ PL_doextract = FALSE; @@ -2411,22 +2954,21 @@ find_beginning(void) while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--; if (strnEQ(s2-4,"perl",4)) /*SUPPRESS 530*/ - while (s = moreswitches(s)) ; + while ((s = moreswitches(s))) + ; } - if (PL_cddir && PerlDir_chdir(PL_cddir) < 0) - croak("Can't chdir to %s",PL_cddir); } } } STATIC void -init_ids(void) +S_init_ids(pTHX) { - PL_uid = (int)PerlProc_getuid(); - PL_euid = (int)PerlProc_geteuid(); - PL_gid = (int)PerlProc_getgid(); - PL_egid = (int)PerlProc_getegid(); + PL_uid = PerlProc_getuid(); + PL_euid = PerlProc_geteuid(); + PL_gid = PerlProc_getgid(); + PL_egid = PerlProc_getegid(); #ifdef VMS PL_uid |= PL_gid << 16; PL_euid |= PL_egid << 16; @@ -2435,31 +2977,34 @@ init_ids(void) } STATIC void -forbid_setid(char *s) +S_forbid_setid(pTHX_ char *s) { if (PL_euid != PL_uid) - croak("No %s allowed while running setuid", s); + Perl_croak(aTHX_ "No %s allowed while running setuid", s); if (PL_egid != PL_gid) - croak("No %s allowed while running setgid", s); + Perl_croak(aTHX_ "No %s allowed while running setgid", s); } -STATIC void -init_debugger(void) +void +Perl_init_debugger(pTHX) { dTHR; + HV *ostash = PL_curstash; + PL_curstash = PL_debstash; PL_dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV)))); AvREAL_off(PL_dbargs); PL_DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV); PL_DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV); PL_DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV)); + sv_upgrade(GvSV(PL_DBsub), SVt_IV); /* IVX accessed if PERLDB_SUB_NN */ PL_DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV))); sv_setiv(PL_DBsingle, 0); PL_DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV))); sv_setiv(PL_DBtrace, 0); PL_DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV))); sv_setiv(PL_DBsignal, 0); - PL_curstash = PL_defstash; + PL_curstash = ostash; } #ifndef STRESS_REALLOC @@ -2469,7 +3014,7 @@ init_debugger(void) #endif void -init_stacks(ARGSproto) +Perl_init_stacks(pTHX) { /* start with 128-item stack and 8K cxstack */ PL_curstackinfo = new_stackinfo(REASONABLE(128), @@ -2491,7 +3036,7 @@ init_stacks(ARGSproto) PL_markstack_ptr = PL_markstack; PL_markstack_max = PL_markstack + REASONABLE(32); - SET_MARKBASE; + SET_MARK_OFFSET; New(54,PL_scopestack,REASONABLE(32),I32); PL_scopestack_ix = 0; @@ -2509,7 +3054,7 @@ init_stacks(ARGSproto) #undef REASONABLE STATIC void -nuke_stacks(void) +S_nuke_stacks(pTHX) { dTHR; while (PL_curstackinfo->si_next) @@ -2526,10 +3071,6 @@ nuke_stacks(void) Safefree(PL_scopestack); Safefree(PL_savestack); Safefree(PL_retstack); - DEBUG( { - Safefree(PL_debname); - Safefree(PL_debdelim); - } ) } #ifndef PERL_OBJECT @@ -2537,7 +3078,7 @@ static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */ #endif STATIC void -init_lexer(void) +S_init_lexer(pTHX) { #ifdef PERL_OBJECT PerlIO *tmpfp; @@ -2546,38 +3087,41 @@ init_lexer(void) PL_rsfp = Nullfp; lex_start(PL_linestr); PL_rsfp = tmpfp; - PL_subname = newSVpv("main",4); + PL_subname = newSVpvn("main",4); } STATIC void -init_predump_symbols(void) +S_init_predump_symbols(pTHX) { dTHR; GV *tmpgv; - GV *othergv; + IO *io; - sv_setpvn(perl_get_sv("\"", TRUE), " ", 1); + sv_setpvn(get_sv("\"", TRUE), " ", 1); PL_stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO); GvMULTI_on(PL_stdingv); - IoIFP(GvIOp(PL_stdingv)) = PerlIO_stdin(); + io = GvIOp(PL_stdingv); + IoIFP(io) = PerlIO_stdin(); tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV); GvMULTI_on(tmpgv); - GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(PL_stdingv)); + GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io); tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO); GvMULTI_on(tmpgv); - IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = PerlIO_stdout(); + io = GvIOp(tmpgv); + IoOFP(io) = IoIFP(io) = PerlIO_stdout(); setdefout(tmpgv); tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV); GvMULTI_on(tmpgv); - GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(PL_defoutgv)); + GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io); - othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO); - GvMULTI_on(othergv); - IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = PerlIO_stderr(); + PL_stderrgv = gv_fetchpv("STDERR",TRUE, SVt_PVIO); + GvMULTI_on(PL_stderrgv); + io = GvIOp(PL_stderrgv); + IoOFP(io) = IoIFP(io) = PerlIO_stderr(); tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV); GvMULTI_on(tmpgv); - GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv)); + GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io); PL_statname = NEWSV(66,0); /* last filename we did stat on */ @@ -2586,7 +3130,7 @@ init_predump_symbols(void) } STATIC void -init_postdump_symbols(register int argc, register char **argv, register char **env) +S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env) { dTHR; char *s; @@ -2598,11 +3142,11 @@ init_postdump_symbols(register int argc, register char **argv, register char **e for (; argc > 0 && **argv == '-'; argc--,argv++) { if (!argv[0][1]) break; - if (argv[0][1] == '-') { + if (argv[0][1] == '-' && !argv[0][2]) { argc--,argv++; break; } - if (s = strchr(argv[0], '=')) { + if ((s = strchr(argv[0], '='))) { *s++ = '\0'; sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s); } @@ -2619,26 +3163,33 @@ init_postdump_symbols(register int argc, register char **argv, register char **e PL_formtarget = PL_bodytarget; TAINT; - if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) { + if ((tmpgv = gv_fetchpv("0",TRUE, SVt_PV))) { sv_setpv(GvSV(tmpgv),PL_origfilename); magicname("0", "0", 1); } - if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV)) + if ((tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))) +#ifdef OS2 + sv_setpv(GvSV(tmpgv), os2_execname()); +#else sv_setpv(GvSV(tmpgv),PL_origargv[0]); - if (PL_argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) { +#endif + if ((PL_argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV))) { GvMULTI_on(PL_argvgv); (void)gv_AVadd(PL_argvgv); av_clear(GvAVn(PL_argvgv)); for (; argc > 0; argc--,argv++) { - av_push(GvAVn(PL_argvgv),newSVpv(argv[0],0)); + SV *sv = newSVpv(argv[0],0); + av_push(GvAVn(PL_argvgv),sv); + if (PL_widesyscalls) + sv_utf8_upgrade(sv); } } - if (PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) { + if ((PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV))) { HV *hv; GvMULTI_on(PL_envgv); hv = GvHVn(PL_envgv); hv_magic(hv, PL_envgv, 'E'); -#ifndef VMS /* VMS doesn't have environ array */ +#if !defined( VMS) && !defined(EPOC) /* VMS doesn't have 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 if the environment has been modified since. To avoid this @@ -2669,21 +3220,21 @@ init_postdump_symbols(register int argc, register char **argv, register char **e #endif } TAINT_NOT; - if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV)) - sv_setiv(GvSV(tmpgv), (IV)getpid()); + if ((tmpgv = gv_fetchpv("$",TRUE, SVt_PV))) + sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid()); } STATIC void -init_perllib(void) +S_init_perllib(pTHX) { char *s; if (!PL_tainting) { #ifndef VMS s = PerlEnv_getenv("PERL5LIB"); if (s) - incpush(s, TRUE); + incpush(s, TRUE, TRUE); else - incpush(PerlEnv_getenv("PERLLIB"), FALSE); + incpush(PerlEnv_getenv("PERLLIB"), FALSE, FALSE); #else /* VMS */ /* Treat PERL5?LIB as a possible search list logical name -- the * "natural" VMS idiom for a Unix path string. We allow each @@ -2692,43 +3243,73 @@ init_perllib(void) char buf[256]; int idx = 0; if (my_trnlnm("PERL5LIB",buf,0)) - do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx)); + do { incpush(buf,TRUE,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx)); else - while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE); + while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE,FALSE); #endif /* VMS */ } /* Use the ~-expanded versions of APPLLIB (undocumented), - ARCHLIB PRIVLIB SITEARCH and SITELIB + ARCHLIB PRIVLIB SITEARCH SITELIB VENDORARCH and VENDORLIB */ #ifdef APPLLIB_EXP - incpush(APPLLIB_EXP, TRUE); + incpush(APPLLIB_EXP, TRUE, TRUE); #endif #ifdef ARCHLIB_EXP - incpush(ARCHLIB_EXP, FALSE); + incpush(ARCHLIB_EXP, FALSE, FALSE); #endif #ifndef PRIVLIB_EXP -#define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl" +# define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl" #endif #if defined(WIN32) - incpush(PRIVLIB_EXP, TRUE); + incpush(PRIVLIB_EXP, TRUE, FALSE); #else - incpush(PRIVLIB_EXP, FALSE); + incpush(PRIVLIB_EXP, FALSE, FALSE); #endif #ifdef SITEARCH_EXP - incpush(SITEARCH_EXP, FALSE); + /* sitearch is always relative to sitelib on Windows for + * DLL-based path intuition to work correctly */ +# if !defined(WIN32) + incpush(SITEARCH_EXP, FALSE, FALSE); +# endif #endif + #ifdef SITELIB_EXP -#if defined(WIN32) - incpush(SITELIB_EXP, TRUE); -#else - incpush(SITELIB_EXP, FALSE); +# if defined(WIN32) + incpush(SITELIB_EXP, TRUE, FALSE); /* this picks up sitearch as well */ +# else + incpush(SITELIB_EXP, FALSE, FALSE); +# endif #endif + +#ifdef SITELIB_STEM /* Search for version-specific dirs below here */ + incpush(SITELIB_STEM, FALSE, 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); +# endif +#endif + +#ifdef PERL_VENDORLIB_EXP +# if defined(WIN32) + incpush(PERL_VENDORLIB_EXP, TRUE, FALSE); /* this picks up vendorarch as well */ +# else + incpush(PERL_VENDORLIB_EXP, FALSE, FALSE); +# endif +#endif + +#ifdef PERL_VENDORLIB_STEM /* Search for version-specific dirs below here */ + incpush(PERL_VENDORLIB_STEM, FALSE, TRUE); #endif + if (!PL_tainting) - incpush(".", FALSE); + incpush(".", FALSE, FALSE); } #if defined(DOSISH) @@ -2745,26 +3326,15 @@ init_perllib(void) #endif STATIC void -incpush(char *p, int addsubdirs) +S_incpush(pTHX_ char *p, int addsubdirs, int addoldvers) { SV *subdir = Nullsv; - if (!p) + if (!p || !*p) return; - if (addsubdirs) { + if (addsubdirs || addoldvers) { subdir = sv_newmortal(); - if (!PL_archpat_auto) { - STRLEN len = (sizeof(ARCHNAME) + strlen(PL_patchlevel) - + sizeof("//auto")); - New(55, PL_archpat_auto, len, char); - sprintf(PL_archpat_auto, "/%s/%s/auto", ARCHNAME, PL_patchlevel); -#ifdef VMS - for (len = sizeof(ARCHNAME) + 2; - PL_archpat_auto[len] != '\0' && PL_archpat_auto[len] != '/'; len++) - if (PL_archpat_auto[len] == '.') PL_archpat_auto[len] = '_'; -#endif - } } /* Break at all separators */ @@ -2775,7 +3345,7 @@ incpush(char *p, int addsubdirs) /* skip any consecutive separators */ while ( *p == PERLLIB_SEP ) { /* Uncomment the next line for PATH semantics */ - /* av_push(GvAVn(PL_incgv), newSVpv(".", 1)); */ + /* av_push(GvAVn(PL_incgv), newSVpvn(".", 1)); */ p++; } @@ -2793,7 +3363,12 @@ incpush(char *p, int addsubdirs) * BEFORE pushing libdir onto @INC we may first push version- and * archname-specific sub-directories. */ - if (addsubdirs) { + if (addsubdirs || addoldvers) { +#ifdef PERL_INC_VERSION_LIST + /* Configure terminates PERL_INC_VERSION_LIST with a NULL */ + const char *incverlist[] = { PERL_INC_VERSION_LIST }; + const char **incver; +#endif struct stat tmpstatbuf; #ifdef VMS char *unix; @@ -2805,25 +3380,46 @@ incpush(char *p, int addsubdirs) sv_usepvn(libdir,unix,len); } else - PerlIO_printf(PerlIO_stderr(), + PerlIO_printf(Perl_error_log, "Failed to unixify @INC element \"%s\"\n", SvPV(libdir,len)); #endif - /* .../archname/version if -d .../archname/version/auto */ - sv_setsv(subdir, libdir); - sv_catpv(subdir, PL_archpat_auto); - if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 && - S_ISDIR(tmpstatbuf.st_mode)) - av_push(GvAVn(PL_incgv), - newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto")); - - /* .../archname if -d .../archname/auto */ - sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME), - strlen(PL_patchlevel) + 1, "", 0); - if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 && - S_ISDIR(tmpstatbuf.st_mode)) - av_push(GvAVn(PL_incgv), - newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto")); + if (addsubdirs) { + /* .../version/archname if -d .../version/archname */ + Perl_sv_setpvf(aTHX_ subdir, "%"SVf"/"PERL_FS_VER_FMT"/%s", + libdir, + (int)PERL_REVISION, (int)PERL_VERSION, + (int)PERL_SUBVERSION, ARCHNAME); + if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 && + S_ISDIR(tmpstatbuf.st_mode)) + av_push(GvAVn(PL_incgv), newSVsv(subdir)); + + /* .../version if -d .../version */ + Perl_sv_setpvf(aTHX_ subdir, "%"SVf"/"PERL_FS_VER_FMT, libdir, + (int)PERL_REVISION, (int)PERL_VERSION, + (int)PERL_SUBVERSION); + if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 && + S_ISDIR(tmpstatbuf.st_mode)) + av_push(GvAVn(PL_incgv), newSVsv(subdir)); + + /* .../archname if -d .../archname */ + Perl_sv_setpvf(aTHX_ subdir, "%"SVf"/%s", libdir, ARCHNAME); + if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 && + S_ISDIR(tmpstatbuf.st_mode)) + av_push(GvAVn(PL_incgv), newSVsv(subdir)); + } + +#ifdef PERL_INC_VERSION_LIST + if (addoldvers) { + for (incver = incverlist; *incver; incver++) { + /* .../xxx if -d .../xxx */ + Perl_sv_setpvf(aTHX_ subdir, "%"SVf"/%s", libdir, *incver); + if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 && + S_ISDIR(tmpstatbuf.st_mode)) + av_push(GvAVn(PL_incgv), newSVsv(subdir)); + } + } +#endif } /* finally push this lib directory on the end of @INC */ @@ -2833,18 +3429,20 @@ incpush(char *p, int addsubdirs) #ifdef USE_THREADS STATIC struct perl_thread * -init_main_thread() +S_init_main_thread(pTHX) { +#if !defined(PERL_IMPLICIT_CONTEXT) struct perl_thread *thr; +#endif XPV *xpv; Newz(53, thr, 1, struct perl_thread); PL_curcop = &PL_compiling; + thr->interp = PERL_GET_INTERP; thr->cvcache = newHV(); thr->threadsv = newAV(); /* thr->threadsvp is set when find_threadsv is called */ thr->specific = newAV(); - thr->errhv = newHV(); thr->flags = THRf_R_JOINABLE; MUTEX_INIT(&thr->mutex); /* Handcraft thrsv similarly to mess_sv */ @@ -2859,6 +3457,7 @@ init_main_thread() *SvEND(PL_thrsv) = '\0'; /* in the trailing_nul field */ thr->oursv = PL_thrsv; PL_chopset = " \n-"; + PL_dumpindent = 4; MUTEX_LOCK(&PL_threads_mutex); PL_nthreads++; @@ -2868,7 +3467,7 @@ init_main_thread() MUTEX_UNLOCK(&PL_threads_mutex); #ifdef HAVE_THREAD_INTERN - init_thread_intern(thr); + Perl_init_thread_intern(thr); #endif #ifdef SET_THREAD_SELF @@ -2876,7 +3475,7 @@ init_main_thread() #else thr->self = pthread_self(); #endif /* SET_THREAD_SELF */ - SET_THR(thr); + PERL_SET_THX(thr); /* * These must come after the SET_THR because sv_setpvn does @@ -2889,12 +3488,15 @@ init_main_thread() sv_upgrade(PL_bodytarget, SVt_PVFM); sv_setpvn(PL_bodytarget, "", 0); PL_formtarget = PL_bodytarget; - thr->errsv = newSVpv("", 0); + thr->errsv = newSVpvn("", 0); (void) find_threadsv("@"); /* Ensure $@ is initialised early */ PL_maxscream = -1; - PL_regcompp = FUNC_NAME_TO_PTR(pregcomp); - PL_regexecp = FUNC_NAME_TO_PTR(regexec_flags); + PL_regcompp = MEMBER_TO_FPTR(Perl_pregcomp); + PL_regexecp = MEMBER_TO_FPTR(Perl_regexec_flags); + PL_regint_start = MEMBER_TO_FPTR(Perl_re_intuit_start); + PL_regint_string = MEMBER_TO_FPTR(Perl_re_intuit_string); + PL_regfree = MEMBER_TO_FPTR(Perl_pregfree); PL_regindent = 0; PL_reginterp_cnt = 0; @@ -2903,38 +3505,47 @@ init_main_thread() #endif /* USE_THREADS */ void -call_list(I32 oldscope, AV *paramList) +Perl_call_list(pTHX_ I32 oldscope, AV *paramList) { dTHR; - line_t oldline = PL_curcop->cop_line; + SV *atsv; + line_t oldline = CopLINE(PL_curcop); + CV *cv; STRLEN len; - dJMPENV; int ret; + dJMPENV; while (AvFILL(paramList) >= 0) { - CV *cv = (CV*)av_shift(paramList); - + cv = (CV*)av_shift(paramList); SAVEFREESV(cv); - +#ifdef PERL_FLEXIBLE_EXCEPTIONS + CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_list_body), cv); +#else JMPENV_PUSH(ret); +#endif switch (ret) { - case 0: { - SV* atsv = ERRSV; - PUSHMARK(PL_stack_sp); - perl_call_sv((SV*)cv, G_EVAL|G_DISCARD); - (void)SvPV(atsv, len); - if (len) { - JMPENV_POP; - PL_curcop = &PL_compiling; - PL_curcop->cop_line = oldline; - if (paramList == PL_beginav) - sv_catpv(atsv, "BEGIN failed--compilation aborted"); - else - sv_catpv(atsv, "END failed--cleanup aborted"); - while (PL_scopestack_ix > oldscope) - LEAVE; - croak("%s", SvPVX(atsv)); - } + case 0: +#ifndef PERL_FLEXIBLE_EXCEPTIONS + call_list_body(cv); +#endif + atsv = ERRSV; + (void)SvPV(atsv, len); + if (len) { + STRLEN n_a; + PL_curcop = &PL_compiling; + CopLINE_set(PL_curcop, oldline); + if (paramList == PL_beginav) + sv_catpv(atsv, "BEGIN failed--compilation aborted"); + else + Perl_sv_catpvf(aTHX_ atsv, + "%s failed--call queue aborted", + paramList == PL_checkav ? "CHECK" + : paramList == PL_initav ? "INIT" + : "END"); + while (PL_scopestack_ix > oldscope) + LEAVE; + JMPENV_POP; + Perl_croak(aTHX_ "%s", SvPVx(atsv, n_a)); } break; case 1: @@ -2946,36 +3557,53 @@ call_list(I32 oldscope, AV *paramList) LEAVE; FREETMPS; PL_curstash = PL_defstash; - if (PL_endav) - call_list(oldscope, PL_endav); - JMPENV_POP; PL_curcop = &PL_compiling; - PL_curcop->cop_line = oldline; - if (PL_statusvalue) { + CopLINE_set(PL_curcop, oldline); + JMPENV_POP; + if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED)) { if (paramList == PL_beginav) - croak("BEGIN failed--compilation aborted"); + Perl_croak(aTHX_ "BEGIN failed--compilation aborted"); else - croak("END failed--cleanup aborted"); + Perl_croak(aTHX_ "%s failed--call queue aborted", + paramList == PL_checkav ? "CHECK" + : paramList == PL_initav ? "INIT" + : "END"); } my_exit_jump(); /* NOTREACHED */ case 3: - if (!PL_restartop) { - PerlIO_printf(PerlIO_stderr(), "panic: restartop\n"); - FREETMPS; - break; + if (PL_restartop) { + PL_curcop = &PL_compiling; + CopLINE_set(PL_curcop, oldline); + JMPENV_JUMP(3); } - JMPENV_POP; - PL_curcop = &PL_compiling; - PL_curcop->cop_line = oldline; - JMPENV_JUMP(3); + PerlIO_printf(Perl_error_log, "panic: restartop\n"); + FREETMPS; + break; } JMPENV_POP; } } +#ifdef PERL_FLEXIBLE_EXCEPTIONS +STATIC void * +S_vcall_list_body(pTHX_ va_list args) +{ + CV *cv = va_arg(args, CV*); + return call_list_body(cv); +} +#endif + +STATIC void * +S_call_list_body(pTHX_ CV *cv) +{ + PUSHMARK(PL_stack_sp); + call_sv((SV*)cv, G_EVAL|G_DISCARD); + return NULL; +} + void -my_exit(U32 status) +Perl_my_exit(pTHX_ U32 status) { dTHR; @@ -2996,7 +3624,7 @@ my_exit(U32 status) } void -my_failure_exit(void) +Perl_my_failure_exit(pTHX) { #ifdef VMS if (vaxc$errno & 1) { @@ -3025,9 +3653,9 @@ my_failure_exit(void) } STATIC void -my_exit_jump(void) +S_my_exit_jump(pTHX) { - dSP; + dTHR; register PERL_CONTEXT *cx; I32 gimme; SV **newsp; @@ -3049,17 +3677,11 @@ my_exit_jump(void) } #ifdef PERL_OBJECT -#define NO_XSLOCKS -#endif /* PERL_OBJECT */ - #include "XSUB.h" +#endif static I32 -#ifdef PERL_OBJECT -read_e_script(CPerlObj *pPerl, int idx, SV *buf_sv, int maxlen) -#else -read_e_script(int idx, SV *buf_sv, int maxlen) -#endif +read_e_script(pTHXo_ int idx, SV *buf_sv, int maxlen) { char *p, *nl; p = SvPVX(PL_e_script); @@ -3073,5 +3695,3 @@ read_e_script(int idx, SV *buf_sv, int maxlen) sv_chop(PL_e_script, nl); return 1; } - - diff --git a/contrib/perl5/perl.h b/contrib/perl5/perl.h index b463595ad129..831bc553c4a6 100644 --- a/contrib/perl5/perl.h +++ b/contrib/perl5/perl.h @@ -1,14 +1,14 @@ /* perl.h * - * Copyright (c) 1987-1999, Larry Wall + * Copyright (c) 1987-2000, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. * + * $FreeBSD$ */ #ifndef H_PERL #define H_PERL 1 -#define OVERLOAD #ifdef PERL_FOR_X2P /* @@ -16,14 +16,68 @@ * Above symbol is defined via -D in 'x2p/Makefile.SH' * Decouple x2p stuff from some of perls more extreme eccentricities. */ -#undef EMBED -#undef NO_EMBED -#define NO_EMBED #undef MULTIPLICITY #undef USE_STDIO #define USE_STDIO #endif /* PERL_FOR_X2P */ +#define VOIDUSED 1 +#include "config.h" + +#if defined(USE_ITHREADS) && defined(USE_5005THREADS) +# include "error: USE_ITHREADS and USE_5005THREADS are incompatible" +#endif + +/* XXX This next guard can disappear if the sources are revised + to use USE_5005THREADS throughout. -- A.D 1/6/2000 +*/ +#if defined(USE_ITHREADS) && defined(USE_THREADS) +# include "error: USE_ITHREADS and USE_THREADS are incompatible" +#endif + +/* See L<perlguts/"The Perl API"> for detailed notes on + * PERL_IMPLICIT_CONTEXT and PERL_IMPLICIT_SYS */ + +#ifdef USE_ITHREADS +# if !defined(MULTIPLICITY) && !defined(PERL_OBJECT) +# define MULTIPLICITY +# endif +#endif + +#ifdef USE_THREADS +# ifndef PERL_IMPLICIT_CONTEXT +# define PERL_IMPLICIT_CONTEXT +# endif +#endif + +#if defined(MULTIPLICITY) +# ifndef PERL_IMPLICIT_CONTEXT +# define PERL_IMPLICIT_CONTEXT +# endif +#endif + +#ifdef PERL_CAPI +# undef PERL_OBJECT +# ifndef MULTIPLICITY +# define MULTIPLICITY +# endif +# ifndef PERL_IMPLICIT_CONTEXT +# define PERL_IMPLICIT_CONTEXT +# endif +# ifndef PERL_IMPLICIT_SYS +# define PERL_IMPLICIT_SYS +# endif +#endif + +#ifdef PERL_OBJECT +# ifndef PERL_IMPLICIT_CONTEXT +# define PERL_IMPLICIT_CONTEXT +# endif +# ifndef PERL_IMPLICIT_SYS +# define PERL_IMPLICIT_SYS +# endif +#endif + #ifdef PERL_OBJECT /* PERL_OBJECT explained - DickH and DougL @ ActiveState.com @@ -47,8 +101,8 @@ the perl interpreter. | Perl Host | +-----------+ ^ - | - v + | + v +-----------+ +-----------+ | Perl Core |<->| Extension | +-----------+ +-----------+ ... @@ -61,9 +115,9 @@ PERL CORE variables or functions needed are made member functions 3. all writable static variables are made member variables 4. all global variables and functions are defined as: - #define var CPerlObj::Perl_var + #define var CPerlObj::PL_var #define func CPerlObj::Perl_func - * these are in objpp.h + * these are in embed.h This necessitated renaming some local variables and functions that had the same name as a global variable or function. This was probably a _good_ thing anyway. @@ -73,7 +127,7 @@ EXTENSIONS 1. Access to global variables and perl functions is through a pointer to the PERL_OBJECT. This pointer type is CPerlObj*. This is made transparent to extension developers by the following macros: - #define var pPerl->Perl_var + #define var pPerl->PL_var #define func pPerl->Perl_func * these are done in objXSUB.h This requires that the extension be compiled as C++, which means @@ -102,41 +156,102 @@ functions are now member functions of the PERL_OBJECT. class CPerlObj; #define STATIC -#define CPERLscope(x) CPerlObj::x -#define CPERLproto CPerlObj * -#define _CPERLproto ,CPERLproto -#define CPERLarg CPerlObj *pPerl -#define CPERLarg_ CPERLarg, -#define _CPERLarg ,CPERLarg -#define PERL_OBJECT_THIS this -#define _PERL_OBJECT_THIS ,this -#define PERL_OBJECT_THIS_ this, -#define CALLRUNOPS (this->*PL_runops) -#define CALLREGCOMP (this->*PL_regcompp) -#define CALLREGEXEC (this->*PL_regexecp) +#define CPERLscope(x) CPerlObj::x +#define CALL_FPTR(fptr) (aTHXo->*fptr) + +#define pTHXo CPerlObj *pPerl +#define pTHXo_ pTHXo, +#define aTHXo this +#define aTHXo_ this, +#define PERL_OBJECT_THIS aTHXo +#define PERL_OBJECT_THIS_ aTHXo_ +#define dTHXoa(a) pTHXo = a +#define dTHXo dTHXoa(PERL_GET_THX) + +#define pTHXx void +#define pTHXx_ +#define aTHXx +#define aTHXx_ #else /* !PERL_OBJECT */ +#ifdef PERL_IMPLICIT_CONTEXT +# ifdef USE_THREADS +struct perl_thread; +# define pTHX register struct perl_thread *thr +# define aTHX thr +# define dTHR dNOOP +# else +# ifndef MULTIPLICITY +# define MULTIPLICITY +# endif +# define pTHX register PerlInterpreter *my_perl +# define aTHX my_perl +# endif +# define dTHXa(a) pTHX = a +# define dTHX dTHXa(PERL_GET_THX) +# define pTHX_ pTHX, +# define aTHX_ aTHX, +# define pTHX_1 2 +# define pTHX_2 3 +# define pTHX_3 4 +# define pTHX_4 5 +#endif + #define STATIC static #define CPERLscope(x) x -#define CPERLproto -#define _CPERLproto #define CPERLarg void #define CPERLarg_ #define _CPERLarg #define PERL_OBJECT_THIS #define _PERL_OBJECT_THIS #define PERL_OBJECT_THIS_ -#define CALLRUNOPS PL_runops -#define CALLREGCOMP (*PL_regcompp) -#define CALLREGEXEC (*PL_regexecp) +#define CALL_FPTR(fptr) (*fptr) #endif /* PERL_OBJECT */ -#define VOIDUSED 1 -#include "config.h" +#define CALLRUNOPS CALL_FPTR(PL_runops) +#define CALLREGCOMP CALL_FPTR(PL_regcompp) +#define CALLREGEXEC CALL_FPTR(PL_regexecp) +#define CALLREG_INTUIT_START CALL_FPTR(PL_regint_start) +#define CALLREG_INTUIT_STRING CALL_FPTR(PL_regint_string) +#define CALLREGFREE CALL_FPTR(PL_regfree) + +#ifdef PERL_FLEXIBLE_EXCEPTIONS +# define CALLPROTECT CALL_FPTR(PL_protect) +#endif + +#define NOOP (void)0 +#define dNOOP extern int Perl___notused + +#ifndef pTHX +# define pTHX void +# define pTHX_ +# define aTHX +# define aTHX_ +# define dTHXa(a) dNOOP +# define dTHX dNOOP +# define pTHX_1 1 +# define pTHX_2 2 +# define pTHX_3 3 +# define pTHX_4 4 +#endif -#include "embed.h" +#ifndef pTHXo +# define pTHXo pTHX +# define pTHXo_ pTHX_ +# define aTHXo aTHX +# define aTHXo_ aTHX_ +# define dTHXo dTHX +#endif + +#ifndef pTHXx +# define pTHXx register PerlInterpreter *my_perl +# define pTHXx_ pTHXx, +# define aTHXx my_perl +# define aTHXx_ aTHXx, +# define dTHXx dTHX +#endif #undef START_EXTERN_C #undef END_EXTERN_C @@ -148,18 +263,14 @@ class CPerlObj; #else # define START_EXTERN_C # define END_EXTERN_C -# define EXTERN_C +# define EXTERN_C extern #endif #ifdef OP_IN_REGISTER # ifdef __GNUC__ # define stringify_immed(s) #s # define stringify(s) stringify_immed(s) -#ifdef EMBED register struct op *Perl_op asm(stringify(OP_IN_REGISTER)); -#else -register struct op *op asm(stringify(OP_IN_REGISTER)); -#endif # endif #endif @@ -186,8 +297,7 @@ register struct op *op asm(stringify(OP_IN_REGISTER)); # endif #endif -#define NOOP (void)0 - +#define WITH_THX(s) STMT_START { dTHX; s; } STMT_END #define WITH_THR(s) STMT_START { dTHR; s; } STMT_END /* @@ -228,11 +338,11 @@ register struct op *op asm(stringify(OP_IN_REGISTER)); #define DOSISH 1 #endif -#if defined(__STDC__) || defined(vax11c) || defined(_AIX) || defined(__stdc__) || defined(__cplusplus) +#if defined(__STDC__) || defined(vax11c) || defined(_AIX) || defined(__stdc__) || defined(__cplusplus) || defined( EPOC) # define STANDARD_C 1 #endif -#if defined(__cplusplus) || defined(WIN32) || defined(__sgi) || defined(OS2) || defined(__DGUX) +#if defined(__cplusplus) || defined(WIN32) || defined(__sgi) || defined(OS2) || defined(__DGUX) || defined( EPOC) || defined(__QNX__) # define DONT_DECLARE_STD 1 #endif @@ -302,6 +412,14 @@ register struct op *op asm(stringify(OP_IN_REGISTER)); # endif #endif +/* HP-UX 10.X CMA (Common Multithreaded Architecure) insists that + pthread.h must be included before all other header files. +*/ +#if (defined(USE_THREADS) || defined(USE_ITHREADS)) \ + && defined(PTHREAD_H_FIRST) && defined(I_PTHREAD) +# include <pthread.h> +#endif + #ifndef _TYPES_ /* If types.h defines this it's easy. */ # ifndef major /* Does everyone's types.h define this? */ # include <sys/types.h> @@ -322,15 +440,17 @@ register struct op *op asm(stringify(OP_IN_REGISTER)); # endif #endif -#include "iperlsys.h" - #ifdef USE_NEXT_CTYPE -#if NX_CURRENT_COMPILER_RELEASE >= 400 -#include <objc/NXCType.h> -#else /* NX_CURRENT_COMPILER_RELEASE < 400 */ -#include <appkit/NXCType.h> -#endif /* NX_CURRENT_COMPILER_RELEASE >= 400 */ +#if NX_CURRENT_COMPILER_RELEASE >= 500 +# include <bsd/ctypes.h> +#else +# if NX_CURRENT_COMPILER_RELEASE >= 400 +# include <objc/NXCType.h> +# else /* NX_CURRENT_COMPILER_RELEASE < 400 */ +# include <appkit/NXCType.h> +# endif /* NX_CURRENT_COMPILER_RELEASE >= 400 */ +#endif /* NX_CURRENT_COMPILER_RELEASE >= 500 */ #else /* !USE_NEXT_CTYPE */ #include <ctype.h> @@ -382,54 +502,15 @@ register struct op *op asm(stringify(OP_IN_REGISTER)); # include <stdlib.h> #endif -#define MEM_SIZE Size_t - -/* This comes after <stdlib.h> so we don't try to change the standard - * library prototypes; we'll use our own in proto.h instead. */ - -#ifdef MYMALLOC - -# ifdef HIDEMYMALLOC -# define malloc Mymalloc -# define calloc Mycalloc -# define realloc Myrealloc -# define free Myfree -Malloc_t Mymalloc _((MEM_SIZE nbytes)); -Malloc_t Mycalloc _((MEM_SIZE elements, MEM_SIZE size)); -Malloc_t Myrealloc _((Malloc_t where, MEM_SIZE nbytes)); -Free_t Myfree _((Malloc_t where)); -# endif -# ifdef EMBEDMYMALLOC -# define malloc Perl_malloc -# define calloc Perl_calloc -# define realloc Perl_realloc -/* VMS' external symbols are case-insensitive, and there's already a */ -/* perl_free in perl.h */ -#ifdef VMS -# define free Perl_myfree -#else -# define free Perl_free +#ifdef PERL_MICRO /* Last chance to export Perl_my_swap */ +# define MYSWAP #endif -Malloc_t Perl_malloc _((MEM_SIZE nbytes)); -Malloc_t Perl_calloc _((MEM_SIZE elements, MEM_SIZE size)); -Malloc_t Perl_realloc _((Malloc_t where, MEM_SIZE nbytes)); -#ifdef VMS -Free_t Perl_myfree _((Malloc_t where)); -#else -Free_t Perl_free _((Malloc_t where)); -#endif -# endif -# undef safemalloc -# undef safecalloc -# undef saferealloc -# undef safefree -# define safemalloc malloc -# define safecalloc calloc -# define saferealloc realloc -# define safefree free +#if !defined(PERL_FOR_X2P) && !defined(WIN32) +# include "embed.h" +#endif -#endif /* MYMALLOC */ +#define MEM_SIZE Size_t #if defined(STANDARD_C) && defined(I_STDDEF) # include <stddef.h> @@ -444,6 +525,51 @@ Free_t Perl_free _((Malloc_t where)); # include <strings.h> #endif +/* This comes after <stdlib.h> so we don't try to change the standard + * library prototypes; we'll use our own in proto.h instead. */ + +#ifdef MYMALLOC +# ifdef PERL_POLLUTE_MALLOC +# ifndef PERL_EXTMALLOC_DEF +# define Perl_malloc malloc +# define Perl_calloc calloc +# define Perl_realloc realloc +# define Perl_mfree free +# endif +# else +# define EMBEDMYMALLOC /* for compatibility */ +# endif +Malloc_t Perl_malloc (MEM_SIZE nbytes); +Malloc_t Perl_calloc (MEM_SIZE elements, MEM_SIZE size); +Malloc_t Perl_realloc (Malloc_t where, MEM_SIZE nbytes); +/* 'mfree' rather than 'free', since there is already a 'perl_free' + * that causes clashes with case-insensitive linkers */ +Free_t Perl_mfree (Malloc_t where); + +typedef struct perl_mstats perl_mstats_t; + +struct perl_mstats { + unsigned long *nfree; + unsigned long *ntotal; + long topbucket, topbucket_ev, topbucket_odd, totfree, total, total_chain; + long total_sbrk, sbrks, sbrk_good, sbrk_slack, start_slack, sbrked_remains; + long minbucket; + /* Level 1 info */ + unsigned long *bucket_mem_size; + unsigned long *bucket_available_size; +}; + +# define safemalloc Perl_malloc +# define safecalloc Perl_calloc +# define saferealloc Perl_realloc +# define safefree Perl_mfree +#else /* MYMALLOC */ +# define safemalloc safesysmalloc +# define safecalloc safesyscalloc +# define saferealloc safesysrealloc +# define safefree safesysfree +#endif /* MYMALLOC */ + #if !defined(HAS_STRCHR) && defined(HAS_INDEX) && !defined(strchr) #define strchr index #define strrchr rindex @@ -456,7 +582,7 @@ Free_t Perl_free _((Malloc_t where)); #ifdef HAS_MEMCPY # if !defined(STANDARD_C) && !defined(I_STRING) && !defined(I_MEMORY) # ifndef memcpy - extern char * memcpy _((char*, char*, int)); + extern char * memcpy (char*, char*, int); # endif # endif #else @@ -472,7 +598,7 @@ Free_t Perl_free _((Malloc_t where)); #ifdef HAS_MEMSET # if !defined(STANDARD_C) && !defined(I_STRING) && !defined(I_MEMORY) # ifndef memset - extern char *memset _((char*, int, int)); + extern char *memset (char*, int, int); # endif # endif #else @@ -498,7 +624,7 @@ Free_t Perl_free _((Malloc_t where)); #if defined(HAS_MEMCMP) && defined(HAS_SANE_MEMCMP) # if !defined(STANDARD_C) && !defined(I_STRING) && !defined(I_MEMORY) # ifndef memcmp - extern int memcmp _((char*, char*, int)); + extern int memcmp (char*, char*, int); # endif # endif # ifdef BUGGY_MSC @@ -522,6 +648,12 @@ Free_t Perl_free _((Malloc_t where)); # endif #endif +#ifndef memchr +# ifndef HAS_MEMCHR +# define memchr(s,c,n) ninstr((char*)(s), ((char*)(s)) + n, &(c), &(c) + 1) +# endif +#endif + #ifndef HAS_BCMP # ifndef bcmp # define bcmp(s1,s2,l) memcmp(s1,s2,l) @@ -605,26 +737,30 @@ Free_t Perl_free _((Malloc_t where)); #ifdef USE_THREADS # define ERRSV (thr->errsv) -# define ERRHV (thr->errhv) # define DEFSV THREADSV(0) # define SAVE_DEFSV save_threadsv(0) #else # define ERRSV GvSV(PL_errgv) -# define ERRHV GvHV(PL_errgv) # define DEFSV GvSV(PL_defgv) # define SAVE_DEFSV SAVESPTR(GvSV(PL_defgv)) #endif /* USE_THREADS */ +#define ERRHV GvHV(PL_errgv) /* XXX unused, here for compatibility */ + #ifndef errno - extern int errno; /* ANSI allows errno to be an lvalue expr */ + extern int errno; /* ANSI allows errno to be an lvalue expr. + * For example in multithreaded environments + * something like this might happen: + * extern int *_errno(void); + * #define errno (*_errno()) */ #endif #ifdef HAS_STRERROR # ifdef VMS - char *strerror _((int,...)); + char *strerror (int,...); # else #ifndef DONT_DECLARE_STD - char *strerror _((int)); + char *strerror (int); #endif # endif # ifndef Strerror @@ -667,7 +803,8 @@ Free_t Perl_free _((Malloc_t where)); /* Configure already sets Direntry_t */ #if defined(I_DIRENT) # include <dirent.h> -# if defined(NeXT) && defined(I_SYS_DIR) /* NeXT needs dirent + sys/dir.h */ + /* NeXT needs dirent + sys/dir.h */ +# if defined(I_SYS_DIR) && (defined(NeXT) || defined(__NeXT__)) # include <sys/dir.h> # endif #else @@ -697,6 +834,10 @@ Free_t Perl_free _((Malloc_t where)); * in the face of half-implementations.) */ +#ifdef I_SYSMODE +#include <sys/mode.h> +#endif + #ifndef S_IFMT # ifdef _S_IFMT # define S_IFMT _S_IFMT @@ -775,12 +916,30 @@ Free_t Perl_free _((Malloc_t where)); # define S_IWUSR 0200 # define S_IXUSR 0100 # endif -# define S_IRGRP (S_IRUSR>>3) -# define S_IWGRP (S_IWUSR>>3) -# define S_IXGRP (S_IXUSR>>3) -# define S_IROTH (S_IRUSR>>6) -# define S_IWOTH (S_IWUSR>>6) -# define S_IXOTH (S_IXUSR>>6) +#endif + +#ifndef S_IRGRP +# ifdef S_IRUSR +# define S_IRGRP (S_IRUSR>>3) +# define S_IWGRP (S_IWUSR>>3) +# define S_IXGRP (S_IXUSR>>3) +# else +# define S_IRGRP 0040 +# define S_IWGRP 0020 +# define S_IXGRP 0010 +# endif +#endif + +#ifndef S_IROTH +# ifdef S_IRUSR +# define S_IROTH (S_IRUSR>>6) +# define S_IWOTH (S_IWUSR>>6) +# define S_IXOTH (S_IXUSR>>6) +# else +# define S_IROTH 0040 +# define S_IWOTH 0020 +# define S_IXOTH 0010 +# endif #endif #ifndef S_ISUID @@ -791,6 +950,30 @@ Free_t Perl_free _((Malloc_t where)); # define S_ISGID 02000 #endif +#ifndef S_IRWXU +# define S_IRWXU (S_IRUSR|S_IWUSR|S_IXUSR) +#endif + +#ifndef S_IRWXG +# define S_IRWXG (S_IRGRP|S_IWGRP|S_IXGRP) +#endif + +#ifndef S_IRWXO +# define S_IRWXO (S_IROTH|S_IWOTH|S_IXOTH) +#endif + +#ifndef S_IREAD +# define S_IREAD S_IRUSR +#endif + +#ifndef S_IWRITE +# define S_IWRITE S_IWUSR +#endif + +#ifndef S_IEXEC +# define S_IEXEC S_IXUSR +#endif + #ifdef ff_next # undef ff_next #endif @@ -803,55 +986,219 @@ Free_t Perl_free _((Malloc_t where)); #undef UV #endif -/* XXX QUAD stuff is not currently supported on most systems. - Specifically, perl internals don't support long long. Among - the many problems is that some compilers support long long, - but the underlying library functions (such as sprintf) don't. - Some things do work (such as quad pack/unpack on convex); - also some systems use long long for the fpos_t typedef. That - seems to work too. - +/* The IV type is supposed to be long enough to hold any integral value or a pointer. --Andy Dougherty August 1996 */ -#ifdef cray -# define Quad_t int +typedef IVTYPE IV; +typedef UVTYPE UV; + +#if defined(USE_64_BIT_INT) && defined(HAS_QUAD) +# if QUADKIND == QUAD_IS_INT64_T && defined(INT64_MAX) +# define IV_MAX INT64_MAX +# define IV_MIN INT64_MIN +# define UV_MAX UINT64_MAX +# ifndef UINT64_MIN +# define UINT64_MIN 0 +# endif +# define UV_MIN UINT64_MIN +# else +# define IV_MAX PERL_QUAD_MAX +# define IV_MIN PERL_QUAD_MIN +# define UV_MAX PERL_UQUAD_MAX +# define UV_MIN PERL_UQUAD_MIN +# endif +# define IV_IS_QUAD +# define UV_IS_QUAD #else -# ifdef convex -# define Quad_t long long -# else -# if LONGSIZE == 8 -# define Quad_t long -# endif -# endif +# if defined(INT32_MAX) && IVSIZE == 4 +# define IV_MAX INT32_MAX +# define IV_MIN INT32_MIN +# ifndef UINT32_MAX_BROKEN /* e.g. HP-UX with gcc messes this up */ +# define UV_MAX UINT32_MAX +# else +# define UV_MAX 4294967295U +# endif +# ifndef UINT32_MIN +# define UINT32_MIN 0 +# endif +# define UV_MIN UINT32_MIN +# else +# define IV_MAX PERL_LONG_MAX +# define IV_MIN PERL_LONG_MIN +# define UV_MAX PERL_ULONG_MAX +# define UV_MIN PERL_ULONG_MIN +# endif +# if IVSIZE == 8 +# define IV_IS_QUAD +# define UV_IS_QUAD +# ifndef HAS_QUAD +# define HAS_QUAD +# endif +# else +# undef IV_IS_QUAD +# undef UV_IS_QUAD +# undef HAS_QUAD +# endif #endif -/* XXX Experimental set-up for long long. Just add -DUSE_LONG_LONG - to your ccflags. --Andy Dougherty 4/1998 +#define IV_DIG (BIT_DIGITS(IVSIZE * 8)) +#define UV_DIG (BIT_DIGITS(UVSIZE * 8)) + +/* + * The macros INT2PTR and NUM2PTR are (despite their names) + * bi-directional: they will convert int/float to or from pointers. + * However the conversion to int/float are named explicitly: + * PTR2IV, PTR2UV, PTR2NV. + * + * For int conversions we do not need two casts if pointers are + * the same size as IV and UV. Otherwise we need an explicit + * cast (PTRV) to avoid compiler warnings. + */ +#if (IVSIZE == PTRSIZE) && (UVSIZE == PTRSIZE) +# define PTRV UV +# define INT2PTR(any,d) (any)(d) +#else +# if PTRSIZE == LONGSIZE +# define PTRV unsigned long +# else +# define PTRV unsigned +# endif +# define INT2PTR(any,d) (any)(PTRV)(d) +#endif +#define NUM2PTR(any,d) (any)(PTRV)(d) +#define PTR2IV(p) INT2PTR(IV,p) +#define PTR2UV(p) INT2PTR(UV,p) +#define PTR2NV(p) NUM2PTR(NV,p) + +#ifdef USE_LONG_DOUBLE +# if !(defined(HAS_LONG_DOUBLE) && (LONG_DOUBLESIZE > DOUBLESIZE)) +# undef USE_LONG_DOUBLE /* Ouch! */ +# endif +#endif + +#ifdef OVR_DBL_DIG +/* Use an overridden DBL_DIG */ +# ifdef DBL_DIG +# undef DBL_DIG +# endif +# define DBL_DIG OVR_DBL_DIG +#else +/* The following is all to get DBL_DIG, in order to pick a nice + default value for printing floating point numbers in Gconvert. + (see config.h) */ -#ifdef USE_LONG_LONG -# if defined(HAS_LONG_LONG) && LONGLONGSIZE == 8 -# define Quad_t long long +#ifdef I_LIMITS +#include <limits.h> +#endif +#ifdef I_FLOAT +#include <float.h> +#endif +#ifndef HAS_DBL_DIG +#define DBL_DIG 15 /* A guess that works lots of places */ +#endif +#endif +#ifdef I_FLOAT +#include <float.h> +#endif +#ifndef HAS_DBL_DIG +#define DBL_DIG 15 /* A guess that works lots of places */ +#endif + +#ifdef OVR_LDBL_DIG +/* Use an overridden LDBL_DIG */ +# ifdef LDBL_DIG +# undef LDBL_DIG +# endif +# define LDBL_DIG OVR_LDBL_DIG +#else +/* The following is all to get LDBL_DIG, in order to pick a nice + default value for printing floating point numbers in Gconvert. + (see config.h) +*/ +# ifdef I_LIMITS +# include <limits.h> +# endif +# ifdef I_FLOAT +# include <float.h> +# endif +# ifndef HAS_LDBL_DIG +# if LONG_DOUBLESIZE == 10 +# define LDBL_DIG 18 /* assume IEEE */ +# else +# if LONG_DOUBLESIZE == 12 +# define LDBL_DIG 18 /* gcc? */ +# else +# if LONG_DOUBLESIZE == 16 +# define LDBL_DIG 33 /* assume IEEE */ +# else +# if LONG_DOUBLESIZE == DOUBLESIZE +# define LDBL_DIG DBL_DIG /* bummer */ +# endif +# endif +# endif # endif +# endif +#endif + +typedef NVTYPE NV; + +#ifdef I_IEEEFP +# include <ieeefp.h> #endif -#ifdef Quad_t -# define HAS_QUAD - typedef Quad_t IV; - typedef unsigned Quad_t UV; -# define IV_MAX PERL_QUAD_MAX -# define IV_MIN PERL_QUAD_MIN -# define UV_MAX PERL_UQUAD_MAX -# define UV_MIN PERL_UQUAD_MIN +#ifdef USE_LONG_DOUBLE +# ifdef I_SUNMATH +# include <sunmath.h> +# endif +# define NV_DIG LDBL_DIG +# ifdef HAS_SQRTL + /* libsunmath doesn't have modfl and frexpl as of mid-March 2000 */ + /* XXX Configure probe for modfl and frexpl needed XXX */ +# if defined(__sun) && defined(__svr4) +# define Perl_modf(x,y) ((long double)modf((double)(x),(double*)(y))) +# define Perl_frexp(x) ((long double)frexp((double)(x))) +# else +# define Perl_modf modfl +# define Perl_frexp frexpl +# endif +# define Perl_cos cosl +# define Perl_sin sinl +# define Perl_sqrt sqrtl +# define Perl_exp expl +# define Perl_log logl +# define Perl_atan2 atan2l +# define Perl_pow powl +# define Perl_floor floorl +# define Perl_fmod fmodl +# endif #else - typedef long IV; - typedef unsigned long UV; -# define IV_MAX PERL_LONG_MAX -# define IV_MIN PERL_LONG_MIN -# define UV_MAX PERL_ULONG_MAX -# define UV_MIN PERL_ULONG_MIN +# define NV_DIG DBL_DIG +# define Perl_modf modf +# define Perl_frexp frexp +# define Perl_cos cos +# define Perl_sin sin +# define Perl_sqrt sqrt +# define Perl_exp exp +# define Perl_log log +# define Perl_atan2 atan2 +# define Perl_pow pow +# define Perl_floor floor +# define Perl_fmod fmod +#endif + +#if !defined(Perl_atof) && defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE) +# if !defined(Perl_atof) && defined(HAS_STRTOLD) +# define Perl_atof(s) strtold(s, (char**)NULL) +# endif +# if !defined(Perl_atof) && defined(HAS_ATOLF) +# define Perl_atof atolf +# endif +#endif +#if !defined(Perl_atof) +# define Perl_atof atof /* we assume atof being available anywhere */ #endif /* Previously these definitions used hardcoded figures. @@ -1023,7 +1370,7 @@ Free_t Perl_free _((Malloc_t where)); # endif #endif -#ifdef HAS_QUAD +#ifdef UV_IS_QUAD # ifdef UQUAD_MAX # define PERL_UQUAD_MAX ((UV)UQUAD_MAX) @@ -1055,18 +1402,13 @@ typedef struct unop UNOP; typedef struct binop BINOP; typedef struct listop LISTOP; typedef struct logop LOGOP; -typedef struct condop CONDOP; typedef struct pmop PMOP; typedef struct svop SVOP; -typedef struct gvop GVOP; +typedef struct padop PADOP; typedef struct pvop PVOP; typedef struct loop LOOP; -typedef struct Outrec Outrec; typedef struct interpreter PerlInterpreter; -#ifndef __BORLANDC__ -typedef struct ff FF; /* XXX not defined anywhere, should go? */ -#endif typedef struct sv SV; typedef struct av AV; typedef struct hv HV; @@ -1095,18 +1437,118 @@ typedef struct xpvfm XPVFM; typedef struct xpvio XPVIO; typedef struct mgvtbl MGVTBL; typedef union any ANY; +typedef struct ptr_tbl_ent PTR_TBL_ENT_t; +typedef struct ptr_tbl PTR_TBL_t; #include "handy.h" -#ifdef PERL_OBJECT -typedef I32 (*filter_t) _((CPerlObj*, int, SV *, int)); -#else -typedef I32 (*filter_t) _((int, SV *, int)); +#if defined(USE_LARGE_FILES) && !defined(NO_64_BIT_RAWIO) +# if LSEEKSIZE == 8 && !defined(USE_64_BIT_RAWIO) +# define USE_64_BIT_RAWIO /* implicit */ +# endif #endif -#define FILTER_READ(idx, sv, len) filter_read(idx, sv, len) -#define FILTER_DATA(idx) (AvARRAY(PL_rsfp_filters)[idx]) -#define FILTER_ISREADER(idx) (idx >= AvFILLp(PL_rsfp_filters)) +/* Notice the use of HAS_FSEEKO: now we are obligated to always use + * fseeko/ftello if possible. Don't go #defining ftell to ftello yourself, + * however, because operating systems like to do that themself. */ +#ifndef FSEEKSIZE +# ifdef HAS_FSEEKO +# define FSEEKSIZE LSEEKSIZE +# else +# define FSEEKSIZE LONGSIZE +# endif +#endif + +#if defined(USE_LARGE_FILES) && !defined(NO_64_BIT_STDIO) +# if FSEEKSIZE == 8 && !defined(USE_64_BIT_STDIO) +# define USE_64_BIT_STDIO /* implicit */ +# endif +#endif + +#ifdef USE_64_BIT_RAWIO +# ifdef HAS_OFF64_T +# undef Off_t +# define Off_t off64_t +# undef LSEEKSIZE +# define LSEEKSIZE 8 +# endif +/* Most 64-bit environments have defines like _LARGEFILE_SOURCE that + * will trigger defines like the ones below. Some 64-bit environments, + * however, do not. Therefore we have to explicitly mix and match. */ +# if defined(USE_OPEN64) +# define open open64 +# endif +# if defined(USE_LSEEK64) +# define lseek lseek64 +# else +# if defined(USE_LLSEEK) +# define lseek llseek +# endif +# endif +# if defined(USE_STAT64) +# define stat stat64 +# endif +# if defined(USE_FSTAT64) +# define fstat fstat64 +# endif +# if defined(USE_LSTAT64) +# define lstat lstat64 +# endif +# if defined(USE_FLOCK64) +# define flock flock64 +# endif +# if defined(USE_LOCKF64) +# define lockf lockf64 +# endif +# if defined(USE_FCNTL64) +# define fcntl fcntl64 +# endif +# if defined(USE_TRUNCATE64) +# define truncate truncate64 +# endif +# if defined(USE_FTRUNCATE64) +# define ftruncate ftruncate64 +# endif +#endif + +#ifdef USE_64_BIT_STDIO +# ifdef HAS_FPOS64_T +# undef Fpos_t +# define Fpos_t fpos64_t +# endif +/* Most 64-bit environments have defines like _LARGEFILE_SOURCE that + * will trigger defines like the ones below. Some 64-bit environments, + * however, do not. */ +# if defined(USE_FOPEN64) +# define fopen fopen64 +# endif +# if defined(USE_FSEEK64) +# define fseek fseek64 /* don't do fseeko here, see perlio.c */ +# endif +# if defined(USE_FTELL64) +# define ftell ftell64 /* don't do ftello here, see perlio.c */ +# endif +# if defined(USE_FSETPOS64) +# define fsetpos fsetpos64 +# endif +# if defined(USE_FGETPOS64) +# define fgetpos fgetpos64 +# endif +# if defined(USE_TMPFILE64) +# define tmpfile tmpfile64 +# endif +# if defined(USE_FREOPEN64) +# define freopen freopen64 +# endif +#endif + +#if defined(OS2) +# include "iperlsys.h" +#endif + +#if defined(__OPEN_VM) +# include "vmesa/vmesaish.h" +#endif #ifdef DOSISH # if defined(OS2) @@ -1127,15 +1569,45 @@ typedef I32 (*filter_t) _((int, SV *, int)); # if defined(__VOS__) # include "vosish.h" # else -# include "unixish.h" +# if defined(EPOC) +# include "epocish.h" +# else +# if defined(MACOS_TRADITIONAL) +# include "macos/macish.h" +# else +# include "unixish.h" +# endif +# endif # endif # endif # endif # endif #endif -#ifndef FUNC_NAME_TO_PTR -#define FUNC_NAME_TO_PTR(name) name +#ifndef PERL_SYS_INIT3 +# define PERL_SYS_INIT3(argvp,argcp,envp) PERL_SYS_INIT(argvp,argcp) +#endif + +#ifndef MAXPATHLEN +# ifdef PATH_MAX +# ifdef _POSIX_PATH_MAX +# if PATH_MAX > _POSIX_PATH_MAX +/* MAXPATHLEN is supposed to include the final null character, + * as opposed to PATH_MAX and _POSIX_PATH_MAX. */ +# define MAXPATHLEN (PATH_MAX+1) +# else +# define MAXPATHLEN (_POSIX_PATH_MAX+1) +# endif +# else +# define MAXPATHLEN (PATH_MAX+1) +# endif +# else +# ifdef _POSIX_PATH_MAX +# define MAXPATHLEN (_POSIX_PATH_MAX+1) +# else +# define MAXPATHLEN 1024 /* Err on the large side. */ +# endif +# endif #endif /* @@ -1145,11 +1617,12 @@ typedef I32 (*filter_t) _((int, SV *, int)); * May make sense to have threads after "*ish.h" anyway */ -#ifdef USE_THREADS +#if defined(USE_THREADS) || defined(USE_ITHREADS) +# if defined(USE_THREADS) /* pending resolution of licensing issues, we avoid the erstwhile * atomic.h everywhere */ # define EMULATE_ATOMIC_REFCOUNTS - +# endif # ifdef FAKE_THREADS # include "fakethr.h" # else @@ -1161,7 +1634,7 @@ typedef I32 (*filter_t) _((int, SV *, int)); # else # ifdef I_MACH_CTHREADS # include <mach/cthreads.h> -# ifdef NeXT +# if (defined(NeXT) || defined(__NeXT__)) && defined(PERL_POLLUTE_MALLOC) # define MUTEX_INIT_CALLS_MALLOC # endif typedef cthread_t perl_os_thread; @@ -1169,7 +1642,9 @@ typedef mutex_t perl_mutex; typedef condition_t perl_cond; typedef void * perl_key; # else /* Posix threads */ -# include <pthread.h> +# ifdef I_PTHREAD +# include <pthread.h> +# endif typedef pthread_t perl_os_thread; typedef pthread_mutex_t perl_mutex; typedef pthread_cond_t perl_cond; @@ -1178,14 +1653,16 @@ typedef pthread_key_t perl_key; # endif /* OS2 */ # endif /* WIN32 */ # endif /* FAKE_THREADS */ -#endif /* USE_THREADS */ +#endif /* USE_THREADS || USE_ITHREADS */ +#ifdef WIN32 +# include "win32.h" +#endif - #ifdef VMS # define STATUS_NATIVE PL_statusvalue_vms # define STATUS_NATIVE_EXPORT \ - ((I32)PL_statusvalue_vms == -1 ? 44 : PL_statusvalue_vms) + (((I32)PL_statusvalue_vms == -1 ? 44 : PL_statusvalue_vms) | (VMSISH_HUSHED ? 0x10000000 : 0)) # define STATUS_NATIVE_SET(n) \ STMT_START { \ PL_statusvalue_vms = (n); \ @@ -1231,6 +1708,70 @@ typedef pthread_key_t perl_key; # define STATUS_ALL_FAILURE (PL_statusvalue = 1) #endif +/* flags in PL_exit_flags for nature of exit() */ +#define PERL_EXIT_EXPECTED 0x01 + +#ifndef MEMBER_TO_FPTR +# define MEMBER_TO_FPTR(name) name +#endif + +/* format to use for version numbers in file/directory names */ +/* XXX move to Configure? */ +#ifndef PERL_FS_VER_FMT +# define PERL_FS_VER_FMT "%d.%d.%d" +#endif + +/* This defines a way to flush all output buffers. This may be a + * performance issue, so we allow people to disable it. + */ +#ifndef PERL_FLUSHALL_FOR_CHILD +# if defined(FFLUSH_NULL) || defined(USE_SFIO) +# define PERL_FLUSHALL_FOR_CHILD PerlIO_flush((PerlIO*)NULL) +# else +# ifdef FFLUSH_ALL +# define PERL_FLUSHALL_FOR_CHILD my_fflush_all() +# else +# define PERL_FLUSHALL_FOR_CHILD NOOP +# endif +# endif +#endif + +#ifndef PERL_WAIT_FOR_CHILDREN +# define PERL_WAIT_FOR_CHILDREN NOOP +#endif + +/* the traditional thread-unsafe notion of "current interpreter". */ +#ifndef PERL_SET_INTERP +# define PERL_SET_INTERP(i) (PL_curinterp = (PerlInterpreter*)(i)) +#endif + +#ifndef PERL_GET_INTERP +# define PERL_GET_INTERP (PL_curinterp) +#endif + +#if defined(PERL_IMPLICIT_CONTEXT) && !defined(PERL_GET_THX) +# ifdef USE_THREADS +# define PERL_GET_THX ((struct perl_thread *)PERL_GET_CONTEXT) +# else +# ifdef MULTIPLICITY +# define PERL_GET_THX ((PerlInterpreter *)PERL_GET_CONTEXT) +# else +# ifdef PERL_OBJECT +# define PERL_GET_THX ((CPerlObj *)PERL_GET_CONTEXT) +# endif +# endif +# endif +# define PERL_SET_THX(t) PERL_SET_CONTEXT(t) +#endif + +#ifndef SVf +# ifdef CHECK_FORMAT +# define SVf "p" +# else +# define SVf "_" +# endif +#endif + /* Some unistd.h's give a prototype for pause() even though HAS_PAUSE ends up undefined. This causes the #define below to be rejected by the compmiler. Sigh. @@ -1251,6 +1792,18 @@ typedef pthread_key_t perl_key; # endif #endif +#if defined(__CYGWIN__) +/* USEMYBINMODE + * This symbol, if defined, indicates that the program should + * use the routine my_binmode(FILE *fp, char iotype, int mode) to insure + * that a file is in "binary" mode -- that is, that no translation + * of bytes occurs on read or write operations. + */ +# define USEMYBINMODE / **/ +# define my_binmode(fp, iotype, mode) \ + (PerlLIO_setmode(PerlIO_fileno(fp), mode) != -1 ? TRUE : FALSE) +#endif + #ifdef UNION_ANY_DEFINITION UNION_ANY_DEFINITION; #else @@ -1259,36 +1812,41 @@ union any { I32 any_i32; IV any_iv; long any_long; - void (CPERLscope(*any_dptr)) _((void*)); + void (*any_dptr) (void*); + void (*any_dxptr) (pTHXo_ void*); }; #endif #ifdef USE_THREADS #define ARGSproto struct perl_thread *thr #else -#define ARGSproto void +#define ARGSproto #endif /* USE_THREADS */ -/* Work around some cygwin32 problems with importing global symbols */ -#if defined(CYGWIN32) && defined(DLLIMPORT) -# include "cw32imp.h" -#endif +typedef I32 (*filter_t) (pTHXo_ int, SV *, int); +#define FILTER_READ(idx, sv, len) filter_read(idx, sv, len) +#define FILTER_DATA(idx) (AvARRAY(PL_rsfp_filters)[idx]) +#define FILTER_ISREADER(idx) (idx >= AvFILLp(PL_rsfp_filters)) + +#if !defined(OS2) +# include "iperlsys.h" +#endif #include "regexp.h" #include "sv.h" #include "util.h" #include "form.h" #include "gv.h" #include "cv.h" -#include "opcode.h" +#include "opnames.h" #include "op.h" #include "cop.h" #include "av.h" #include "hv.h" #include "mg.h" #include "scope.h" -#include "bytecode.h" -#include "byterun.h" +#include "warnings.h" +#include "utf8.h" /* Current curly descriptor */ typedef struct curcur CURCUR; @@ -1309,40 +1867,28 @@ struct _sublex_info { I32 super_state; /* lexer state to save */ I32 sub_inwhat; /* "lex_inwhat" to use */ OP *sub_op; /* "lex_op" to use */ + char *super_bufptr; /* PL_bufptr that was */ + char *super_bufend; /* PL_bufend that was */ }; -#ifdef PERL_OBJECT -struct magic_state { - SV* mgs_sv; - U32 mgs_flags; -}; -typedef struct magic_state MGS; - -typedef struct { - I32 len_min; - I32 len_delta; - I32 pos_min; - I32 pos_delta; - SV *last_found; - I32 last_end; /* min value, <0 unless valid. */ - I32 last_start_min; - I32 last_start_max; - SV **longest; /* Either &l_fixed, or &l_float. */ - SV *longest_fixed; - I32 offset_fixed; - SV *longest_float; - I32 offset_float_min; - I32 offset_float_max; - I32 flags; -} scan_data_t; +typedef struct magic_state MGS; /* struct magic_state defined in mg.c */ + +struct scan_data_t; /* Used in S_* functions in regcomp.c */ +struct regnode_charclass_class; /* Used in S_* functions in regcomp.c */ typedef I32 CHECKPOINT; -#endif /* PERL_OBJECT */ -/* work around some libPW problems */ -#ifdef DOINIT -EXT char Error[1]; -#endif +struct ptr_tbl_ent { + struct ptr_tbl_ent* next; + void* oldval; + void* newval; +}; + +struct ptr_tbl { + struct ptr_tbl_ent** tbl_ary; + UV tbl_max; + UV tbl_items; +}; #if defined(iAPX286) || defined(M_I286) || defined(I80286) # define I286 @@ -1407,10 +1953,9 @@ EXT char Error[1]; #define U_I(what) ((unsigned int)(what)) #define U_L(what) ((U32)(what)) #else -EXTERN_C U32 cast_ulong _((double)); -#define U_S(what) ((U16)cast_ulong((double)(what))) -#define U_I(what) ((unsigned int)cast_ulong((double)(what))) -#define U_L(what) (cast_ulong((double)(what))) +#define U_S(what) ((U16)cast_ulong((NV)(what))) +#define U_I(what) ((unsigned int)cast_ulong((NV)(what))) +#define U_L(what) (cast_ulong((NV)(what))) #endif #ifdef CASTI32 @@ -1418,41 +1963,43 @@ EXTERN_C U32 cast_ulong _((double)); #define I_V(what) ((IV)(what)) #define U_V(what) ((UV)(what)) #else -START_EXTERN_C -I32 cast_i32 _((double)); -IV cast_iv _((double)); -UV cast_uv _((double)); -END_EXTERN_C -#define I_32(what) (cast_i32((double)(what))) -#define I_V(what) (cast_iv((double)(what))) -#define U_V(what) (cast_uv((double)(what))) +#define I_32(what) (cast_i32((NV)(what))) +#define I_V(what) (cast_iv((NV)(what))) +#define U_V(what) (cast_uv((NV)(what))) #endif -struct Outrec { - I32 o_lines; - char *o_str; - U32 o_len; -}; +/* These do not care about the fractional part, only about the range. */ +#define NV_WITHIN_IV(nv) (I_V(nv) >= IV_MIN && I_V(nv) <= IV_MAX) +#define NV_WITHIN_UV(nv) ((nv)>=0.0 && U_V(nv) >= UV_MIN && U_V(nv) <= UV_MAX) + +/* Used with UV/IV arguments: */ + /* XXXX: need to speed it up */ +#define CLUMP_2UV(iv) ((iv) < 0 ? 0 : (UV)(iv)) +#define CLUMP_2IV(uv) ((uv) > (UV)IV_MAX ? IV_MAX : (IV)(uv)) #ifndef MAXSYSFD # define MAXSYSFD 2 #endif -#ifndef TMPPATH -# define TMPPATH "/tmp/perl-eXXXXXX" -#endif - #ifndef __cplusplus -Uid_t getuid _((void)); -Uid_t geteuid _((void)); -Gid_t getgid _((void)); -Gid_t getegid _((void)); +Uid_t getuid (void); +Uid_t geteuid (void); +Gid_t getgid (void); +Gid_t getegid (void); #endif -#ifdef DEBUGGING #ifndef Perl_debug_log -#define Perl_debug_log PerlIO_stderr() +# define Perl_debug_log PerlIO_stderr() #endif + +#ifndef Perl_error_log +# define Perl_error_log (PL_stderrgv \ + && IoOFP(GvIOp(PL_stderrgv)) \ + ? IoOFP(GvIOp(PL_stderrgv)) \ + : PerlIO_stderr()) +#endif + +#ifdef DEBUGGING #undef YYDEBUG #define YYDEBUG 1 #define DEB(a) a @@ -1464,7 +2011,14 @@ Gid_t getegid _((void)); #define DEBUG_o(a) if (PL_debug & 16) a #define DEBUG_c(a) if (PL_debug & 32) a #define DEBUG_P(a) if (PL_debug & 64) a -#define DEBUG_m(a) if (PL_curinterp && PL_debug & 128) a +# if defined(PERL_OBJECT) +# define DEBUG_m(a) if (PL_debug & 128) a +# else +# define DEBUG_m(a) \ + STMT_START { \ + if (PERL_GET_INTERP) { dTHX; if (PL_debug & 128) { a; } } \ + } STMT_END +# endif #define DEBUG_f(a) if (PL_debug & 256) a #define DEBUG_r(a) if (PL_debug & 512) a #define DEBUG_x(a) if (PL_debug & 1024) a @@ -1504,29 +2058,31 @@ Gid_t getegid _((void)); #ifndef assert /* <assert.h> might have been included somehow */ #define assert(what) DEB( { \ if (!(what)) { \ - croak("Assertion failed: file \"%s\", line %d", \ + Perl_croak(aTHX_ "Assertion failed: file \"%s\", line %d", \ __FILE__, __LINE__); \ - PerlProc_exit(1); \ + PerlProc_exit(1); \ }}) #endif struct ufuncs { - I32 (*uf_val)_((IV, SV*)); - I32 (*uf_set)_((IV, SV*)); + I32 (*uf_val)(IV, SV*); + I32 (*uf_set)(IV, SV*); IV uf_index; }; /* Fix these up for __STDC__ */ #ifndef DONT_DECLARE_STD -char *mktemp _((char*)); -double atof _((const char*)); +char *mktemp (char*); +#ifndef atof +double atof (const char*); +#endif #endif #ifndef STANDARD_C /* All of these are in stdlib.h or time.h for ANSI C */ Time_t time(); struct tm *gmtime(), *localtime(); -#ifdef OEMVS +#if defined(OEMVS) || defined(__OPEN_VM) char *(strchr)(), *(strrchr)(); char *(strcpy)(), *(strcat)(); #else @@ -1540,40 +2096,42 @@ char *strcpy(), *strcat(); # include <math.h> #else START_EXTERN_C - double exp _((double)); - double log _((double)); - double log10 _((double)); - double sqrt _((double)); - double frexp _((double,int*)); - double ldexp _((double,int)); - double modf _((double,double*)); - double sin _((double)); - double cos _((double)); - double atan2 _((double,double)); - double pow _((double,double)); + double exp (double); + double log (double); + double log10 (double); + double sqrt (double); + double frexp (double,int*); + double ldexp (double,int); + double modf (double,double*); + double sin (double); + double cos (double); + double atan2 (double,double); + double pow (double,double); END_EXTERN_C #endif #ifndef __cplusplus -# ifdef __NeXT__ /* or whatever catches all NeXTs */ +# if defined(NeXT) || defined(__NeXT__) /* or whatever catches all NeXTs */ char *crypt (); /* Maybe more hosts will need the unprototyped version */ # else -# if !defined(WIN32) || !defined(HAVE_DES_FCRYPT) -char *crypt _((const char*, const char*)); -# endif /* !WIN32 && !HAVE_CRYPT_SOURCE */ -# endif /* !__NeXT__ */ +# if !defined(WIN32) +char *crypt (const char*, const char*); +# endif /* !WIN32 */ +# endif /* !NeXT && !__NeXT__ */ # ifndef DONT_DECLARE_STD # ifndef getenv -char *getenv _((const char*)); +char *getenv (const char*); # endif /* !getenv */ -Off_t lseek _((int,Off_t,int)); +# if !defined(EPOC) && !(defined(__hpux) && defined(_FILE_OFFSET_BITS) && _FILE_OFFSET_BITS == 64) && !defined(HAS_LSEEK_PROTO) +Off_t lseek (int,Off_t,int); +# endif # endif /* !DONT_DECLARE_STD */ -char *getlogin _((void)); +char *getlogin (void); #endif /* !__cplusplus */ #ifdef UNLINK_ALL_VERSIONS /* Currently only makes sense for VMS */ #define UNLINK unlnk -I32 unlnk _((char*)); +I32 unlnk (char*); #else #define UNLINK PerlLIO_unlink #endif @@ -1591,7 +2149,7 @@ I32 unlnk _((char*)); # endif #endif -typedef Signal_t (*Sighandler_t) _((int)); +/* Sighandler_t defined in iperlsys.h */ #ifdef HAS_SIGACTION typedef struct sigaction Sigsave_t; @@ -1608,10 +2166,10 @@ typedef Sighandler_t Sigsave_t; # define register # endif # define PAD_SV(po) pad_sv(po) -# define RUNOPS_DEFAULT runops_debug +# define RUNOPS_DEFAULT Perl_runops_debug #else # define PAD_SV(po) PL_curpad[po] -# define RUNOPS_DEFAULT runops_standard +# define RUNOPS_DEFAULT Perl_runops_standard #endif #ifdef MYMALLOC @@ -1637,10 +2195,8 @@ typedef Sighandler_t Sigsave_t; #endif -/* - * These need prototyping here because <proto.h> isn't - * included until after runops is initialised. - */ +typedef int (CPERLscope(*runops_proc_t)) (pTHX); +typedef OP* (CPERLscope(*PPADDR_t)[]) (pTHX); #ifndef PERL_OBJECT typedef int runops_proc_t _((void)); @@ -1653,79 +2209,84 @@ int runops_debug _((void)); /* _ (for $_) must be first in the following list (DEFSV requires it) */ #define THREADSV_NAMES "_123456789&`'+/.,\\\";^-%=|~:\001\005!@" -/* VMS doesn't use environ array and NeXT has problems with crt0.o globals */ -#if !defined(VMS) && !(defined(NeXT) && defined(__DYNAMIC__)) -#if !defined(DONT_DECLARE_STD) \ - || (defined(__svr4__) && defined(__GNUC__) && defined(sun)) \ - || defined(__sgi) || defined(__DGUX) -extern char ** environ; /* environment variables supplied via exec */ -#endif -#else -# if defined(NeXT) && defined(__DYNAMIC__) - -# include <mach-o/dyld.h> +/* NeXT has problems with crt0.o globals */ +#if defined(__DYNAMIC__) && \ + (defined(NeXT) || defined(__NeXT__) || defined(__APPLE__)) +# if defined(NeXT) || defined(__NeXT) +# include <mach-o/dyld.h> +# define environ (*environ_pointer) EXT char *** environ_pointer; -# define environ (*environ_pointer) +# else +# if defined(__APPLE__) +# include <crt_externs.h> /* for the env array */ +# define environ (*_NSGetEnviron()) +# endif # endif -#endif /* environ processing */ - +#else + /* VMS and some other platforms don't use the environ array */ +# if !defined(VMS) +# if !defined(DONT_DECLARE_STD) || \ + (defined(__svr4__) && defined(__GNUC__) && defined(sun)) || \ + defined(__sgi) || \ + defined(__DGUX) || defined(EPOC) +extern char ** environ; /* environment variables supplied via exec */ +# endif +# endif +#endif -/* for tmp use in stupid debuggers */ -EXT int * di; -EXT short * ds; -EXT char * dc; +START_EXTERN_C /* handy constants */ -EXTCONST char warn_uninit[] - INIT("Use of uninitialized value"); -EXTCONST char warn_nosemi[] +EXTCONST char PL_warn_uninit[] + INIT("Use of uninitialized value%s%s"); +EXTCONST char PL_warn_nosemi[] INIT("Semicolon seems to be missing"); -EXTCONST char warn_reserved[] +EXTCONST char PL_warn_reserved[] INIT("Unquoted string \"%s\" may clash with future reserved word"); -EXTCONST char warn_nl[] +EXTCONST char PL_warn_nl[] INIT("Unsuccessful %s on filename containing newline"); -EXTCONST char no_wrongref[] +EXTCONST char PL_no_wrongref[] INIT("Can't use %s ref as %s ref"); -EXTCONST char no_symref[] +EXTCONST char PL_no_symref[] INIT("Can't use string (\"%.32s\") as %s ref while \"strict refs\" in use"); -EXTCONST char no_usym[] +EXTCONST char PL_no_usym[] INIT("Can't use an undefined value as %s reference"); -EXTCONST char no_aelem[] +EXTCONST char PL_no_aelem[] INIT("Modification of non-creatable array value attempted, subscript %d"); -EXTCONST char no_helem[] +EXTCONST char PL_no_helem[] INIT("Modification of non-creatable hash value attempted, subscript \"%s\""); -EXTCONST char no_modify[] +EXTCONST char PL_no_modify[] INIT("Modification of a read-only value attempted"); -EXTCONST char no_mem[] +EXTCONST char PL_no_mem[] INIT("Out of memory!\n"); -EXTCONST char no_security[] +EXTCONST char PL_no_security[] INIT("Insecure dependency in %s%s"); -EXTCONST char no_sock_func[] +EXTCONST char PL_no_sock_func[] INIT("Unsupported socket function \"%s\" called"); -EXTCONST char no_dir_func[] +EXTCONST char PL_no_dir_func[] INIT("Unsupported directory function \"%s\" called"); -EXTCONST char no_func[] +EXTCONST char PL_no_func[] INIT("The %s function is unimplemented"); -EXTCONST char no_myglob[] +EXTCONST char PL_no_myglob[] INIT("\"my\" variable %s can't be in a package"); +EXTCONST char PL_uuemap[65] + INIT("`!\"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_"); + + #ifdef DOINIT -EXT char *sig_name[] = { SIG_NAME }; -EXT int sig_num[] = { SIG_NUM }; -EXT SV * psig_ptr[sizeof(sig_num)/sizeof(*sig_num)]; -EXT SV * psig_name[sizeof(sig_num)/sizeof(*sig_num)]; +EXT char *PL_sig_name[] = { SIG_NAME }; +EXT int PL_sig_num[] = { SIG_NUM }; #else -EXT char *sig_name[]; -EXT int sig_num[]; -EXT SV * psig_ptr[]; -EXT SV * psig_name[]; +EXT char *PL_sig_name[]; +EXT int PL_sig_num[]; #endif /* fast case folding tables */ #ifdef DOINIT #ifdef EBCDIC -EXT unsigned char fold[] = { /* fast EBCDIC case folding table */ +EXT unsigned char PL_fold[] = { /* fast EBCDIC case folding table */ 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, @@ -1760,7 +2321,7 @@ EXT unsigned char fold[] = { /* fast EBCDIC case folding table */ 248, 249, 250, 251, 252, 253, 254, 255 }; #else /* ascii rather than ebcdic */ -EXTCONST unsigned char fold[] = { +EXTCONST unsigned char PL_fold[] = { 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, @@ -1796,11 +2357,11 @@ EXTCONST unsigned char fold[] = { }; #endif /* !EBCDIC */ #else -EXTCONST unsigned char fold[]; +EXTCONST unsigned char PL_fold[]; #endif #ifdef DOINIT -EXT unsigned char fold_locale[] = { +EXT unsigned char PL_fold_locale[] = { 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, @@ -1835,12 +2396,12 @@ EXT unsigned char fold_locale[] = { 248, 249, 250, 251, 252, 253, 254, 255 }; #else -EXT unsigned char fold_locale[]; +EXT unsigned char PL_fold_locale[]; #endif #ifdef DOINIT #ifdef EBCDIC -EXT unsigned char freq[] = {/* EBCDIC frequencies for mixed English/C */ +EXT unsigned char PL_freq[] = {/* EBCDIC frequencies for mixed English/C */ 1, 2, 84, 151, 154, 155, 156, 157, 165, 246, 250, 3, 158, 7, 18, 29, 40, 51, 62, 73, 85, 96, 107, 118, @@ -1875,7 +2436,7 @@ EXT unsigned char freq[] = {/* EBCDIC frequencies for mixed English/C */ 191, 183, 141, 142, 143, 144, 145, 146 }; #else /* ascii rather than ebcdic */ -EXTCONST unsigned char freq[] = { /* letter frequencies for mixed English/C */ +EXTCONST unsigned char PL_freq[] = { /* letter frequencies for mixed English/C */ 1, 2, 84, 151, 154, 155, 156, 157, 165, 246, 250, 3, 158, 7, 18, 29, 40, 51, 62, 73, 85, 96, 107, 118, @@ -1911,12 +2472,12 @@ EXTCONST unsigned char freq[] = { /* letter frequencies for mixed English/C */ }; #endif #else -EXTCONST unsigned char freq[]; +EXTCONST unsigned char PL_freq[]; #endif #ifdef DEBUGGING #ifdef DOINIT -EXTCONST char* block_type[] = { +EXTCONST char* PL_block_type[] = { "NULL", "SUB", "EVAL", @@ -1925,10 +2486,12 @@ EXTCONST char* block_type[] = { "BLOCK", }; #else -EXTCONST char* block_type[]; +EXTCONST char* PL_block_type[]; #endif #endif +END_EXTERN_C + /*****************************************************************************/ /* This lexer/parser stuff is currently global since yacc is hard to reenter */ /*****************************************************************************/ @@ -1944,6 +2507,8 @@ typedef enum { XREF, XSTATE, XBLOCK, + XATTRBLOCK, + XATTRTERM, XTERMBLOCK } expectation; @@ -1973,18 +2538,24 @@ enum { /* pass one of these to get_vtbl */ want_vtbl_regexp, want_vtbl_collxfrm, want_vtbl_amagic, - want_vtbl_amagicelem + want_vtbl_amagicelem, #ifdef USE_THREADS - , - want_vtbl_mutex + want_vtbl_mutex, #endif + want_vtbl_regdata, + want_vtbl_regdatum, + want_vtbl_backref }; - /* Note: the lowest 8 bits are reserved for stuffing into op->op_private */ +#define HINT_PRIVATE_MASK 0x000000ff #define HINT_INTEGER 0x00000001 #define HINT_STRICT_REFS 0x00000002 +/* #define HINT_notused4 0x00000004 */ +#define HINT_BYTE 0x00000008 +/* #define HINT_notused10 0x00000010 */ + /* Note: 20,40,80 used for NATIVE_HINTS */ #define HINT_BLOCK_SCOPE 0x00000100 #define HINT_STRICT_SUBS 0x00000200 @@ -2001,78 +2572,72 @@ enum { /* pass one of these to get_vtbl */ #define HINT_RE_TAINT 0x00100000 #define HINT_RE_EVAL 0x00200000 +#define HINT_FILETEST_ACCESS 0x00400000 +#define HINT_UTF8 0x00800000 + /* Various states of an input record separator SV (rs, nrs) */ #define RsSNARF(sv) (! SvOK(sv)) -#define RsSIMPLE(sv) (SvOK(sv) && SvCUR(sv)) -#define RsPARA(sv) (SvOK(sv) && ! SvCUR(sv)) +#define RsSIMPLE(sv) (SvOK(sv) && (! SvPOK(sv) || SvCUR(sv))) +#define RsPARA(sv) (SvPOK(sv) && ! SvCUR(sv)) #define RsRECORD(sv) (SvROK(sv) && (SvIV(SvRV(sv)) > 0)) /* Enable variables which are pointers to functions */ -#ifdef PERL_OBJECT -typedef regexp*(CPerlObj::*regcomp_t) _((char* exp, char* xend, PMOP* pm)); -typedef I32 (CPerlObj::*regexec_t) _((regexp* prog, char* stringarg, - char* strend, char* strbeg, - I32 minend, SV* screamer, void* data, - U32 flags)); -#else -typedef regexp*(*regcomp_t) _((char* exp, char* xend, PMOP* pm)); -typedef I32 (*regexec_t) _((regexp* prog, char* stringarg, char* strend, char* - strbeg, I32 minend, SV* screamer, void* data, - U32 flags)); +typedef regexp*(CPERLscope(*regcomp_t)) (pTHX_ char* exp, char* xend, PMOP* pm); +typedef I32 (CPERLscope(*regexec_t)) (pTHX_ regexp* prog, char* stringarg, + char* strend, char* strbeg, I32 minend, + SV* screamer, void* data, U32 flags); +typedef char* (CPERLscope(*re_intuit_start_t)) (pTHX_ regexp *prog, SV *sv, + char *strpos, char *strend, + U32 flags, + struct re_scream_pos_data_s *d); +typedef SV* (CPERLscope(*re_intuit_string_t)) (pTHX_ regexp *prog); +typedef void (CPERLscope(*regfree_t)) (pTHX_ struct regexp* r); + +#ifdef USE_PURE_BISON +int Perl_yylex(pTHX_ YYSTYPE *lvalp, int *lcharp); +#endif + +typedef void (*DESTRUCTORFUNC_NOCONTEXT_t) (void*); +typedef void (*DESTRUCTORFUNC_t) (pTHXo_ void*); +typedef void (*SVFUNC_t) (pTHXo_ SV*); +typedef I32 (*SVCOMPARE_t) (pTHXo_ SV*, SV*); +typedef void (*XSINIT_t) (pTHXo); +typedef void (*ATEXIT_t) (pTHXo_ void*); +typedef void (*XSUBADDR_t) (pTHXo_ CV *); #endif /* Set up PERLVAR macros for populating structs */ #define PERLVAR(var,type) type var; +#define PERLVARA(var,n,type) type var[n]; #define PERLVARI(var,type,init) type var; #define PERLVARIC(var,type,init) type var; /* Interpreter exitlist entry */ typedef struct exitlistentry { -#ifdef PERL_OBJECT - void (*fn) _((CPerlObj*, void*)); -#else - void (*fn) _((void*)); -#endif + void (*fn) (pTHXo_ void*); void *ptr; } PerlExitListEntry; -#ifdef PERL_OBJECT -extern "C" CPerlObj* perl_alloc _((IPerlMem*, IPerlEnv*, IPerlStdIO*, IPerlLIO*, IPerlDir*, IPerlSock*, IPerlProc*)); - -typedef int (CPerlObj::*runops_proc_t) _((void)); -#undef EXT -#define EXT -#undef EXTCONST -#define EXTCONST -#undef INIT -#define INIT(x) - -class CPerlObj { -public: - CPerlObj(IPerlMem*, IPerlEnv*, IPerlStdIO*, IPerlLIO*, IPerlDir*, IPerlSock*, IPerlProc*); - void Init(void); - void* operator new(size_t nSize, IPerlMem *pvtbl); -#endif /* PERL_OBJECT */ - #ifdef PERL_GLOBAL_STRUCT struct perl_vars { -#include "perlvars.h" +# include "perlvars.h" }; -#ifdef PERL_CORE +# ifdef PERL_CORE EXT struct perl_vars PL_Vars; EXT struct perl_vars *PL_VarsPtr INIT(&PL_Vars); -#else /* PERL_CORE */ -#if !defined(__GNUC__) || !defined(WIN32) +# else /* PERL_CORE */ +# if !defined(__GNUC__) || !defined(WIN32) EXT -#endif /* WIN32 */ +# endif /* WIN32 */ struct perl_vars *PL_VarsPtr; -#define PL_Vars (*((PL_VarsPtr) ? PL_VarsPtr : (PL_VarsPtr = Perl_GetVars()))) -#endif /* PERL_CORE */ +# define PL_Vars (*((PL_VarsPtr) \ + ? PL_VarsPtr : (PL_VarsPtr = Perl_GetVars(aTHX)))) +# endif /* PERL_CORE */ #endif /* PERL_GLOBAL_STRUCT */ -#ifdef MULTIPLICITY +#if defined(MULTIPLICITY) || defined(PERL_OBJECT) /* If we have multiple interpreters define a struct holding variables which must be per-interpreter If we don't have threads anything that would have @@ -2080,17 +2645,22 @@ struct perl_vars *PL_VarsPtr; */ struct interpreter { -#ifndef USE_THREADS -#include "thrdvar.h" -#endif -#include "intrpvar.h" +# ifndef USE_THREADS +# include "thrdvar.h" +# endif +# include "intrpvar.h" +/* + * The following is a buffer where new variables must + * be defined to maintain binary compatibility with PERL_OBJECT + */ +PERLVARA(object_compatibility,30, char) }; #else struct interpreter { char broiled; }; -#endif +#endif /* MULTIPLICITY || PERL_OBJECT */ #ifdef USE_THREADS /* If we have threads define a struct with all the variables @@ -2110,24 +2680,51 @@ typedef void *Thread; /* Done with PERLVAR macros for now ... */ #undef PERLVAR +#undef PERLVARA #undef PERLVARI #undef PERLVARIC #include "thread.h" #include "pp.h" + +#ifndef PERL_CALLCONV +# define PERL_CALLCONV +#endif + +#ifndef NEXT30_NO_ATTRIBUTE +# ifndef HASATTRIBUTE /* disable GNU-cc attribute checking? */ +# ifdef __attribute__ /* Avoid possible redefinition errors */ +# undef __attribute__ +# endif +# define __attribute__(attr) +# endif +#endif + +#ifdef PERL_OBJECT +# define PERL_DECL_PROT +#endif + +#undef PERL_CKDEF +#undef PERL_PPDEF +#define PERL_CKDEF(s) OP *s (pTHX_ OP *o); +#define PERL_PPDEF(s) OP *s (pTHX); + #include "proto.h" -#ifdef EMBED -#define Perl_sv_setptrobj(rv,ptr,name) Perl_sv_setref_iv(rv,name,(IV)ptr) -#define Perl_sv_setptrref(rv,ptr) Perl_sv_setref_iv(rv,Nullch,(IV)ptr) -#else -#define sv_setptrobj(rv,ptr,name) sv_setref_iv(rv,name,(IV)ptr) -#define sv_setptrref(rv,ptr) sv_setref_iv(rv,Nullch,(IV)ptr) +#ifdef PERL_OBJECT +# undef PERL_DECL_PROT +#endif + +#ifndef PERL_OBJECT +/* this has structure inits, so it cannot be included before here */ +# include "opcode.h" #endif /* The following must follow proto.h as #defines mess up syntax */ -#include "embedvar.h" +#if !defined(PERL_FOR_X2P) +# include "embedvar.h" +#endif /* Now include all the 'global' variables * If we don't have threads or multiple interpreters @@ -2135,6 +2732,7 @@ typedef void *Thread; */ #define PERLVAR(var,type) EXT type PL_##var; +#define PERLVARA(var,n,type) EXT type PL_##var[n]; #define PERLVARI(var,type,init) EXT type PL_##var INIT(init); #define PERLVARIC(var,type,init) EXTCONST type PL_##var INIT(init); @@ -2142,219 +2740,215 @@ typedef void *Thread; #include "perlvars.h" #endif -#ifndef MULTIPLICITY - +#if !defined(MULTIPLICITY) && !defined(PERL_OBJECT) +START_EXTERN_C # include "intrpvar.h" # ifndef USE_THREADS # include "thrdvar.h" # endif - +END_EXTERN_C #endif #ifdef PERL_OBJECT -/* from perly.c */ -#undef yydebug -#undef yynerrs -#undef yyerrflag -#undef yychar -#undef yyssp -#undef yyvsp -#undef yyval -#undef yylval -#define yydebug PL_yydebug -#define yynerrs PL_yynerrs -#define yyerrflag PL_yyerrflag -#define yychar PL_yychar -#define yyssp PL_yyssp -#define yyvsp PL_yyvsp -#define yyval PL_yyval -#define yylval PL_yylval -PERLVAR(yydebug, int) -PERLVAR(yynerrs, int) -PERLVAR(yyerrflag, int) -PERLVAR(yychar, int) -PERLVAR(yyssp, short*) -PERLVAR(yyvsp, YYSTYPE*) -PERLVAR(yyval, YYSTYPE) -PERLVAR(yylval, YYSTYPE) - -#define efloatbuf PL_efloatbuf -#define efloatsize PL_efloatsize -PERLVAR(efloatbuf, char *) -PERLVAR(efloatsize, STRLEN) - -#define glob_index PL_glob_index -#define srand_called PL_srand_called -#define uudmap PL_uudmap -#define bitcount PL_bitcount -#define filter_debug PL_filter_debug -PERLVAR(glob_index, int) -PERLVAR(srand_called, bool) -PERLVAR(uudmap[256], char) -PERLVAR(bitcount, char*) -PERLVAR(filter_debug, int) -PERLVAR(super_bufptr, char*) /* PL_bufptr that was */ -PERLVAR(super_bufend, char*) /* PL_bufend that was */ +# include "embed.h" -/* - * The following is a buffer where new variables must - * be defined to maintain binary compatibility with PERL_OBJECT - * for 5.005 - */ -PERLVAR(object_compatibility[30], char) -}; +# ifdef DOINIT +# include "INTERN.h" +# else +# include "EXTERN.h" +# endif + +/* this has structure inits, so it cannot be included before here */ +# include "opcode.h" -#include "objpp.h" -#ifdef DOINIT -#include "INTERN.h" #else -#include "EXTERN.h" -#endif +# if defined(WIN32) +# include "embed.h" +# endif #endif /* PERL_OBJECT */ +#ifndef PERL_GLOBAL_STRUCT +START_EXTERN_C + +# include "perlvars.h" + +END_EXTERN_C +#endif #undef PERLVAR +#undef PERLVARA #undef PERLVARI #undef PERLVARIC -#if defined(HASATTRIBUTE) && defined(WIN32) -/* - * This provides a layer of functions and macros to ensure extensions will - * get to use the same RTL functions as the core. - * It has to go here or #define of printf messes up __attribute__ - * stuff in proto.h - */ -#ifndef PERL_OBJECT -# include <win32iop.h> -#endif /* PERL_OBJECT */ -#endif /* WIN32 */ +START_EXTERN_C #ifdef DOINIT -EXT MGVTBL vtbl_sv = {magic_get, - magic_set, - magic_len, +EXT MGVTBL PL_vtbl_sv = {MEMBER_TO_FPTR(Perl_magic_get), + MEMBER_TO_FPTR(Perl_magic_set), + MEMBER_TO_FPTR(Perl_magic_len), 0, 0}; -EXT MGVTBL vtbl_env = {0, magic_set_all_env, - 0, magic_clear_all_env, +EXT MGVTBL PL_vtbl_env = {0, MEMBER_TO_FPTR(Perl_magic_set_all_env), + 0, MEMBER_TO_FPTR(Perl_magic_clear_all_env), 0}; -EXT MGVTBL vtbl_envelem = {0, magic_setenv, - 0, magic_clearenv, +EXT MGVTBL PL_vtbl_envelem = {0, MEMBER_TO_FPTR(Perl_magic_setenv), + 0, MEMBER_TO_FPTR(Perl_magic_clearenv), 0}; -EXT MGVTBL vtbl_sig = {0, 0, 0, 0, 0}; -EXT MGVTBL vtbl_sigelem = {magic_getsig, - magic_setsig, - 0, magic_clearsig, +EXT MGVTBL PL_vtbl_sig = {0, 0, 0, 0, 0}; +EXT MGVTBL PL_vtbl_sigelem = {MEMBER_TO_FPTR(Perl_magic_getsig), + MEMBER_TO_FPTR(Perl_magic_setsig), + 0, MEMBER_TO_FPTR(Perl_magic_clearsig), 0}; -EXT MGVTBL vtbl_pack = {0, 0, magic_sizepack, magic_wipepack, +EXT MGVTBL PL_vtbl_pack = {0, 0, MEMBER_TO_FPTR(Perl_magic_sizepack), MEMBER_TO_FPTR(Perl_magic_wipepack), 0}; -EXT MGVTBL vtbl_packelem = {magic_getpack, - magic_setpack, - 0, magic_clearpack, +EXT MGVTBL PL_vtbl_packelem = {MEMBER_TO_FPTR(Perl_magic_getpack), + MEMBER_TO_FPTR(Perl_magic_setpack), + 0, MEMBER_TO_FPTR(Perl_magic_clearpack), 0}; -EXT MGVTBL vtbl_dbline = {0, magic_setdbline, +EXT MGVTBL PL_vtbl_dbline = {0, MEMBER_TO_FPTR(Perl_magic_setdbline), 0, 0, 0}; -EXT MGVTBL vtbl_isa = {0, magic_setisa, - 0, magic_setisa, +EXT MGVTBL PL_vtbl_isa = {0, MEMBER_TO_FPTR(Perl_magic_setisa), + 0, MEMBER_TO_FPTR(Perl_magic_setisa), 0}; -EXT MGVTBL vtbl_isaelem = {0, magic_setisa, +EXT MGVTBL PL_vtbl_isaelem = {0, MEMBER_TO_FPTR(Perl_magic_setisa), 0, 0, 0}; -EXT MGVTBL vtbl_arylen = {magic_getarylen, - magic_setarylen, +EXT MGVTBL PL_vtbl_arylen = {MEMBER_TO_FPTR(Perl_magic_getarylen), + MEMBER_TO_FPTR(Perl_magic_setarylen), 0, 0, 0}; -EXT MGVTBL vtbl_glob = {magic_getglob, - magic_setglob, +EXT MGVTBL PL_vtbl_glob = {MEMBER_TO_FPTR(Perl_magic_getglob), + MEMBER_TO_FPTR(Perl_magic_setglob), 0, 0, 0}; -EXT MGVTBL vtbl_mglob = {0, magic_setmglob, +EXT MGVTBL PL_vtbl_mglob = {0, MEMBER_TO_FPTR(Perl_magic_setmglob), 0, 0, 0}; -EXT MGVTBL vtbl_nkeys = {magic_getnkeys, - magic_setnkeys, +EXT MGVTBL PL_vtbl_nkeys = {MEMBER_TO_FPTR(Perl_magic_getnkeys), + MEMBER_TO_FPTR(Perl_magic_setnkeys), 0, 0, 0}; -EXT MGVTBL vtbl_taint = {magic_gettaint,magic_settaint, +EXT MGVTBL PL_vtbl_taint = {MEMBER_TO_FPTR(Perl_magic_gettaint),MEMBER_TO_FPTR(Perl_magic_settaint), 0, 0, 0}; -EXT MGVTBL vtbl_substr = {magic_getsubstr, magic_setsubstr, +EXT MGVTBL PL_vtbl_substr = {MEMBER_TO_FPTR(Perl_magic_getsubstr), MEMBER_TO_FPTR(Perl_magic_setsubstr), 0, 0, 0}; -EXT MGVTBL vtbl_vec = {magic_getvec, - magic_setvec, +EXT MGVTBL PL_vtbl_vec = {MEMBER_TO_FPTR(Perl_magic_getvec), + MEMBER_TO_FPTR(Perl_magic_setvec), 0, 0, 0}; -EXT MGVTBL vtbl_pos = {magic_getpos, - magic_setpos, +EXT MGVTBL PL_vtbl_pos = {MEMBER_TO_FPTR(Perl_magic_getpos), + MEMBER_TO_FPTR(Perl_magic_setpos), 0, 0, 0}; -EXT MGVTBL vtbl_bm = {0, magic_setbm, +EXT MGVTBL PL_vtbl_bm = {0, MEMBER_TO_FPTR(Perl_magic_setbm), 0, 0, 0}; -EXT MGVTBL vtbl_fm = {0, magic_setfm, +EXT MGVTBL PL_vtbl_fm = {0, MEMBER_TO_FPTR(Perl_magic_setfm), 0, 0, 0}; -EXT MGVTBL vtbl_uvar = {magic_getuvar, - magic_setuvar, +EXT MGVTBL PL_vtbl_uvar = {MEMBER_TO_FPTR(Perl_magic_getuvar), + MEMBER_TO_FPTR(Perl_magic_setuvar), 0, 0, 0}; #ifdef USE_THREADS -EXT MGVTBL vtbl_mutex = {0, 0, 0, 0, magic_mutexfree}; +EXT MGVTBL PL_vtbl_mutex = {0, 0, 0, 0, MEMBER_TO_FPTR(Perl_magic_mutexfree)}; #endif /* USE_THREADS */ -EXT MGVTBL vtbl_defelem = {magic_getdefelem,magic_setdefelem, +EXT MGVTBL PL_vtbl_defelem = {MEMBER_TO_FPTR(Perl_magic_getdefelem),MEMBER_TO_FPTR(Perl_magic_setdefelem), 0, 0, 0}; -EXT MGVTBL vtbl_regexp = {0,0,0,0, magic_freeregexp}; +EXT MGVTBL PL_vtbl_regexp = {0,0,0,0, MEMBER_TO_FPTR(Perl_magic_freeregexp)}; +EXT MGVTBL PL_vtbl_regdata = {0, 0, MEMBER_TO_FPTR(Perl_magic_regdata_cnt), 0, 0}; +EXT MGVTBL PL_vtbl_regdatum = {MEMBER_TO_FPTR(Perl_magic_regdatum_get), 0, 0, 0, 0}; #ifdef USE_LOCALE_COLLATE -EXT MGVTBL vtbl_collxfrm = {0, - magic_setcollxfrm, +EXT MGVTBL PL_vtbl_collxfrm = {0, + MEMBER_TO_FPTR(Perl_magic_setcollxfrm), 0, 0, 0}; #endif -#ifdef OVERLOAD -EXT MGVTBL vtbl_amagic = {0, magic_setamagic, - 0, 0, magic_setamagic}; -EXT MGVTBL vtbl_amagicelem = {0, magic_setamagic, - 0, 0, magic_setamagic}; -#endif /* OVERLOAD */ +EXT MGVTBL PL_vtbl_amagic = {0, MEMBER_TO_FPTR(Perl_magic_setamagic), + 0, 0, MEMBER_TO_FPTR(Perl_magic_setamagic)}; +EXT MGVTBL PL_vtbl_amagicelem = {0, MEMBER_TO_FPTR(Perl_magic_setamagic), + 0, 0, MEMBER_TO_FPTR(Perl_magic_setamagic)}; + +EXT MGVTBL PL_vtbl_backref = {0, 0, + 0, 0, MEMBER_TO_FPTR(Perl_magic_killbackrefs)}; #else /* !DOINIT */ -EXT MGVTBL vtbl_sv; -EXT MGVTBL vtbl_env; -EXT MGVTBL vtbl_envelem; -EXT MGVTBL vtbl_sig; -EXT MGVTBL vtbl_sigelem; -EXT MGVTBL vtbl_pack; -EXT MGVTBL vtbl_packelem; -EXT MGVTBL vtbl_dbline; -EXT MGVTBL vtbl_isa; -EXT MGVTBL vtbl_isaelem; -EXT MGVTBL vtbl_arylen; -EXT MGVTBL vtbl_glob; -EXT MGVTBL vtbl_mglob; -EXT MGVTBL vtbl_nkeys; -EXT MGVTBL vtbl_taint; -EXT MGVTBL vtbl_substr; -EXT MGVTBL vtbl_vec; -EXT MGVTBL vtbl_pos; -EXT MGVTBL vtbl_bm; -EXT MGVTBL vtbl_fm; -EXT MGVTBL vtbl_uvar; +EXT MGVTBL PL_vtbl_sv; +EXT MGVTBL PL_vtbl_env; +EXT MGVTBL PL_vtbl_envelem; +EXT MGVTBL PL_vtbl_sig; +EXT MGVTBL PL_vtbl_sigelem; +EXT MGVTBL PL_vtbl_pack; +EXT MGVTBL PL_vtbl_packelem; +EXT MGVTBL PL_vtbl_dbline; +EXT MGVTBL PL_vtbl_isa; +EXT MGVTBL PL_vtbl_isaelem; +EXT MGVTBL PL_vtbl_arylen; +EXT MGVTBL PL_vtbl_glob; +EXT MGVTBL PL_vtbl_mglob; +EXT MGVTBL PL_vtbl_nkeys; +EXT MGVTBL PL_vtbl_taint; +EXT MGVTBL PL_vtbl_substr; +EXT MGVTBL PL_vtbl_vec; +EXT MGVTBL PL_vtbl_pos; +EXT MGVTBL PL_vtbl_bm; +EXT MGVTBL PL_vtbl_fm; +EXT MGVTBL PL_vtbl_uvar; #ifdef USE_THREADS -EXT MGVTBL vtbl_mutex; +EXT MGVTBL PL_vtbl_mutex; #endif /* USE_THREADS */ -EXT MGVTBL vtbl_defelem; -EXT MGVTBL vtbl_regexp; +EXT MGVTBL PL_vtbl_defelem; +EXT MGVTBL PL_vtbl_regexp; +EXT MGVTBL PL_vtbl_regdata; +EXT MGVTBL PL_vtbl_regdatum; #ifdef USE_LOCALE_COLLATE -EXT MGVTBL vtbl_collxfrm; +EXT MGVTBL PL_vtbl_collxfrm; #endif -#ifdef OVERLOAD -EXT MGVTBL vtbl_amagic; -EXT MGVTBL vtbl_amagicelem; -#endif /* OVERLOAD */ +EXT MGVTBL PL_vtbl_amagic; +EXT MGVTBL PL_vtbl_amagicelem; + +EXT MGVTBL PL_vtbl_backref; #endif /* !DOINIT */ -#ifdef OVERLOAD +enum { + fallback_amg, abs_amg, + bool__amg, nomethod_amg, + string_amg, numer_amg, + add_amg, add_ass_amg, + subtr_amg, subtr_ass_amg, + mult_amg, mult_ass_amg, + div_amg, div_ass_amg, + modulo_amg, modulo_ass_amg, + pow_amg, pow_ass_amg, + lshift_amg, lshift_ass_amg, + rshift_amg, rshift_ass_amg, + band_amg, band_ass_amg, + bor_amg, bor_ass_amg, + bxor_amg, bxor_ass_amg, + lt_amg, le_amg, + gt_amg, ge_amg, + eq_amg, ne_amg, + ncmp_amg, scmp_amg, + slt_amg, sle_amg, + sgt_amg, sge_amg, + seq_amg, sne_amg, + not_amg, compl_amg, + inc_amg, dec_amg, + atan2_amg, cos_amg, + sin_amg, exp_amg, + log_amg, sqrt_amg, + repeat_amg, repeat_ass_amg, + concat_amg, concat_ass_amg, + copy_amg, neg_amg, + to_sv_amg, to_av_amg, + to_hv_amg, to_gv_amg, + to_cv_amg, iter_amg, + max_amg_code + /* Do not leave a trailing comma here. C9X allows it, C89 doesn't. */ +}; + +#define NofAMmeth max_amg_code -#define NofAMmeth 58 #ifdef DOINIT -EXTCONST char * AMG_names[NofAMmeth] = { +EXTCONST char * PL_AMG_names[NofAMmeth] = { "fallback", "abs", /* "fallback" should be the first. */ "bool", "nomethod", "\"\"", "0+", @@ -2383,12 +2977,17 @@ EXTCONST char * AMG_names[NofAMmeth] = { "log", "sqrt", "x", "x=", ".", ".=", - "=", "neg" + "=", "neg", + "${}", "@{}", + "%{}", "*{}", + "&{}", "<>", }; #else -EXTCONST char * AMG_names[NofAMmeth]; +EXTCONST char * PL_AMG_names[NofAMmeth]; #endif /* def INITAMAGIC */ +END_EXTERN_C + struct am_table { long was_ok_sub; long was_ok_am; @@ -2413,37 +3012,6 @@ typedef struct am_table_short AMTS; #define AMT_AMAGIC_on(amt) ((amt)->flags |= AMTf_AMAGIC) #define AMT_AMAGIC_off(amt) ((amt)->flags &= ~AMTf_AMAGIC) -enum { - fallback_amg, abs_amg, - bool__amg, nomethod_amg, - string_amg, numer_amg, - add_amg, add_ass_amg, - subtr_amg, subtr_ass_amg, - mult_amg, mult_ass_amg, - div_amg, div_ass_amg, - modulo_amg, modulo_ass_amg, - pow_amg, pow_ass_amg, - lshift_amg, lshift_ass_amg, - rshift_amg, rshift_ass_amg, - band_amg, band_ass_amg, - bor_amg, bor_ass_amg, - bxor_amg, bxor_ass_amg, - lt_amg, le_amg, - gt_amg, ge_amg, - eq_amg, ne_amg, - ncmp_amg, scmp_amg, - slt_amg, sle_amg, - sgt_amg, sge_amg, - seq_amg, sne_amg, - not_amg, compl_amg, - inc_amg, dec_amg, - atan2_amg, cos_amg, - sin_amg, exp_amg, - log_amg, sqrt_amg, - repeat_amg, repeat_ass_amg, - concat_amg, concat_ass_amg, - copy_amg, neg_amg -}; /* * some compilers like to redefine cos et alia as faster @@ -2476,18 +3044,22 @@ enum { # endif #endif /* _FASTMATH */ -#endif /* OVERLOAD */ - -#define PERLDB_ALL 0x3f /* No _NONAME, _GOTO */ -#define PERLDBf_SUB 0x01 /* Debug sub enter/exit. */ -#define PERLDBf_LINE 0x02 /* Keep line #. */ -#define PERLDBf_NOOPT 0x04 /* Switch off optimizations. */ -#define PERLDBf_INTER 0x08 /* Preserve more data for - later inspections. */ -#define PERLDBf_SUBLINE 0x10 /* Keep subr source lines. */ -#define PERLDBf_SINGLE 0x20 /* Start with single-step on. */ -#define PERLDBf_NONAME 0x40 /* For _SUB: no name of the subr. */ -#define PERLDBf_GOTO 0x80 /* Report goto: call DB::goto. */ +#define PERLDB_ALL (PERLDBf_SUB | PERLDBf_LINE | \ + PERLDBf_NOOPT | PERLDBf_INTER | \ + PERLDBf_SUBLINE| PERLDBf_SINGLE| \ + PERLDBf_NAMEEVAL| PERLDBf_NAMEANON) + /* No _NONAME, _GOTO */ +#define PERLDBf_SUB 0x01 /* Debug sub enter/exit */ +#define PERLDBf_LINE 0x02 /* Keep line # */ +#define PERLDBf_NOOPT 0x04 /* Switch off optimizations */ +#define PERLDBf_INTER 0x08 /* Preserve more data for + later inspections */ +#define PERLDBf_SUBLINE 0x10 /* Keep subr source lines */ +#define PERLDBf_SINGLE 0x20 /* Start with single-step on */ +#define PERLDBf_NONAME 0x40 /* For _SUB: no name of the subr */ +#define PERLDBf_GOTO 0x80 /* Report goto: call DB::goto */ +#define PERLDBf_NAMEEVAL 0x100 /* Informative names for evals */ +#define PERLDBf_NAMEANON 0x200 /* Informative names for anon subs */ #define PERLDB_SUB (PL_perldb && (PL_perldb & PERLDBf_SUB)) #define PERLDB_LINE (PL_perldb && (PL_perldb & PERLDBf_LINE)) @@ -2497,42 +3069,144 @@ enum { #define PERLDB_SINGLE (PL_perldb && (PL_perldb & PERLDBf_SINGLE)) #define PERLDB_SUB_NN (PL_perldb && (PL_perldb & (PERLDBf_NONAME))) #define PERLDB_GOTO (PL_perldb && (PL_perldb & PERLDBf_GOTO)) +#define PERLDB_NAMEEVAL (PL_perldb && (PL_perldb & PERLDBf_NAMEEVAL)) +#define PERLDB_NAMEANON (PL_perldb && (PL_perldb & PERLDBf_NAMEANON)) #ifdef USE_LOCALE_NUMERIC #define SET_NUMERIC_STANDARD() \ STMT_START { \ - if (! PL_numeric_standard) \ - perl_set_numeric_standard(); \ + if (! PL_numeric_standard) \ + set_numeric_standard(); \ } STMT_END #define SET_NUMERIC_LOCAL() \ STMT_START { \ if (! PL_numeric_local) \ - perl_set_numeric_local(); \ + set_numeric_local(); \ } STMT_END +#define IS_NUMERIC_RADIX(c) \ + ((PL_hints & HINT_LOCALE) && \ + PL_numeric_radix && (c) == PL_numeric_radix) + +#define RESTORE_NUMERIC_LOCAL() if ((PL_hints & HINT_LOCALE) && PL_numeric_standard) SET_NUMERIC_LOCAL() +#define RESTORE_NUMERIC_STANDARD() if ((PL_hints & HINT_LOCALE) && PL_numeric_local) SET_NUMERIC_STANDARD() +#define Atof my_atof + #else /* !USE_LOCALE_NUMERIC */ -#define SET_NUMERIC_STANDARD() /**/ -#define SET_NUMERIC_LOCAL() /**/ +#define SET_NUMERIC_STANDARD() /**/ +#define SET_NUMERIC_LOCAL() /**/ +#define IS_NUMERIC_RADIX(c) (0) +#define RESTORE_NUMERIC_LOCAL() /**/ +#define RESTORE_NUMERIC_STANDARD() /**/ +#define Atof Perl_atof #endif /* !USE_LOCALE_NUMERIC */ +#if !defined(Strtol) && defined(USE_64_BIT_INT) && defined(IV_IS_QUAD) && QUADKIND == QUAD_IS_LONG_LONG +# ifdef __hpux +# define strtoll __strtoll /* secret handshake */ +# endif +# if !defined(Strtol) && defined(HAS_STRTOLL) +# define Strtol strtoll +# endif +/* is there atoq() anywhere? */ +#endif +#if !defined(Strtol) && defined(HAS_STRTOL) +# define Strtol strtol +#endif +#ifndef Atol +/* It would be more fashionable to use Strtol() to define atol() + * (as is done for Atoul(), see below) but for backward compatibility + * we just assume atol(). */ +# if defined(USE_64_BIT_INT) && defined(IV_IS_QUAD) && QUADKIND == QUAD_IS_LONG_LONG && defined(HAS_ATOLL) +# define Atol atoll +# else +# define Atol atol +# endif +#endif + +#if !defined(Strtoul) && defined(USE_64_BIT_INT) && defined(UV_IS_QUAD) && QUADKIND == QUAD_IS_LONG_LONG +# ifdef __hpux +# define strtoull __strtoull /* secret handshake */ +# endif +# if !defined(Strtoul) && defined(HAS_STRTOULL) +# define Strtoul strtoull +# endif +# if !defined(Strtoul) && defined(HAS_STRTOUQ) +# define Strtoul strtouq +# endif +/* is there atouq() anywhere? */ +#endif +#if !defined(Strtoul) && defined(HAS_STRTOUL) +# define Strtoul strtoul +#endif +#ifndef Atoul +# define Atoul(s) Strtoul(s, (char **)NULL, 10) +#endif + #if !defined(PERLIO_IS_STDIO) && defined(HASATTRIBUTE) /* * Now we have __attribute__ out of the way * Remap printf */ +#undef printf #define printf PerlIO_stdoutf #endif +/* if these never got defined, they need defaults */ +#ifndef PERL_SET_CONTEXT +# define PERL_SET_CONTEXT(i) PERL_SET_INTERP(i) +#endif + +#ifndef PERL_GET_CONTEXT +# define PERL_GET_CONTEXT PERL_GET_INTERP +#endif + +#ifndef PERL_GET_THX +# define PERL_GET_THX ((void*)NULL) +#endif + +#ifndef PERL_SET_THX +# define PERL_SET_THX(t) NOOP +#endif + #ifndef PERL_SCRIPT_MODE #define PERL_SCRIPT_MODE "r" #endif /* + * Some operating systems are stingy with stack allocation, + * so perl may have to guard against stack overflow. + */ +#ifndef PERL_STACK_OVERFLOW_CHECK +#define PERL_STACK_OVERFLOW_CHECK() NOOP +#endif + +/* + * Some nonpreemptive operating systems find it convenient to + * check for asynchronous conditions after each op execution. + * Keep this check simple, or it may slow down execution + * massively. + */ +#ifndef PERL_ASYNC_CHECK +#define PERL_ASYNC_CHECK() NOOP +#endif + +/* + * On some operating systems, a memory allocation may succeed, + * but put the process too close to the system's comfort limit. + * In this case, PERL_ALLOC_CHECK frees the pointer and sets + * it to NULL. + */ +#ifndef PERL_ALLOC_CHECK +#define PERL_ALLOC_CHECK(p) NOOP +#endif + +/* * nice_chunk and nice_chunk size need to be set * and queried under the protection of sv_mutex */ @@ -2553,21 +3227,55 @@ enum { # include <sys/sem.h> # ifndef HAS_UNION_SEMUN /* Provide the union semun. */ union semun { - int val; - struct semid_ds *buf; - unsigned short *array; + int val; + struct semid_ds *buf; + unsigned short *array; }; # endif # ifdef USE_SEMCTL_SEMUN +# ifdef IRIX32_SEMUN_BROKEN_BY_GCC + union gccbug_semun { + int val; + struct semid_ds *buf; + unsigned short *array; + char __dummy[5]; + }; +# define semun gccbug_semun +# endif # define Semctl(id, num, cmd, semun) semctl(id, num, cmd, semun) # else # ifdef USE_SEMCTL_SEMID_DS -# define Semctl(id, num, cmd, semun) semctl(id, num, cmd, semun.buf) +# ifdef EXTRA_F_IN_SEMUN_BUF +# define Semctl(id, num, cmd, semun) semctl(id, num, cmd, semun.buff) +# else +# define Semctl(id, num, cmd, semun) semctl(id, num, cmd, semun.buf) +# endif # endif # endif -# ifndef Semctl /* Place our bets on the semun horse. */ -# define Semctl(id, num, cmd, semun) semctl(id, num, cmd, semun) -# endif +#endif + +#ifdef I_FCNTL +# include <fcntl.h> +#endif + +#ifdef I_SYS_FILE +# include <sys/file.h> +#endif + +#ifndef O_RDONLY +/* Assume UNIX defaults */ +# define O_RDONLY 0000 +# define O_WRONLY 0001 +# define O_RDWR 0002 +# define O_CREAT 0100 +#endif + +#ifndef O_BINARY +# define O_BINARY 0 +#endif + +#ifndef O_TEXT +# define O_TEXT 0 #endif #ifdef IAMSUID @@ -2581,7 +3289,63 @@ enum { #ifdef I_MNTENT # include <mntent.h> /* for getmntent() */ #endif +#ifdef I_SYS_STATFS +# include <sys/statfs.h> /* for some statfs() */ +#endif +#ifdef I_SYS_VFS +# ifdef __sgi +# define sv IRIX_sv /* kludge: IRIX has an sv of its own */ +# endif +# include <sys/vfs.h> /* for some statfs() */ +# ifdef __sgi +# undef IRIX_sv +# endif +#endif +#ifdef I_USTAT +# include <ustat.h> /* for ustat() */ +#endif + +#if !defined(PERL_MOUNT_NOSUID) && defined(MOUNT_NOSUID) +# define PERL_MOUNT_NOSUID MOUNT_NOSUID +#endif +#if !defined(PERL_MOUNT_NOSUID) && defined(MNT_NOSUID) +# define PERL_MOUNT_NOSUID MNT_NOSUID +#endif +#if !defined(PERL_MOUNT_NOSUID) && defined(MS_NOSUID) +# define PERL_MOUNT_NOSUID MS_NOSUID +#endif +#if !defined(PERL_MOUNT_NOSUID) && defined(M_NOSUID) +# define PERL_MOUNT_NOSUID M_NOSUID +#endif #endif /* IAMSUID */ +/* and finally... */ +#define PERL_PATCHLEVEL_H_IMPLICIT +#include "patchlevel.h" +#undef PERL_PATCHLEVEL_H_IMPLICIT + +/* Mention + + NV_PRESERVES_UV + + HAS_ICONV + I_ICONV + + HAS_MKSTEMP + HAS_MKSTEMPS + HAS_MKDTEMP + + HAS_GETCWD + + HAS_MMAP + HAS_MPROTECT + HAS_MSYNC + HAS_MADVISE + HAS_MUNMAP + I_SYSMMAN + Mmap_t + + so that Configure picks them up. */ + #endif /* Include guard */ |