X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=perl.c;h=e595a0a28951f6c81f96daaa22d8c8ad9e07c41d;hb=bfa0af6f4d529b278f8cb84f8526cffd75a4ff4d;hp=684fd80177c00af9c220f2b0d56177f55995c1f1;hpb=f05b5874edd1526b5a2b557cc1ffb6ad7552b85d;p=p5sagit%2Fp5-mst-13.2.git diff --git a/perl.c b/perl.c index 684fd80..e595a0a 100644 --- a/perl.c +++ b/perl.c @@ -985,7 +985,6 @@ perl_destruct(pTHXx) /* 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); @@ -1005,7 +1004,6 @@ perl_destruct(pTHXx) SvREFCNT_dec(PL_utf8_idstart); SvREFCNT_dec(PL_utf8_idcont); PL_utf8_alnum = NULL; - PL_utf8_alnumc = NULL; PL_utf8_ascii = NULL; PL_utf8_alpha = NULL; PL_utf8_space = NULL; @@ -1228,14 +1226,18 @@ perl_destruct(pTHXx) Safefree(PL_reg_poscache); free_tied_hv_pool(); Safefree(PL_op_mask); - Safefree(PL_psig_ptr); - PL_psig_ptr = (SV**)NULL; Safefree(PL_psig_name); PL_psig_name = (SV**)NULL; - Safefree(PL_bitcount); - PL_bitcount = NULL; + PL_psig_ptr = (SV**)NULL; Safefree(PL_psig_pend); PL_psig_pend = (int*)NULL; + { + /* We need to NULL PL_psig_pend first, so that + signal handlers know not to use it */ + int *psig_save = PL_psig_pend; + PL_psig_pend = (int*)NULL; + Safefree(psig_save); + } PL_formfeed = NULL; nuke_stacks(); PL_tainting = FALSE; @@ -1642,7 +1644,6 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) char **argv = PL_origargv; const char *scriptname = NULL; VOL bool dosearch = FALSE; - register SV *sv; register char c; const char *cddir = NULL; #ifdef USE_SITECUSTOMIZE @@ -1654,8 +1655,6 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) SvGROW(linestr_sv, 80); sv_setpvs(linestr_sv,""); - sv = newSVpvs(""); /* first used for -I flags */ - SAVEFREESV(sv); init_main_stash(); { @@ -1714,11 +1713,6 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) PL_minus_E = TRUE; /* FALL THROUGH */ case 'e': -#ifdef MACOS_TRADITIONAL - /* ignore -e for Dev:Pseudo argument */ - if (argv[1] && !strcmp(argv[1], "Dev:Pseudo")) - break; -#endif forbid_setid('e', FALSE); if (!PL_e_script) { PL_e_script = newSVpvs(""); @@ -1750,9 +1744,6 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) if (s && *s) { STRLEN len = strlen(s); incpush(s, len, INCPUSH_ADD_SUB_DIRS|INCPUSH_ADD_OLD_VERS); - sv_catpvs(sv, "-I"); - sv_catpvn(sv, s, len); - sv_catpvs(sv, " "); } else Perl_croak(aTHX_ "No directory specified for -I"); @@ -1777,26 +1768,23 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) # ifdef NO_MATHOMS " NO_MATHOMS" # endif +# ifdef PERL_DISABLE_PMC + " PERL_DISABLE_PMC" +# endif # ifdef PERL_DONT_CREATE_GVSV " PERL_DONT_CREATE_GVSV" # endif +# ifdef PERL_IS_MINIPERL + " PERL_IS_MINIPERL" +# endif # ifdef PERL_MALLOC_WRAP " PERL_MALLOC_WRAP" # endif # ifdef PERL_MEM_LOG " PERL_MEM_LOG" # endif -# ifdef PERL_MEM_LOG_ENV - " PERL_MEM_LOG_ENV" -# endif -# ifdef PERL_MEM_LOG_ENV_FD - " PERL_MEM_LOG_ENV_FD" -# endif -# ifdef PERL_MEM_LOG_STDERR - " PERL_MEM_LOG_STDERR" -# endif -# ifdef PERL_MEM_LOG_TIMESTAMP - " PERL_MEM_LOG_TIMESTAMP" +# ifdef PERL_MEM_LOG_NOIMPL + " PERL_MEM_LOG_NOIMPL" # endif # ifdef PERL_USE_DEVEL " PERL_USE_DEVEL" @@ -1929,7 +1917,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) d = s; if (!*s) break; - if (!strchr("CDIMUdmtw", *s)) + if (!strchr("CDIMUdmtwW", *s)) Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s); while (++s && *s) { if (isSPACE(*s)) { @@ -1955,10 +1943,15 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) } } -#ifdef USE_SITECUSTOMIZE +#if defined(USE_SITECUSTOMIZE) && !defined(PERL_IS_MINIPERL) if (!minus_f) { + /* SITELIB_EXP is a function call on Win32. + The games with local $! are to avoid setting errno if there is no + sitecustomize script. */ + const char *const sitelib = SITELIB_EXP; (void)Perl_av_create_and_unshift_one(aTHX_ &PL_preambleav, - Perl_newSVpvf(aTHX_ "BEGIN { do '%s/sitecustomize.pl' }", SITELIB_EXP)); + Perl_newSVpvf(aTHX_ + "BEGIN { do {local $!; -f '%s/sitecustomize.pl'} && do '%s/sitecustomize.pl' }", sitelib, sitelib)); } #endif @@ -2008,11 +2001,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) # endif #endif - if (PL_doextract -#ifdef MACOS_TRADITIONAL - || gMacPerl_AlwaysExtract -#endif - ) { + if (PL_doextract) { /* This will croak if suidscript is true, as -x cannot be used with setuid scripts. */ @@ -2034,7 +2023,6 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) boot_core_PerlIO(); boot_core_UNIVERSAL(); - boot_core_xsutils(); boot_core_mro(); if (xsinit) @@ -2067,6 +2055,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) #if defined(__SYMBIAN32__) PL_unicode = PERL_UNICODE_STD_FLAG; /* See PERL_SYMBIAN_CONSOLE_UTF8. */ #endif +# ifndef PERL_IS_MINIPERL if (PL_unicode) { /* Requires init_predump_symbols(). */ if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) { @@ -2105,6 +2094,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) } } } +#endif { const char *s; @@ -2153,16 +2143,6 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) /* now parse the script */ SETERRNO(0,SS_NORMAL); -#ifdef MACOS_TRADITIONAL - if (gMacPerl_SyntaxError = (yyparse() || PL_parser->error_count)) { - if (PL_minus_c) - Perl_croak(aTHX_ "%s had compilation errors.\n", MacPerl_MPWFileName(PL_origfilename)); - else { - Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n", - MacPerl_MPWFileName(PL_origfilename)); - } - } -#else if (yyparse() || PL_parser->error_count) { if (PL_minus_c) Perl_croak(aTHX_ "%s had compilation errors.\n", PL_origfilename); @@ -2171,7 +2151,6 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) PL_origfilename); } } -#endif CopLINE_set(PL_curcop, 0); PL_curstash = PL_defstash; if (PL_e_script) { @@ -2282,20 +2261,15 @@ S_run_body(pTHX_ I32 oldscope) exit(0); /* less likely to core dump than my_exit(0) */ } #endif - DEBUG_x(dump_all()); #ifdef DEBUGGING + if (DEBUG_x_TEST || DEBUG_B_TEST) + dump_all_perl(!DEBUG_B_TEST); if (!DEBUG_q_TEST) PERL_DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n")); #endif if (PL_minus_c) { -#ifdef MACOS_TRADITIONAL - PerlIO_printf(Perl_error_log, "%s%s syntax OK\n", - (gMacPerl_ErrorFormat ? "# " : ""), - MacPerl_MPWFileName(PL_origfilename)); -#else PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename); -#endif my_exit(0); } if (PERLDB_SINGLE && PL_DBsingle) @@ -2519,9 +2493,13 @@ Perl_call_method(pTHX_ const char *methname, I32 flags) /* name of the subroutine */ /* See G_* flags in cop.h */ { + STRLEN len; PERL_ARGS_ASSERT_CALL_METHOD; - return call_sv(sv_2mortal(newSVpv(methname,0)), flags | G_METHOD); + len = strlen(methname); + + /* XXX: sv_2mortal(newSVpvn_share(methname, len)) can be faster */ + return call_sv(newSVpvn_flags(methname, len, SVs_TEMP), flags | G_METHOD); } /* May be called with any of a CV, a GV, or an SV containing the name. */ @@ -2898,6 +2876,8 @@ Perl_get_debug_opts(pTHX_ const char **s, bool givehelp) " C Copy On Write", " A Consistency checks on internal structures", " q quiet - currently only suppresses the 'EXECUTING' message", + " M trace smart match resolution", + " B dump suBroutine definitions, including special Blocks like BEGIN", NULL }; int i = 0; @@ -2906,7 +2886,7 @@ Perl_get_debug_opts(pTHX_ const char **s, bool givehelp) if (isALPHA(**s)) { /* if adding extra options, remember to update DEBUG_MASK */ - static const char debopts[] = "psltocPmfrxuUHXDSTRJvCAq"; + static const char debopts[] = "psltocPmfrxuUHXDSTRJvCAqMB"; for (; isALNUM(**s); (*s)++) { const char * const d = strchr(debopts,**s); @@ -3209,9 +3189,6 @@ Perl_moreswitches(pTHX_ const 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; @@ -3270,11 +3247,6 @@ Perl_moreswitches(pTHX_ const char *s) PerlIO_printf(PerlIO_stdout(), "\n\nCopyright 1987-2009, Larry Wall\n"); -#ifdef MACOS_TRADITIONAL - PerlIO_printf(PerlIO_stdout(), - "\nMac OS port Copyright 1991-2002, Matthias Neeracher;\n" - "maintained by Chris Nandor\n"); -#endif #ifdef MSDOS PerlIO_printf(PerlIO_stdout(), "\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n"); @@ -3317,10 +3289,6 @@ Perl_moreswitches(pTHX_ const char *s) PerlIO_printf(PerlIO_stdout(), "BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n"); #endif -#ifdef __MINT__ - PerlIO_printf(PerlIO_stdout(), - "MiNT port by Guido Flohr, 1997-1999\n"); -#endif #ifdef EPOC PerlIO_printf(PerlIO_stdout(), "EPOC port by Olaf Flebbe, 1999-2002\n"); @@ -3671,38 +3639,14 @@ S_find_beginning(pTHX_ SV* linestr_sv, PerlIO *rsfp) dVAR; const char *s; register const char *s2; -#ifdef MACOS_TRADITIONAL - int maclines = 0; -#endif PERL_ARGS_ASSERT_FIND_BEGINNING; /* skip forward in input to the real script? */ -#ifdef MACOS_TRADITIONAL - /* Since the Mac OS does not honor #! arguments for us, we do it ourselves */ - - while (PL_doextract || gMacPerl_AlwaysExtract) { - if ((s = sv_gets(linestr_sv, rsfp, 0)) == NULL) { - if (!gMacPerl_AlwaysExtract) - Perl_croak(aTHX_ "No Perl script found in input\n"); - - if (PL_doextract) /* require explicit override ? */ - if (!OverrideExtract(PL_origfilename)) - Perl_croak(aTHX_ "User aborted script\n"); - else - PL_doextract = FALSE; - - /* Pater peccavi, file does not have #! */ - PerlIO_rewind(rsfp); - - break; - } -#else while (PL_doextract) { if ((s = sv_gets(linestr_sv, rsfp, 0)) == NULL) Perl_croak(aTHX_ "No Perl script found in input\n"); -#endif s2 = s; if (*s == '#' && s[1] == '!' && ((s = instr(s,"perl")) || (s = instr(s2,"PERL")))) { PerlIO_ungetc(rsfp, '\n'); /* to keep line count right */ @@ -3717,20 +3661,6 @@ S_find_beginning(pTHX_ SV* linestr_sv, PerlIO *rsfp) while ((s = moreswitches(s))) ; } -#ifdef MACOS_TRADITIONAL - /* We are always searching for the #!perl line in MacPerl, - * so if we find it, still keep the line count correct - * by counting lines we already skipped over - */ - for (; maclines > 0 ; maclines--) - PerlIO_ungetc(rsfp, '\n'); - - break; - - /* gMacPerl_AlwaysExtract is false in MPW tool */ - } else if (gMacPerl_AlwaysExtract) { - ++maclines; -#endif } } } @@ -4016,17 +3946,7 @@ S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register init_argv_symbols(argc,argv); if ((tmpgv = gv_fetchpvs("0", GV_ADD|GV_NOTQUAL, SVt_PV))) { -#ifdef MACOS_TRADITIONAL - /* $0 is not majick on a Mac */ - sv_setpv(GvSV(tmpgv),MacPerl_MPWFileName(PL_origfilename)); -#else sv_setpv(GvSV(tmpgv),PL_origfilename); - { - GV * const gv = gv_fetchpv("0", GV_ADD, SVt_PV); - if (gv) - sv_magic(GvSV(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, "0", 1); - } -#endif } if ((PL_envgv = gv_fetchpvs("ENV", GV_ADD|GV_NOTQUAL, SVt_PVHV))) { HV *hv; @@ -4140,6 +4060,10 @@ S_init_perllib(pTHX) #endif /* VMS */ } +#ifndef PERL_IS_MINIPERL + /* miniperl gets just -I..., the split of $ENV{PERL5LIB}, and "." in @INC + (and not the architecture specific directories from $ENV{PERL5LIB}) */ + /* Use the ~-expanded versions of APPLLIB (undocumented), ARCHLIB PRIVLIB SITEARCH SITELIB VENDORARCH and VENDORLIB */ @@ -4148,33 +4072,6 @@ S_init_perllib(pTHX) INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE); #endif -#ifdef MACOS_TRADITIONAL - { - Stat_t tmpstatbuf; - SV * privdir = newSV(0); - char * macperl = PerlEnv_getenv("MACPERL"); - - if (!macperl) - macperl = ""; - -# ifdef ARCHLIB_EXP - S_incpush_use_sep(aTHX_ STR_WITH_LEN(ARCHLIB_EXP), INCPUSH_CAN_RELOCATE); -# endif - - Perl_sv_setpvf(aTHX_ privdir, "%slib:", macperl); - if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode)) - incpush_use_sep(SvPVX(privdir), SvCUR(privdir), - INCPUSH_ADD_SUB_DIRS); - Perl_sv_setpvf(aTHX_ privdir, "%ssite_perl:", macperl); - if (PerlLIO_stat(SvPVX(privdir), SvCUR(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode)) - incpush_use_sep(SvPVX(privdir), SvCUR(privdir), - INCPUSH_ADD_SUB_DIRS); - - SvREFCNT_dec(privdir); - if (!PL_tainting) - S_incpush(aTHX_ STR_WITH_LEN(":"), 0); - } -#else #ifdef SITEARCH_EXP /* sitearch is always relative to sitelib on Windows for * DLL-based path intuition to work correctly */ @@ -4241,7 +4138,6 @@ S_init_perllib(pTHX) INCPUSH_ADD_VERSIONED_SUB_DIRS|INCPUSH_NOT_BASEDIR |INCPUSH_CAN_RELOCATE); #endif -#endif /* MACOS_TRADITIONAL */ if (!PL_tainting) { #ifndef VMS @@ -4280,7 +4176,6 @@ S_init_perllib(pTHX) |INCPUSH_NOT_BASEDIR|INCPUSH_CAN_RELOCATE); #endif -#ifndef MACOS_TRADITIONAL #if defined(SITELIB_STEM) && defined(PERL_INC_VERSION_LIST) /* Search for version-specific dirs below here */ S_incpush_use_sep(aTHX_ STR_WITH_LEN(SITELIB_STEM), @@ -4299,10 +4194,10 @@ S_init_perllib(pTHX) INCPUSH_ADD_OLD_VERS|INCPUSH_ADD_ARCHONLY_SUB_DIRS |INCPUSH_CAN_RELOCATE); #endif +#endif /* !PERL_IS_MINIPERL */ if (!PL_tainting) S_incpush(aTHX_ STR_WITH_LEN("."), 0); -#endif /* MACOS_TRADITIONAL */ } #if defined(DOSISH) || defined(EPOC) || defined(__SYMBIAN32__) @@ -4311,11 +4206,7 @@ S_init_perllib(pTHX) # if defined(VMS) # define PERLLIB_SEP '|' # else -# if defined(MACOS_TRADITIONAL) -# define PERLLIB_SEP ',' -# else -# define PERLLIB_SEP ':' -# endif +# define PERLLIB_SEP ':' # endif #endif #ifndef PERLLIB_MANGLE @@ -4355,7 +4246,9 @@ S_incpush(pTHX_ const char *const dir, STRLEN len, U32 flags) = (U8)flags & INCPUSH_ADD_VERSIONED_SUB_DIRS; const U8 add_archonly_sub_dirs = (U8)flags & INCPUSH_ADD_ARCHONLY_SUB_DIRS; +#ifdef PERL_INC_VERSION_LIST const U8 addoldvers = (U8)flags & INCPUSH_ADD_OLD_VERS; +#endif const U8 canrelocate = (U8)flags & INCPUSH_CAN_RELOCATE; const U8 unshift = (U8)flags & INCPUSH_UNSHIFT; const U8 push_basedir = (flags & INCPUSH_NOT_BASEDIR) ? 0 : 1; @@ -4388,16 +4281,6 @@ S_incpush(pTHX_ const char *const dir, STRLEN len, U32 flags) libdir = newSVpv(PERLLIB_MANGLE(dir, 0), 0); } -#ifdef MACOS_TRADITIONAL - if (!strchr(SvPVX(libdir), ':')) { - char buf[256]; - - sv_setpv(libdir, MacPerl_CanonDir(SvPVX(libdir), buf, 0)); - } - if (SvPVX(libdir)[SvCUR(libdir)-1] != ':') - sv_catpvs(libdir, ":"); -#endif - /* Do the if() outside the #ifdef to avoid warnings about an unused parameter. */ if (canrelocate) { @@ -4527,22 +4410,12 @@ S_incpush(pTHX_ const char *const dir, STRLEN len, U32 flags) subdir = newSVsv(libdir); if (add_versioned_sub_dirs) { -#ifdef MACOS_TRADITIONAL -#define PERL_ARCH_FMT_PREFIX "" -#define PERL_ARCH_FMT_SUFFIX ":" -#define PERL_ARCH_FMT_PATH PERL_FS_VERSION "" -#else -#define PERL_ARCH_FMT_PREFIX "/" -#define PERL_ARCH_FMT_SUFFIX "" -#define PERL_ARCH_FMT_PATH "/" PERL_FS_VERSION -#endif /* .../version/archname if -d .../version/archname */ - sv_catpvs(subdir, PERL_ARCH_FMT_PATH \ - PERL_ARCH_FMT_PREFIX ARCHNAME PERL_ARCH_FMT_SUFFIX); + sv_catpvs(subdir, "/" PERL_FS_VERSION "/" ARCHNAME); subdir = S_incpush_if_exists(aTHX_ av, subdir, libdir); /* .../version if -d .../version */ - sv_catpvs(subdir, PERL_ARCH_FMT_PATH); + sv_catpvs(subdir, "/" PERL_FS_VERSION); subdir = S_incpush_if_exists(aTHX_ av, subdir, libdir); } @@ -4550,8 +4423,7 @@ S_incpush(pTHX_ const char *const dir, STRLEN len, U32 flags) if (addoldvers) { for (incver = incverlist; *incver; incver++) { /* .../xxx if -d .../xxx */ - Perl_sv_catpvf(aTHX_ subdir, PERL_ARCH_FMT_PREFIX \ - "%s" PERL_ARCH_FMT_SUFFIX, *incver); + Perl_sv_catpvf(aTHX_ subdir, "/%s", *incver); subdir = S_incpush_if_exists(aTHX_ av, subdir, libdir); } } @@ -4559,8 +4431,7 @@ S_incpush(pTHX_ const char *const dir, STRLEN len, U32 flags) if (add_archonly_sub_dirs) { /* .../archname if -d .../archname */ - sv_catpvs(subdir, - PERL_ARCH_FMT_PREFIX ARCHNAME PERL_ARCH_FMT_SUFFIX); + sv_catpvs(subdir, "/" ARCHNAME); subdir = S_incpush_if_exists(aTHX_ av, subdir, libdir); }