X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/9edfffed45d005f6a85767a405c48b9f793098df..48a26b3aff3d4a22b7cc3f3ba0bb5977d168a801:/perl.c diff --git a/perl.c b/perl.c index 46efa2a..715f4da 100644 --- a/perl.c +++ b/perl.c @@ -1,6 +1,6 @@ /* 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. @@ -27,13 +27,6 @@ char *getenv (char *); /* Usually in */ static I32 read_e_script(pTHXo_ int idx, SV *buf_sv, int maxlen); -#ifdef I_FCNTL -#include -#endif -#ifdef I_SYS_FILE -#include -#endif - #ifdef IAMSUID #ifndef DOSUID #define DOSUID @@ -47,43 +40,89 @@ static I32 read_e_script(pTHXo_ int idx, SV *buf_sv, int maxlen); #endif #ifdef PERL_OBJECT -CPerlObj* -perl_alloc(struct IPerlMem* ipM, 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; -} +#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 +# 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_IMPLICIT_SYS PerlInterpreter * -perl_alloc_using(struct IPerlMem* ipM, struct IPerlEnv* ipE, +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) { 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)); - PERL_SET_INTERP(my_perl); + 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. + +=cut +*/ + PerlInterpreter * perl_alloc(void) { @@ -91,11 +130,20 @@ perl_alloc(void) /* New() needs interpreter, so call malloc() instead */ my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter)); - PERL_SET_INTERP(my_perl); + + INIT_TLS_AND_INTERP; + Zero(my_perl, 1, PerlInterpreter); return my_perl; } #endif /* PERL_IMPLICIT_SYS */ -#endif /* PERL_OBJECT */ + +/* +=for apidoc perl_construct + +Initializes a new Perl interpreter. See L. + +=cut +*/ void perl_construct(pTHXx) @@ -106,7 +154,7 @@ perl_construct(pTHXx) struct perl_thread *thr = NULL; #endif /* FAKE_THREADS */ #endif /* USE_THREADS */ - + #ifdef MULTIPLICITY init_interp(); PL_perl_destruct_level = 1; @@ -118,14 +166,6 @@ perl_construct(pTHXx) /* 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)) - Perl_croak(aTHX_ "panic: pthread_key_create"); -#endif MUTEX_INIT(&PL_sv_mutex); /* * Safe to use basic SV functions from now on (though @@ -135,16 +175,18 @@ perl_construct(pTHXx) 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 */ @@ -202,14 +244,29 @@ perl_construct(pTHXx) init_i18nl10n(1); SET_NUMERIC_STANDARD(); + { + 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 - sprintf(PL_patchlevel, "%7.5f", (double) PERL_REVISION - + ((double) PERL_VERSION / (double) 1000) - + ((double) PERL_SUBVERSION / (double) 100000)); -#else - sprintf(PL_patchlevel, "%5.3f", (double) PERL_REVISION + - ((double) PERL_VERSION / (double) 1000)); + + ((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 */ @@ -223,6 +280,14 @@ perl_construct(pTHXx) ENTER; } +/* +=for apidoc perl_destruct + +Shuts down a Perl interpreter. See L. + +=cut +*/ + void perl_destruct(pTHXx) { @@ -235,6 +300,9 @@ perl_destruct(pTHXx) dTHX; #endif /* USE_THREADS */ + /* 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 */ @@ -309,7 +377,7 @@ perl_destruct(pTHXx) #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; @@ -389,6 +457,7 @@ perl_destruct(pTHXx) Safefree(PL_inplace); PL_inplace = Nullch; + SvREFCNT_dec(PL_patchlevel); if (PL_e_script) { SvREFCNT_dec(PL_e_script); @@ -397,10 +466,10 @@ perl_destruct(pTHXx) /* magical thingies */ - Safefree(PL_ofs); /* $, */ + Safefree(PL_ofs); /* $, */ PL_ofs = Nullch; - Safefree(PL_ors); /* $\ */ + Safefree(PL_ors); /* $\ */ PL_ors = Nullch; SvREFCNT_dec(PL_rs); /* $/ */ @@ -409,7 +478,9 @@ perl_destruct(pTHXx) 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; @@ -433,11 +504,11 @@ perl_destruct(pTHXx) /* startup and shutdown function lists */ SvREFCNT_dec(PL_beginav); SvREFCNT_dec(PL_endav); - SvREFCNT_dec(PL_stopav); + SvREFCNT_dec(PL_checkav); SvREFCNT_dec(PL_initav); PL_beginav = Nullav; PL_endav = Nullav; - PL_stopav = Nullav; + PL_checkav = Nullav; PL_initav = Nullav; /* shortcuts just get cleared */ @@ -451,15 +522,91 @@ perl_destruct(pTHXx) 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); @@ -485,14 +632,21 @@ perl_destruct(pTHXx) /* 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, @@ -524,16 +678,28 @@ perl_destruct(pTHXx) } SvREFCNT_dec(PL_strtab); + /* free special SVs */ + + SvREFCNT(&PL_sv_yes) = 0; + sv_clear(&PL_sv_yes); + SvANY(&PL_sv_yes) = NULL; + SvREADONLY_off(&PL_sv_yes); + + SvREFCNT(&PL_sv_no) = 0; + sv_clear(&PL_sv_no); + SvANY(&PL_sv_no) = NULL; + SvREADONLY_off(&PL_sv_no); + + 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); @@ -560,7 +726,7 @@ perl_destruct(pTHXx) 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) { @@ -576,7 +742,7 @@ perl_destruct(pTHXx) } } /* 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); @@ -584,6 +750,14 @@ perl_destruct(pTHXx) } } +/* +=for apidoc perl_free + +Releases a Perl interpreter. See L. + +=cut +*/ + void perl_free(pTHXx) { @@ -603,6 +777,14 @@ Perl_call_atexit(pTHX_ ATEXIT_t fn, void *ptr) ++PL_exitlistlen; } +/* +=for apidoc perl_parse + +Tells a Perl interpreter to parse a Perl script. See L. + +=cut +*/ + int perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env) { @@ -658,13 +840,20 @@ setuid perl scripts securely.\n"); oldscope = PL_scopestack_ix; PL_dowarn = G_WARN_OFF; - CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_parse_body), - env, xsinit); +#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: - if (PL_stopav) - call_list(oldscope, PL_stopav); - return 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 */ @@ -674,23 +863,36 @@ setuid perl scripts securely.\n"); LEAVE; FREETMPS; PL_curstash = PL_defstash; - if (PL_stopav) - call_list(oldscope, PL_stopav); - return STATUS_NATIVE_EXPORT; + if (PL_checkav) + call_list(oldscope, PL_checkav); + ret = STATUS_NATIVE_EXPORT; + break; case 3: PerlIO_printf(Perl_error_log, "panic: top_env\n"); - return 1; + ret = 1; + break; } - return 0; + JMPENV_POP; + return ret; } +#ifdef PERL_FLEXIBLE_EXCEPTIONS STATIC void * -S_parse_body(pTHX_ va_list args) +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 **env = va_arg(args, char**); char *scriptname = NULL; int fdscript = -1; VOL bool dosearch = FALSE; @@ -700,8 +902,6 @@ S_parse_body(pTHX_ va_list args) register char *s; char *cddir = Nullch; - XSINIT_t xsinit = va_arg(args, XSINIT_t); - sv_setpvn(PL_linestr,"",0); sv = newSVpvn("",0); /* first used for -I flags */ SAVEFREESV(sv); @@ -719,6 +919,11 @@ S_parse_body(pTHX_ va_list args) 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 @@ -743,7 +948,7 @@ S_parse_body(pTHX_ va_list args) case 'W': case 'X': case 'w': - if (s = moreswitches(s)) + if ((s = moreswitches(s))) goto reswitch; break; @@ -753,11 +958,6 @@ S_parse_body(pTHX_ va_list args) goto reswitch; case 'e': -#ifdef MACOS_TRADITIONAL - /* ignore -e for Dev:Pseudo argument */ - if (argv[1] && !strcmp(argv[1], "Dev:Pseudo")) - break; -#endif if (PL_euid != PL_uid || PL_egid != PL_gid) Perl_croak(aTHX_ "No -e allowed in setuid scripts"); if (!PL_e_script) { @@ -780,18 +980,18 @@ S_parse_body(pTHX_ va_list args) 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"); @@ -824,6 +1024,24 @@ S_parse_body(pTHX_ va_list args) # 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 @@ -902,7 +1120,8 @@ print \" \\@INC:\\n @INC\\n\";"); #ifndef SECURE_INTERNAL_GETENV !PL_tainting && #endif - (s = PerlEnv_getenv("PERL5OPT"))) { + (s = PerlEnv_getenv("PERL5OPT"))) + { while (isSPACE(*s)) s++; if (*s == '-' && *(s+1) == 'T') @@ -960,14 +1179,11 @@ print \" \\@INC:\\n @INC\\n\";"); } #endif -#ifdef MACOS_TRADITIONAL - if (PL_doextract || gAlwaysExtract) -#else if (PL_doextract) { -#endif 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); @@ -997,11 +1213,13 @@ print \" \\@INC:\\n @INC\\n\";"); CvPADLIST(PL_compcv) = comppadlist; boot_core_UNIVERSAL(); +#ifndef PERL_MICRO boot_core_xsutils(); +#endif if (xsinit) (*xsinit)(aTHXo); /* in case linked C routines want magical variables */ -#if defined(VMS) || defined(WIN32) || defined(DJGPP) +#if defined(VMS) || defined(WIN32) || defined(DJGPP) || defined(__CYGWIN__) init_os_extras(); #endif @@ -1022,16 +1240,6 @@ print \" \\@INC:\\n @INC\\n\";"); SETERRNO(0,SS$_NORMAL); PL_error_count = 0; -#ifdef MACOS_TRADITIONAL - if (gSyntaxError = (yyparse() || PL_error_count)) { - if (PL_minus_c) - Perl_croak(aTHX_ "%s had compilation errors.\n", MPWFileName(PL_origfilename)); - else { - Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n", - MPWFileName(PL_origfilename)); - } - } -#else if (yyparse() || PL_error_count) { if (PL_minus_c) Perl_croak(aTHX_ "%s had compilation errors.\n", PL_origfilename); @@ -1040,8 +1248,7 @@ print \" \\@INC:\\n @INC\\n\";"); PL_origfilename); } } -#endif - PL_curcop->cop_line = 0; + CopLINE_set(PL_curcop, 0); PL_curstash = PL_defstash; PL_preprocess = FALSE; if (PL_e_script) { @@ -1056,8 +1263,11 @@ print \" \\@INC:\\n @INC\\n\";"); if (PL_do_undump) my_unexec(); - if (isWARN_ONCE) + if (isWARN_ONCE) { + SAVECOPFILE(PL_curcop); + SAVECOPLINE(PL_curcop); gv_check(PL_defstash); + } LEAVE; FREETMPS; @@ -1072,12 +1282,20 @@ print \" \\@INC:\\n @INC\\n\";"); return NULL; } +/* +=for apidoc perl_run + +Tells a Perl interpreter to run. See L. + +=cut +*/ + int perl_run(pTHXx) { dTHR; I32 oldscope; - int ret; + int ret = 0; dJMPENV; #ifdef USE_THREADS dTHX; @@ -1085,14 +1303,23 @@ perl_run(pTHXx) oldscope = PL_scopestack_ix; +#ifdef PERL_FLEXIBLE_EXCEPTIONS redo_body: - CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_run_body), oldscope); + 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 */ goto redo_body; - case 0: /* normal completion */ - case 2: /* my_exit() */ + 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; @@ -1103,7 +1330,8 @@ perl_run(pTHXx) if (PerlEnv_getenv("PERL_DEBUG_MSTATS")) dump_mstats("after execution: "); #endif - return STATUS_NATIVE_EXPORT; + ret = STATUS_NATIVE_EXPORT; + break; case 3: if (PL_restartop) { POPSTACK_TO(PL_mainstack); @@ -1111,19 +1339,30 @@ perl_run(pTHXx) } PerlIO_printf(Perl_error_log, "panic: restartop\n"); FREETMPS; - return 1; + ret = 1; + break; } - /* NOTREACHED */ - return 0; + JMPENV_POP; + return ret; } +#ifdef PERL_FLEXIBLE_EXCEPTIONS STATIC void * -S_run_body(pTHX_ va_list args) +S_vrun_body(pTHX_ va_list args) { - dTHR; 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")); @@ -1134,12 +1373,8 @@ S_run_body(pTHX_ va_list args) PTR2UV(thr))); if (PL_minus_c) { -#ifdef MACOS_TRADITIONAL - PerlIO_printf(PerlIO_stderr(), "%s syntax OK\n", MPWFileName(PL_origfilename)); -#else PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename); -#endif -my_exit(0); + my_exit(0); } if (PERLDB_SINGLE && PL_DBsingle) sv_setiv(PL_DBsingle, 1); @@ -1165,6 +1400,16 @@ my_exit(0); return NULL; } +/* +=for apidoc p||get_sv + +Returns the SV of the specified Perl scalar. If C is set and the +Perl variable does not exist then it will be created. If C is not +set and the variable does not exist then NULL is returned. + +=cut +*/ + SV* Perl_get_sv(pTHX_ const char *name, I32 create) { @@ -1184,6 +1429,16 @@ Perl_get_sv(pTHX_ const char *name, I32 create) return Nullsv; } +/* +=for apidoc p||get_av + +Returns the AV of the specified Perl array. If C is set and the +Perl variable does not exist then it will be created. If C is not +set and the variable does not exist then NULL is returned. + +=cut +*/ + AV* Perl_get_av(pTHX_ const char *name, I32 create) { @@ -1195,6 +1450,16 @@ Perl_get_av(pTHX_ const char *name, I32 create) return Nullav; } +/* +=for apidoc p||get_hv + +Returns the HV of the specified Perl hash. If C is set and the +Perl variable does not exist then it will be created. If C is not +set and the variable does not exist then NULL is returned. + +=cut +*/ + HV* Perl_get_hv(pTHX_ const char *name, I32 create) { @@ -1206,6 +1471,17 @@ Perl_get_hv(pTHX_ const char *name, I32 create) return Nullhv; } +/* +=for apidoc p||get_cv + +Returns the CV of the specified Perl subroutine. If C is set and +the Perl subroutine does not exist then it will be declared (which has the +same effect as saying C). If C is not set and the +subroutine does not exist then NULL is returned. + +=cut +*/ + CV* Perl_get_cv(pTHX_ const char *name, I32 create) { @@ -1226,6 +1502,14 @@ Perl_get_cv(pTHX_ const 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. + +=cut +*/ + I32 Perl_call_argv(pTHX_ const char *sub_name, I32 flags, register char **argv) @@ -1245,6 +1529,14 @@ Perl_call_argv(pTHX_ const char *sub_name, I32 flags, register char **argv) return call_pv(sub_name, flags); } +/* +=for apidoc p||call_pv + +Performs a callback to the specified Perl sub. See L. + +=cut +*/ + I32 Perl_call_pv(pTHX_ const char *sub_name, I32 flags) /* name of the subroutine */ @@ -1253,6 +1545,15 @@ Perl_call_pv(pTHX_ const char *sub_name, I32 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. + +=cut +*/ + I32 Perl_call_method(pTHX_ const char *methname, I32 flags) /* name of the subroutine */ @@ -1260,17 +1561,28 @@ Perl_call_method(pTHX_ const char *methname, I32 flags) { 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(); - if(PL_op == &myop) - PL_op = Nullop; + 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. + +=cut +*/ + I32 Perl_call_sv(pTHX_ SV *sv, I32 flags) @@ -1317,7 +1629,7 @@ Perl_call_sv(pTHX_ SV *sv, I32 flags) if (!(flags & G_EVAL)) { CATCH_SET(TRUE); - call_xbody((OP*)&myop, FALSE); + call_body((OP*)&myop, FALSE); retval = PL_stack_sp - (PL_stack_base + oldmark); CATCH_SET(oldcatch); } @@ -1345,11 +1657,19 @@ Perl_call_sv(pTHX_ SV *sv, I32 flags) } PL_markstack_ptr++; - redo_body: - CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_call_body), +#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,""); @@ -1361,7 +1681,8 @@ Perl_call_sv(pTHX_ SV *sv, I32 flags) /* my_exit() was called */ PL_curstash = PL_defstash; FREETMPS; - if (PL_statusvalue) + JMPENV_POP; + if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED)) Perl_croak(aTHX_ "Callback called exit"); my_exit_jump(); /* NOTREACHED */ @@ -1394,6 +1715,7 @@ Perl_call_sv(pTHX_ SV *sv, I32 flags) PL_curpm = newpm; LEAVE; } + JMPENV_POP; } if (flags & G_DISCARD) { @@ -1406,18 +1728,20 @@ Perl_call_sv(pTHX_ SV *sv, I32 flags) return retval; } +#ifdef PERL_FLEXIBLE_EXCEPTIONS STATIC void * -S_call_body(pTHX_ va_list args) +S_vcall_body(pTHX_ va_list args) { OP *myop = va_arg(args, OP*); int is_eval = va_arg(args, int); - call_xbody(myop, is_eval); + call_body(myop, is_eval); return NULL; } +#endif STATIC void -S_call_xbody(pTHX_ OP *myop, int is_eval) +S_call_body(pTHX_ OP *myop, int is_eval) { dTHR; @@ -1433,6 +1757,14 @@ S_call_xbody(pTHX_ OP *myop, int is_eval) /* Eval a string. The G_EVAL flag is always assumed. */ +/* +=for apidoc p||eval_sv + +Tells Perl to C the string in the SV. + +=cut +*/ + I32 Perl_eval_sv(pTHX_ SV *sv, I32 flags) @@ -1469,11 +1801,19 @@ Perl_eval_sv(pTHX_ 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_call_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,""); @@ -1485,7 +1825,8 @@ Perl_eval_sv(pTHX_ SV *sv, I32 flags) /* my_exit() was called */ PL_curstash = PL_defstash; FREETMPS; - if (PL_statusvalue) + JMPENV_POP; + if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED)) Perl_croak(aTHX_ "Callback called exit"); my_exit_jump(); /* NOTREACHED */ @@ -1505,6 +1846,7 @@ Perl_eval_sv(pTHX_ SV *sv, I32 flags) break; } + JMPENV_POP; if (flags & G_DISCARD) { PL_stack_sp = PL_stack_base + oldmark; retval = 0; @@ -1515,6 +1857,14 @@ Perl_eval_sv(pTHX_ SV *sv, I32 flags) return retval; } +/* +=for apidoc p||eval_pv + +Tells Perl to C the given string and return an SV* result. + +=cut +*/ + SV* Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error) { @@ -1539,6 +1889,14 @@ Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error) /* Require a module. */ +/* +=for apidoc p||require_pv + +Tells Perl to C a module. + +=cut +*/ + void Perl_require_pv(pTHX_ const char *pv) { @@ -1560,7 +1918,7 @@ 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); } @@ -1573,6 +1931,7 @@ S_usage(pTHX_ 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 program under debugger", "-D[number/list] set debugging flags (argument is a bit mask or alphabets)", @@ -1593,6 +1952,8 @@ S_usage(pTHX_ char *name) /* XXX move this out into a module ? */ "-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 @@ -1628,6 +1989,10 @@ Perl_moreswitches(pTHX_ char *s) } return s + numlen; } + case 'C': + PL_widesyscalls = TRUE; + s++; + return s; case 'F': PL_minus_F = TRUE; PL_splitstr = savepv(s + 1); @@ -1701,14 +2066,23 @@ Perl_moreswitches(pTHX_ 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 - Perl_croak(aTHX_ "No space allowed after -I"); + Perl_croak(aTHX_ "No directory specified for -I"); return s; case 'l': PL_minus_l = TRUE; @@ -1761,7 +2135,7 @@ Perl_moreswitches(pTHX_ char *s) sv_catpv(sv, "})"); } s += strlen(s); - if (PL_preambleav == NULL) + if (!PL_preambleav) PL_preambleav = newAV(); av_push(PL_preambleav, sv); } @@ -1787,9 +2161,6 @@ Perl_moreswitches(pTHX_ char *s) s++; return s; case 'u': -#ifdef MACOS_TRADITIONAL - Perl_croak(aTHX_ "Believe me, you don't want to use \"-u\" on a Macintosh"); -#endif PL_do_undump = TRUE; s++; return s; @@ -1798,23 +2169,15 @@ Perl_moreswitches(pTHX_ char *s) s++; return s; case 'v': -#if defined(PERL_SUBVERSION) && PERL_SUBVERSION > 0 - printf("\nThis is perl, version %d.%03d_%02d built for %s", - PERL_REVISION, PERL_VERSION, PERL_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)", (int)LOCAL_PATCH_COUNT, (LOCAL_PATCH_COUNT!=1) ? "es" : ""); #endif - printf("\n\nCopyright 1987-1999, Larry Wall\n"); -#ifdef MACOS_TRADITIONAL - fputs("Macintosh port Copyright 1991-1999, Matthias Neeracher\n", stdout); -#endif + printf("\n\nCopyright 1987-2000, Larry Wall\n"); #ifdef MSDOS printf("\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n"); #endif @@ -1850,6 +2213,9 @@ Perl_moreswitches(pTHX_ char *s) #ifdef __MINT__ 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; #endif @@ -2012,12 +2378,6 @@ S_init_interp(pTHX) # endif #endif -#ifdef MACOS_TRADITIONAL - /* In MacOS time() already returns values in excess of 2**31-1, - * therefore we patch the integerness away. */ - PL_opargs[OP_TIME] &= ~OA_RETINTEGER; -#endif - } STATIC void @@ -2056,7 +2416,7 @@ S_init_main_stash(pTHX) 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. */ @@ -2067,7 +2427,6 @@ STATIC void S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript) { dTHR; - register char *s; *fdscript = -1; @@ -2091,7 +2450,7 @@ S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript) } } - CopFILEGV_set(PL_curcop, gv_fetchfile(PL_origfilename)); + CopFILE_set(PL_curcop, PL_origfilename); if (strEQ(PL_origfilename,"-")) scriptname = ""; if (*fdscript >= 0) { @@ -2110,7 +2469,7 @@ S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript) 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 @@ -2126,7 +2485,7 @@ 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 # ifdef __OPEN_VM @@ -2142,7 +2501,7 @@ sed %s -e \"/^[^#]/b\" \ -e '/^#[ ]*undef[ ]/b' \ -e '/^#[ ]*endif/b' \ -e 's/^[ ]*#.*//' \ - %s | %_ %_ %s", + %s | %"SVf" %"SVf" %s", # else Perl_sv_setpvf(aTHX_ cmd, "\ %s %s -e '/^[^#]/b' \ @@ -2156,7 +2515,7 @@ sed %s -e \"/^[^#]/b\" \ -e '/^#[ ]*undef[ ]/b' \ -e '/^#[ ]*endif/b' \ -e 's/^[ ]*#.*//' \ - %s | %_ -C %_ %s", + %s | %"SVf" -C %"SVf" %s", # endif #ifdef LOC_SED LOC_SED, @@ -2209,7 +2568,9 @@ sed %s -e \"/^[^#]/b\" \ PL_statbuf.st_mode & (S_ISUID|S_ISGID)) { /* try again */ - PerlProc_execv(Perl_form(aTHX_ "%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); Perl_croak(aTHX_ "Can't do setuid\n"); } #endif @@ -2222,7 +2583,7 @@ sed %s -e \"/^[^#]/b\" \ /* Mention * I_SYSSTATVFS HAS_FSTATVFS * I_SYSMOUNT - * I_STATFS HAS_FSTATFS + * I_STATFS HAS_FSTATFS HAS_GETFSSTAT * I_MNTENT HAS_GETMNTENT HAS_HASMNTOPT * here so that metaconfig picks them up. */ @@ -2257,7 +2618,7 @@ S_fd_on_nosuid_fs(pTHX_ int fd) # if defined(HAS_FSTAT) && \ defined(HAS_USTAT) && \ defined(HAS_GETMNT) && \ - defined(HAS_STRUCT_FS_DATA) && + defined(HAS_STRUCT_FS_DATA) && \ defined(NOSTAT_ONE) struct stat fdst; if (fstat(fd, &fdst) == 0) { @@ -2317,7 +2678,9 @@ S_fd_on_nosuid_fs(pTHX_ int fd) STATIC void S_validate_suid(pTHX_ char *validarg, char *scriptname, int fdscript) { +#ifdef IAMSUID int which; +#endif /* do we need to emulate setuid on scripts? */ @@ -2422,7 +2785,7 @@ S_validate_suid(pTHX_ char *validarg, char *scriptname, int fdscript) if (PL_statbuf.st_mode & S_IWOTH) 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 */ Perl_croak(aTHX_ "No #! line"); @@ -2456,7 +2819,9 @@ 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(Perl_form(aTHX_ "%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 Perl_croak(aTHX_ "Can't do setuid\n"); } @@ -2538,7 +2903,9 @@ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n"); #if defined(HAS_FCNTL) && defined(F_SETFD) fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0); /* ensure no close-on-exec */ #endif - PerlProc_execv(Perl_form(aTHX_ "%s/perl%s", BIN_EXP, PL_patchlevel), PL_origargv);/* try again */ + 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 */ @@ -2567,32 +2934,11 @@ S_find_beginning(pTHX) /* skip forward in input to the real script? */ forbid_setid("-x"); -#ifdef MACOS_TRADITIONAL - /* Since the Mac OS does not honor !# arguments for us, - * we do it ourselves. */ - while (PL_doextract || gAlwaysExtract) { - if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch) { - if (!gAlwaysExtract) - Perl_croak(aTHX_ "No Perl script found in input\n"); - - if (PL_doextract) /* require explicit override ? */ - if (!OverrideExtract(PL_origfilename)) - Perl_croak(aTHX_ "User aborted script\n"); - else - PL_doextract = FALSE; - - /* Pater peccavi, file does not have #! */ - PerlIO_rewind(PL_rsfp); - - break; - } -#else while (PL_doextract) { if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch) Perl_croak(aTHX_ "No Perl script found in input\n"); -#endif if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) { - PerlIO_ungetc(PL_rsfp, '\n'); /* to keep line count right */ + PerlIO_ungetc(PL_rsfp, '\n'); /* to keep line count right */ PL_doextract = FALSE; while (*s && !(isSPACE (*s) || *s == '#')) s++; s2 = s; @@ -2601,7 +2947,8 @@ S_find_beginning(pTHX) while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--; if (strnEQ(s2-4,"perl",4)) /*SUPPRESS 530*/ - while (s = moreswitches(s)) ; + while ((s = moreswitches(s))) + ; } } } @@ -2682,7 +3029,7 @@ Perl_init_stacks(pTHX) 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; @@ -2741,7 +3088,6 @@ S_init_predump_symbols(pTHX) { dTHR; GV *tmpgv; - GV *othergv; IO *io; sv_setpvn(get_sv("\"", TRUE), " ", 1); @@ -2772,9 +3118,8 @@ S_init_predump_symbols(pTHX) PL_statname = NEWSV(66,0); /* last filename we did stat on */ - if (PL_osname) - Safefree(PL_osname); - PL_osname = savepv(OSNAME); + if (!PL_osname) + PL_osname = savepv(OSNAME); } STATIC void @@ -2790,11 +3135,11 @@ S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register 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); } @@ -2811,31 +3156,28 @@ S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register PL_formtarget = PL_bodytarget; TAINT; - if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) { -#ifdef MACOS_TRADITIONAL - sv_setpv(GvSV(tmpgv),MPWFileName(PL_origfilename)); - /* $0 is not majick on a Mac */ -#else + if ((tmpgv = gv_fetchpv("0",TRUE, SVt_PV))) { sv_setpv(GvSV(tmpgv),PL_origfilename); magicname("0", "0", 1); -#endif } - 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]); #endif - if (PL_argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) { + 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); } - PL_argvout_stack = newAV(); } - 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); @@ -2871,8 +3213,8 @@ S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register #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 @@ -2883,9 +3225,9 @@ S_init_perllib(pTHX) #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 @@ -2894,113 +3236,98 @@ S_init_perllib(pTHX) 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 -#ifdef MACOS_TRADITIONAL - { - struct stat tmpstatbuf; - SV * privdir = NEWSV(55, 0); - char * macperl = getenv("MACPERL") || ""; - - Perl_sv_setpvf(privdir, "%slib:", macperl); - if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode)) - incpush(SvPVX(privdir), TRUE); - Perl_sv_setpvf(privdir, "%ssite_perl:", macperl); - if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode)) - incpush(SvPVX(privdir), TRUE); - - SvREFCNT_dec(privdir); - } - if (!PL_tainting) - incpush(":", FALSE); -#else #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 -#if defined(PERL_VENDORLIB_EXP) -#if defined(WIN32) - incpush(PERL_VENDORLIB_EXP, TRUE); -#else - incpush(PERL_VENDORLIB_EXP, FALSE); + +#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); -#endif /* MACOS_TRADITIONAL */ + incpush(".", FALSE, FALSE); } -#if defined(MACOS_TRADITIONAL) -# define PERLLIB_SEP ',' +#if defined(DOSISH) +# define PERLLIB_SEP ';' #else -# if defined(DOSISH) -# define PERLLIB_SEP ';' +# if defined(VMS) +# define PERLLIB_SEP '|' # else -# if defined(VMS) -# define PERLLIB_SEP '|' -# else -# define PERLLIB_SEP ':' -# endif +# define PERLLIB_SEP ':' # endif -#endif +#endif #ifndef PERLLIB_MANGLE -# define PERLLIB_MANGLE(s,n) (s) +# define PERLLIB_MANGLE(s,n) (s) #endif STATIC void -S_incpush(pTHX_ 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); -#ifdef MACOS_TRADITIONAL - sprintf(PL_archpat_auto, "%s:%s:auto:", ARCHNAME, PL_patchlevel); -#else - sprintf(PL_archpat_auto, "/%s/%s/auto", ARCHNAME, PL_patchlevel); -#endif -#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 */ @@ -3024,18 +3351,17 @@ S_incpush(pTHX_ char *p, int addsubdirs) sv_setpv(libdir, PERLLIB_MANGLE(p, 0)); p = Nullch; /* break out */ } -#ifdef MACOS_TRADITIONAL - if (!strchr(SvPVX(libdir), ':')) - sv_insert(libdir, 0, 0, ":", 1); - if (SvPVX(libdir)[SvCUR(libdir)-1] != ':') - sv_catpv(libdir, ":"); -#endif /* * 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; @@ -3051,21 +3377,42 @@ S_incpush(pTHX_ char *p, int addsubdirs) "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), - newSVpvn(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), - newSVpvn(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)); + } + + if (addoldvers) { +#ifdef PERL_INC_VERSION_LIST + 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 */ @@ -3121,7 +3468,7 @@ S_init_main_thread(pTHX) #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 @@ -3154,8 +3501,8 @@ void Perl_call_list(pTHX_ I32 oldscope, AV *paramList) { dTHR; - SV *atsv = ERRSV; - line_t oldline = PL_curcop->cop_line; + SV *atsv; + line_t oldline = CopLINE(PL_curcop); CV *cv; STRLEN len; int ret; @@ -3164,24 +3511,34 @@ Perl_call_list(pTHX_ I32 oldscope, AV *paramList) while (AvFILL(paramList) >= 0) { cv = (CV*)av_shift(paramList); SAVEFREESV(cv); - CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_call_list_body), 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: +#ifndef PERL_FLEXIBLE_EXCEPTIONS + call_list_body(cv); +#endif + atsv = ERRSV; (void)SvPV(atsv, len); if (len) { + STRLEN n_a; PL_curcop = &PL_compiling; - PL_curcop->cop_line = oldline; + 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_stopav ? "STOP" + paramList == PL_checkav ? "CHECK" : paramList == PL_initav ? "INIT" : "END"); while (PL_scopestack_ix > oldscope) LEAVE; - Perl_croak(aTHX_ "%s", SvPVX(atsv)); + JMPENV_POP; + Perl_croak(aTHX_ "%s", SvPVx(atsv, n_a)); } break; case 1: @@ -3194,13 +3551,14 @@ Perl_call_list(pTHX_ I32 oldscope, AV *paramList) FREETMPS; PL_curstash = PL_defstash; 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) Perl_croak(aTHX_ "BEGIN failed--compilation aborted"); else Perl_croak(aTHX_ "%s failed--call queue aborted", - paramList == PL_stopav ? "STOP" + paramList == PL_checkav ? "CHECK" : paramList == PL_initav ? "INIT" : "END"); } @@ -3209,22 +3567,29 @@ Perl_call_list(pTHX_ I32 oldscope, AV *paramList) case 3: if (PL_restartop) { PL_curcop = &PL_compiling; - PL_curcop->cop_line = oldline; + CopLINE_set(PL_curcop, oldline); JMPENV_JUMP(3); } PerlIO_printf(Perl_error_log, "panic: restartop\n"); FREETMPS; break; } + JMPENV_POP; } } +#ifdef PERL_FLEXIBLE_EXCEPTIONS STATIC void * -S_call_list_body(pTHX_ va_list args) +S_vcall_list_body(pTHX_ va_list args) { - dTHR; 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; @@ -3323,4 +3688,3 @@ read_e_script(pTHXo_ int idx, SV *buf_sv, int maxlen) sv_chop(PL_e_script, nl); return 1; } -