X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/abec5bedacd77b2152e61ec3216ab47bd7272fc9..8a1f10dd1e1964fa64cd0dff7196cf3f1f503ae1:/perl.c diff --git a/perl.c b/perl.c index 086645b..a7938bd 100644 --- a/perl.c +++ b/perl.c @@ -3,7 +3,7 @@ * * Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001 * 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012 - * by Larry Wall and others + * 2013, 2014, 2015, 2016 by Larry Wall and others * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -389,9 +389,10 @@ perl_construct(pTHXx) PL_XPosix_ptrs[_CC_VERTSPACE] = _new_invlist_C_array(VertSpace_invlist); PL_XPosix_ptrs[_CC_WORDCHAR] = _new_invlist_C_array(XPosixWord_invlist); PL_XPosix_ptrs[_CC_XDIGIT] = _new_invlist_C_array(XPosixXDigit_invlist); - PL_GCB_invlist = _new_invlist_C_array(Grapheme_Cluster_Break_invlist); - PL_SB_invlist = _new_invlist_C_array(Sentence_Break_invlist); - PL_WB_invlist = _new_invlist_C_array(Word_Break_invlist); + PL_GCB_invlist = _new_invlist_C_array(_Perl_GCB_invlist); + PL_SB_invlist = _new_invlist_C_array(_Perl_SB_invlist); + PL_WB_invlist = _new_invlist_C_array(_Perl_WB_invlist); + PL_LB_invlist = _new_invlist_C_array(_Perl_LB_invlist); ENTER; } @@ -1070,6 +1071,7 @@ perl_destruct(pTHXx) PL_XPosix_ptrs[i] = NULL; } PL_GCB_invlist = NULL; + PL_LB_invlist = NULL; PL_SB_invlist = NULL; PL_WB_invlist = NULL; @@ -1485,8 +1487,8 @@ perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env) const char * const s = PerlEnv_getenv("PERL_HASH_SEED_DEBUG"); if (s && strEQ(s, "1")) { - unsigned char *seed= PERL_HASH_SEED; - unsigned char *seed_end= PERL_HASH_SEED + PERL_HASH_SEED_BYTES; + const unsigned char *seed= PERL_HASH_SEED; + const unsigned char *seed_end= PERL_HASH_SEED + PERL_HASH_SEED_BYTES; PerlIO_printf(Perl_debug_log, "HASH_FUNCTION = %s HASH_SEED = 0x", PERL_HASH_FUNC); while (seed < seed_end) { PerlIO_printf(Perl_debug_log, "%02x", *seed++); @@ -1500,6 +1502,14 @@ perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env) } } #endif /* #if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT) */ + +#ifdef __amigaos4__ + { + struct NameTranslationInfo nti; + __translate_amiga_to_unix_path_name(&argv[0],&nti); + } +#endif + PL_origargc = argc; PL_origargv = argv; @@ -1692,6 +1702,9 @@ S_Internals_V(pTHX_ CV *cv) # ifdef PERL_BOOL_AS_CHAR " PERL_BOOL_AS_CHAR" # endif +# ifdef PERL_COPY_ON_WRITE + " PERL_COPY_ON_WRITE" +# endif # ifdef PERL_DISABLE_PMC " PERL_DISABLE_PMC" # endif @@ -1737,9 +1750,6 @@ S_Internals_V(pTHX_ CV *cv) # ifdef PERL_MEM_LOG_NOIMPL " PERL_MEM_LOG_NOIMPL" # endif -# ifdef PERL_NEW_COPY_ON_WRITE - " PERL_NEW_COPY_ON_WRITE" -# endif # ifdef PERL_PERTURB_KEYS_DETERMINISTIC " PERL_PERTURB_KEYS_DETERMINISTIC" # endif @@ -1779,6 +1789,9 @@ S_Internals_V(pTHX_ CV *cv) # ifdef USE_LOCALE_CTYPE " USE_LOCALE_CTYPE" # endif +# ifdef WIN32_NO_REGISTRY + " USE_NO_REGISTRY" +# endif # ifdef USE_PERL_ATOF " USE_PERL_ATOF" # endif @@ -1795,15 +1808,20 @@ S_Internals_V(pTHX_ CV *cv) PUSHs(Perl_newSVpvn_flags(aTHX_ non_bincompat_options, sizeof(non_bincompat_options) - 1, SVs_TEMP)); -#ifdef __DATE__ -# ifdef __TIME__ +#ifndef PERL_BUILD_DATE +# ifdef __DATE__ +# ifdef __TIME__ +# define PERL_BUILD_DATE __DATE__ " " __TIME__ +# else +# define PERL_BUILD_DATE __DATE__ +# endif +# endif +#endif + +#ifdef PERL_BUILD_DATE PUSHs(Perl_newSVpvn_flags(aTHX_ - STR_WITH_LEN("Compiled at " __DATE__ " " __TIME__), + STR_WITH_LEN("Compiled at " PERL_BUILD_DATE), SVs_TEMP)); -# else - PUSHs(Perl_newSVpvn_flags(aTHX_ STR_WITH_LEN("Compiled on " __DATE__), - SVs_TEMP)); -# endif #else PUSHs(&PL_sv_undef); #endif @@ -1833,7 +1851,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) int argc = PL_origargc; char **argv = PL_origargv; const char *scriptname = NULL; - VOL bool dosearch = FALSE; + bool dosearch = FALSE; char c; bool doextract = FALSE; const char *cddir = NULL; @@ -2515,7 +2533,7 @@ Perl_get_av(pTHX_ const char *name, I32 flags) Returns the HV of the specified Perl hash. C are passed to C. If C is set and the Perl variable does not exist then it will be created. If C is zero -and the variable does not exist then NULL is returned. +and the variable does not exist then C is returned. =cut */ @@ -2589,7 +2607,7 @@ Perl_get_cv(pTHX_ const char *name, I32 flags) =for apidoc p||call_argv Performs a callback to the specified named and package-scoped Perl subroutine -with C (a NULL-terminated array of strings) as arguments. See +with C (a C-terminated array of strings) as arguments. See L. Approximate Perl equivalent: C<&{"$sub_name"}(@$argv)>. @@ -2664,8 +2682,22 @@ Perl_call_method(pTHX_ const char *methname, I32 flags) /* =for apidoc p||call_sv -Performs a callback to the Perl sub whose name is in the SV. See -L. +Performs a callback to the Perl sub specified by the SV. + +If neither the C nor C flag is supplied, the +SV may be any of a CV, a GV, a reference to a CV, a reference to a GV +or C will be used as the name of the sub to call. + +If the C flag is supplied, the SV may be a reference to a CV or +C will be used as the name of the method to call. + +If the C flag is supplied, C will be used as +the name of the method to call. + +Some other values are treated specially for internal use and should +not be depended on. + +See L. =cut */ @@ -2674,12 +2706,11 @@ I32 Perl_call_sv(pTHX_ SV *sv, VOL I32 flags) /* See G_* flags in cop.h */ { - dVAR; dSP; + dVAR; LOGOP myop; /* fake syntax tree node */ METHOP method_op; I32 oldmark; VOL I32 retval = 0; - I32 oldscope; bool oldcatch = CATCH_GET; int ret; OP* const oldop = PL_op; @@ -2704,11 +2735,13 @@ Perl_call_sv(pTHX_ SV *sv, VOL I32 flags) SAVEOP(); PL_op = (OP*)&myop; - EXTEND(PL_stack_sp, 1); - if (!(flags & G_METHOD_NAMED)) - *++PL_stack_sp = sv; + if (!(flags & G_METHOD_NAMED)) { + dSP; + EXTEND(SP, 1); + PUSHs(sv); + PUTBACK; + } oldmark = TOPMARK; - oldscope = PL_scopestack_ix; if (PERLDB_SUB && PL_curstash != PL_debstash /* Handle first BEGIN of -d. */ @@ -2742,10 +2775,12 @@ Perl_call_sv(pTHX_ SV *sv, VOL I32 flags) CATCH_SET(oldcatch); } else { + I32 old_cxix; myop.op_other = (OP*)&myop; - PL_markstack_ptr--; + (void)POPMARK; + old_cxix = cxstack_ix; create_eval_scope(flags|G_FAKINGEVAL); - PL_markstack_ptr++; + (void)INCMARK; JMPENV_PUSH(ret); @@ -2785,8 +2820,13 @@ Perl_call_sv(pTHX_ SV *sv, VOL I32 flags) break; } - if (PL_scopestack_ix > oldscope) + /* if we croaked, depending on how we croaked the eval scope + * may or may not have already been popped */ + if (cxstack_ix > old_cxix) { + assert(cxstack_ix == old_cxix + 1); + assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL); delete_eval_scope(); + } JMPENV_POP; } @@ -2806,7 +2846,7 @@ Perl_call_sv(pTHX_ SV *sv, VOL I32 flags) =for apidoc p||eval_sv Tells Perl to C the string in the SV. It supports the same flags -as C, with the obvious exception of G_EVAL. See L. +as C, with the obvious exception of C. See L. =cut */ @@ -2817,9 +2857,8 @@ Perl_eval_sv(pTHX_ SV *sv, I32 flags) /* See G_* flags in cop.h */ { dVAR; - dSP; UNOP myop; /* fake syntax tree node */ - VOL I32 oldmark = SP - PL_stack_base; + VOL I32 oldmark; VOL I32 retval = 0; int ret; OP* const oldop = PL_op; @@ -2835,8 +2874,13 @@ Perl_eval_sv(pTHX_ SV *sv, I32 flags) SAVEOP(); PL_op = (OP*)&myop; Zero(&myop, 1, UNOP); - EXTEND(PL_stack_sp, 1); - *++PL_stack_sp = sv; + { + dSP; + oldmark = SP - PL_stack_base; + EXTEND(SP, 1); + PUSHs(sv); + PUTBACK; + } if (!(flags & G_NOARGS)) myop.op_flags = OPf_STACKED; @@ -3121,10 +3165,10 @@ Perl_moreswitches(pTHX_ const char *s) s--; } PL_rs = newSVpvs(""); - SvGROW(PL_rs, (STRLEN)(UNISKIP(rschar) + 1)); + SvGROW(PL_rs, (STRLEN)(UVCHR_SKIP(rschar) + 1)); tmps = (U8*)SvPVX(PL_rs); uvchr_to_utf8(tmps, rschar); - SvCUR_set(PL_rs, UNISKIP(rschar)); + SvCUR_set(PL_rs, UVCHR_SKIP(rschar)); SvUTF8_on(PL_rs); } else { @@ -3496,7 +3540,7 @@ S_minus_v(pTHX) #endif PerlIO_printf(PIO_stdout, - "\n\nCopyright 1987-2015, Larry Wall\n"); + "\n\nCopyright 1987-2016, Larry Wall\n"); #ifdef MSDOS PerlIO_printf(PIO_stdout, "\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n"); @@ -3746,7 +3790,7 @@ S_open_script(pTHX_ const char *scriptname, bool dosearch, bool *suidscript) const char * const err = "Failed to create a fake bit bucket"; if (strEQ(scriptname, BIT_BUCKET)) { #ifdef HAS_MKSTEMP /* Hopefully mkstemp() is safe here. */ - int old_umask = umask(0600); + int old_umask = umask(0177); int tmpfd = mkstemp(tmpname); umask(old_umask); if (tmpfd > -1) { @@ -3782,10 +3826,10 @@ S_open_script(pTHX_ const char *scriptname, bool dosearch, bool *suidscript) CopFILE(PL_curcop), Strerror(errno)); } fd = PerlIO_fileno(rsfp); -#if defined(HAS_FCNTL) && defined(F_SETFD) +#if defined(HAS_FCNTL) && defined(F_SETFD) && defined(FD_CLOEXEC) if (fd >= 0) { /* ensure close-on-exec */ - if (fcntl(fd, F_SETFD, 1) < 0) { + if (fcntl(fd, F_SETFD, FD_CLOEXEC) < 0) { Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n", CopFILE(PL_curcop), Strerror(errno)); } @@ -3826,16 +3870,13 @@ S_validate_suid(pTHX_ PerlIO *rsfp) if (my_euid != my_uid || my_egid != my_gid) { /* (suidperl doesn't exist, in fact) */ dVAR; int fd = PerlIO_fileno(rsfp); - if (fd < 0) { - Perl_croak(aTHX_ "Illegal suidscript"); - } else { - if (PerlLIO_fstat(fd, &PL_statbuf) < 0) { /* may be either wrapped or real suid */ - Perl_croak(aTHX_ "Illegal suidscript"); - } + Stat_t statbuf; + if (fd < 0 || PerlLIO_fstat(fd, &statbuf) < 0) { /* may be either wrapped or real suid */ + Perl_croak_nocontext( "Illegal suidscript"); } - if ((my_euid != my_uid && my_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID) + if ((my_euid != my_uid && my_euid == statbuf.st_uid && statbuf.st_mode & S_ISUID) || - (my_egid != my_gid && my_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID) + (my_egid != my_gid && my_egid == statbuf.st_gid && statbuf.st_mode & S_ISGID) ) if (!PL_do_undump) Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\ @@ -4350,12 +4391,12 @@ S_init_perllib(pTHX) */ char buf[256]; int idx = 0; - if (my_trnlnm("PERL5LIB",buf,0)) + if (vmstrnenv("PERL5LIB",buf,0,NULL,0)) do { incpush_use_sep(buf, 0, INCPUSH_ADD_SUB_DIRS); - } while (my_trnlnm("PERL5LIB",buf,++idx)); + } while (vmstrnenv("PERL5LIB",buf,++idx,NULL,0)); else { - while (my_trnlnm("PERLLIB",buf,idx++)) + while (vmstrnenv("PERLLIB",buf,idx++,NULL,0)) incpush_use_sep(buf, 0, 0); } #endif /* VMS */ @@ -4385,7 +4426,7 @@ S_init_perllib(pTHX) #ifdef SITELIB_EXP # if defined(WIN32) /* this picks up sitearch as well */ - s = win32_get_sitelib(PERL_FS_VERSION, &len); + s = PerlEnv_sitelib_path(PERL_FS_VERSION, &len); if (s) incpush_use_sep(s, len, INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE); # else @@ -4405,7 +4446,7 @@ S_init_perllib(pTHX) #ifdef PERL_VENDORLIB_EXP # if defined(WIN32) /* this picks up vendorarch as well */ - s = win32_get_vendorlib(PERL_FS_VERSION, &len); + s = PerlEnv_vendorlib_path(PERL_FS_VERSION, &len); if (s) incpush_use_sep(s, len, INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE); # else @@ -4423,7 +4464,7 @@ S_init_perllib(pTHX) #endif #if defined(WIN32) - s = win32_get_privlib(PERL_FS_VERSION, &len); + s = PerlEnv_lib_path(PERL_FS_VERSION, &len); if (s) incpush_use_sep(s, len, INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE); #else @@ -4461,11 +4502,11 @@ S_init_perllib(pTHX) */ char buf[256]; int idx = 0; - if (my_trnlnm("PERL5LIB",buf,0)) + if (vmstrnenv("PERL5LIB",buf,0,NULL,0)) do { incpush_use_sep(buf, 0, INCPUSH_ADD_OLD_VERS|INCPUSH_NOT_BASEDIR); - } while (my_trnlnm("PERL5LIB",buf,++idx)); + } while (vmstrnenv("PERL5LIB",buf,++idx,NULL,0)); #endif /* VMS */ } @@ -5066,7 +5107,7 @@ read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen) /* removes boilerplate code at the end of each boot_Module xsub */ void -Perl_xs_boot_epilog(pTHX_ const U32 ax) +Perl_xs_boot_epilog(pTHX_ const I32 ax) { if (PL_unitcheckav) call_list(PL_scopestack_ix, PL_unitcheckav);