X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/739a0b843246478d33d6b9205abb19e5492a5807..3ecd756934919b7d8847ae01fd8fc9d35ca96a84:/perl.c?ds=sidebyside diff --git a/perl.c b/perl.c index 63de43e..e9549d5 100644 --- a/perl.c +++ b/perl.c @@ -58,10 +58,6 @@ union control_un { #endif -#ifdef __BEOS__ -# define HZ 1000000 -#endif - #ifndef HZ # ifdef CLK_TCK # define HZ CLK_TCK @@ -245,7 +241,7 @@ perl_construct(pTHXx) init_constants(); SvREADONLY_on(&PL_sv_placeholder); - SvREFCNT(&PL_sv_placeholder) = (~(U32)0)/2; + SvREFCNT(&PL_sv_placeholder) = SvREFCNT_IMMORTAL; PL_sighandlerp = (Sighandler_t) Perl_sighandler; #ifdef PERL_USES_PL_PIDSTATUS @@ -325,10 +321,9 @@ perl_construct(pTHXx) /* Use sysconf(_SC_CLK_TCK) if available, if not * available or if the sysconf() fails, use the HZ. - * BeOS has those, but returns the wrong value. * The HZ if not originally defined has been by now * been defined as CLK_TCK, if available. */ -#if defined(HAS_SYSCONF) && defined(_SC_CLK_TCK) && !defined(__BEOS__) +#if defined(HAS_SYSCONF) && defined(_SC_CLK_TCK) PL_clocktick = sysconf(_SC_CLK_TCK); if (PL_clocktick <= 0) #endif @@ -523,6 +518,7 @@ perl_destruct(pTHXx) #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP pid_t child; #endif + int i; PERL_ARGS_ASSERT_PERL_DESTRUCT; #ifndef MULTIPLICITY @@ -762,15 +758,12 @@ perl_destruct(pTHXx) PerlIO_destruct(aTHX); - if (PL_sv_objcount) { - /* - * Try to destruct global references. We do this first so that the - * destructors and destructees still exist. Some sv's might remain. - * Non-referenced objects are on their own. - */ - sv_clean_objs(); - PL_sv_objcount = 0; - } + /* + * Try to destruct global references. We do this first so that the + * destructors and destructees still exist. Some sv's might remain. + * Non-referenced objects are on their own. + */ + sv_clean_objs(); /* unhook hooks which will soon be, or use, destroyed data */ SvREFCNT_dec(PL_warnhook); @@ -845,7 +838,6 @@ perl_destruct(pTHXx) ary[i] = &PL_sv_undef; } } - Safefree(PL_stashpad); #endif @@ -873,7 +865,9 @@ perl_destruct(pTHXx) PL_minus_F = FALSE; PL_doswitches = FALSE; PL_dowarn = G_WARN_OFF; +#ifdef PERL_SAWAMPERSAND PL_sawampersand = 0; /* must save all match strings */ +#endif PL_unsafe = FALSE; Safefree(PL_inplace); @@ -984,18 +978,11 @@ perl_destruct(pTHXx) PL_numeric_radix_sv = NULL; #endif - /* clear utf8 character classes */ - SvREFCNT_dec(PL_utf8_alnum); - SvREFCNT_dec(PL_utf8_alpha); - SvREFCNT_dec(PL_utf8_blank); - SvREFCNT_dec(PL_utf8_space); - 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); + /* clear character classes */ + for (i = 0; i < POSIX_SWASH_COUNT; i++) { + SvREFCNT_dec(PL_utf8_swash_ptrs[i]); + PL_utf8_swash_ptrs[i] = NULL; + } SvREFCNT_dec(PL_utf8_mark); SvREFCNT_dec(PL_utf8_toupper); SvREFCNT_dec(PL_utf8_totitle); @@ -1004,17 +991,6 @@ perl_destruct(pTHXx) SvREFCNT_dec(PL_utf8_idstart); SvREFCNT_dec(PL_utf8_idcont); SvREFCNT_dec(PL_utf8_foldclosures); - PL_utf8_alnum = NULL; - PL_utf8_alpha = NULL; - PL_utf8_blank = NULL; - PL_utf8_space = NULL; - PL_utf8_graph = NULL; - PL_utf8_digit = NULL; - PL_utf8_upper = NULL; - PL_utf8_lower = NULL; - PL_utf8_print = NULL; - PL_utf8_punct = NULL; - PL_utf8_xdigit = NULL; PL_utf8_mark = NULL; PL_utf8_toupper = NULL; PL_utf8_totitle = NULL; @@ -1023,6 +999,16 @@ perl_destruct(pTHXx) PL_utf8_idstart = NULL; PL_utf8_idcont = NULL; PL_utf8_foldclosures = NULL; + for (i = 0; i < POSIX_CC_COUNT; i++) { + SvREFCNT_dec(PL_Posix_ptrs[i]); + PL_Posix_ptrs[i] = NULL; + + SvREFCNT_dec(PL_L1Posix_ptrs[i]); + PL_L1Posix_ptrs[i] = NULL; + + SvREFCNT_dec(PL_XPosix_ptrs[i]); + PL_XPosix_ptrs[i] = NULL; + } if (!specialWARN(PL_compiling.cop_warnings)) PerlMemShared_free(PL_compiling.cop_warnings); @@ -1083,6 +1069,10 @@ perl_destruct(pTHXx) while (sv_clean_all() > 2) ; +#ifdef USE_ITHREADS + Safefree(PL_stashpad); /* must come after sv_clean_all */ +#endif + AvREAL_off(PL_fdpid); /* no surviving entries */ SvREFCNT_dec(PL_fdpid); /* needed in io_close() */ PL_fdpid = NULL; @@ -2259,8 +2249,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) #endif lex_start(linestr_sv, rsfp, lex_start_flags); - if(linestr_sv) - SvREFCNT_dec(linestr_sv); + SvREFCNT_dec(linestr_sv); PL_subname = newSVpvs("main"); @@ -2580,7 +2569,7 @@ Approximate Perl equivalent: C<&{"$sub_name"}(@$argv)>. */ I32 -Perl_call_argv(pTHX_ const char *sub_name, I32 flags, register char **argv) +Perl_call_argv(pTHX_ const char *sub_name, I32 flags, char **argv) /* See G_* flags in cop.h */ /* null terminated arg list */ @@ -2892,7 +2881,6 @@ SV* Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error) { dVAR; - dSP; SV* sv = newSVpv(p, 0); PERL_ARGS_ASSERT_EVAL_PV; @@ -2900,12 +2888,18 @@ Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error) eval_sv(sv, G_SCALAR); SvREFCNT_dec(sv); - SPAGAIN; - sv = POPs; - PUTBACK; + { + dSP; + sv = POPs; + PUTBACK; + } - if (croak_on_error && SvTRUE(ERRSV)) { - Perl_croak(aTHX_ "%s", SvPVx_nolen_const(ERRSV)); + /* just check empty string or undef? */ + if (croak_on_error) { + SV * const errsv = ERRSV; + if(SvTRUE_NN(errsv)) + /* replace with croak_sv? */ + Perl_croak_nocontext("%s", SvPV_nolen_const(errsv)); } return sv; @@ -3037,7 +3031,7 @@ Perl_get_debug_opts(pTHX_ const char **s, bool givehelp) /* if adding extra options, remember to update DEBUG_MASK */ static const char debopts[] = "psltocPmfrxuUHXDSTRJvCAqMB"; - for (; isALNUM(**s); (*s)++) { + for (; isWORDCHAR(**s); (*s)++) { const char * const d = strchr(debopts,**s); if (d) i |= 1 << (d - debopts); @@ -3048,7 +3042,7 @@ Perl_get_debug_opts(pTHX_ const char **s, bool givehelp) } else if (isDIGIT(**s)) { i = atoi(*s); - for (; isALNUM(**s); (*s)++) ; + for (; isWORDCHAR(**s); (*s)++) ; } else if (givehelp) { const char *const *p = usage_msgd; @@ -3142,7 +3136,7 @@ Perl_moreswitches(pTHX_ const char *s) s++; /* -dt indicates to the debugger that threads will be used */ - if (*s == 't' && !isALNUM(s[1])) { + if (*s == 't' && !isWORDCHAR(s[1])) { ++s; my_setenv("PERL5DB_THREADED", "1"); } @@ -3165,7 +3159,7 @@ Perl_moreswitches(pTHX_ const char *s) end = s + strlen(s); /* We now allow -d:Module=Foo,Bar and -d:-Module */ - while(isALNUM(*s) || *s==':') ++s; + while(isWORDCHAR(*s) || *s==':') ++s; if (*s != '=') sv_catpvn(sv, start, end - start); else { @@ -3193,7 +3187,7 @@ Perl_moreswitches(pTHX_ const char *s) if (ckWARN_d(WARN_DEBUGGING)) Perl_warner(aTHX_ packWARN(WARN_DEBUGGING), "Recompile perl with -DDEBUGGING to use -D switch (did you mean -d ?)\n"); - for (s++; isALNUM(*s); s++) ; + for (s++; isWORDCHAR(*s); s++) ; #endif return s; } @@ -3286,7 +3280,7 @@ Perl_moreswitches(pTHX_ const char *s) sv = newSVpvn(use,4); start = s; /* We allow -M'Module qw(Foo Bar)' */ - while(isALNUM(*s) || *s==':') { + while(isWORDCHAR(*s) || *s==':') { if( *s++ == ':' ) { if( *s == ':' ) s++; @@ -3474,7 +3468,7 @@ S_minus_v(pTHX) #endif PerlIO_printf(PIO_stdout, - "\n\nCopyright 1987-2012, Larry Wall\n"); + "\n\nCopyright 1987-2013, Larry Wall\n"); #ifdef MSDOS PerlIO_printf(PIO_stdout, "\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n"); @@ -3489,10 +3483,6 @@ S_minus_v(pTHX) "\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n" "Version 5 port Copyright (c) 1994-2002, Andreas Kaiser, Ilya Zakharevich\n"); #endif -#ifdef __BEOS__ - PerlIO_printf(PIO_stdout, - "BeOS port Copyright Tom Spindler, 1997-1999\n"); -#endif #ifdef OEMVS PerlIO_printf(PIO_stdout, "MVS (OS390) port by Mortice Kern Systems, 1997-1999\n"); @@ -3656,6 +3646,7 @@ S_open_script(pTHX_ const char *scriptname, bool dosearch, bool *suidscript) int fdscript = -1; PerlIO *rsfp = NULL; dVAR; + Stat_t tmpstatbuf; PERL_ARGS_ASSERT_OPEN_SCRIPT; @@ -3765,6 +3756,13 @@ S_open_script(pTHX_ const char *scriptname, bool dosearch, bool *suidscript) /* ensure close-on-exec */ fcntl(PerlIO_fileno(rsfp), F_SETFD, 1); #endif + + if (PerlLIO_fstat(PerlIO_fileno(rsfp), &tmpstatbuf) >= 0 + && S_ISDIR(tmpstatbuf.st_mode)) + Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n", + CopFILE(PL_curcop), + strerror(EISDIR)); + return rsfp; } @@ -4132,7 +4130,7 @@ S_init_predump_symbols(pTHX) } void -Perl_init_argv_symbols(pTHX_ register int argc, register char **argv) +Perl_init_argv_symbols(pTHX_ int argc, char **argv) { dVAR; @@ -4180,7 +4178,7 @@ Perl_init_argv_symbols(pTHX_ register int argc, register char **argv) } STATIC void -S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env) +S_init_postdump_symbols(pTHX_ int argc, char **argv, char **env) { dVAR; GV* tmpgv; @@ -4490,16 +4488,12 @@ S_mayberelocate(pTHX_ const char *const dir, STRLEN len, U32 flags) PERL_ARGS_ASSERT_MAYBERELOCATE; assert(len > 0); - if (len) { - /* I am not convinced that this is valid when PERLLIB_MANGLE is - defined to so something (in os2/os2.c), but the code has been - this way, ignoring any possible changed of length, since - 760ac839baf413929cd31cc32ffd6dba6b781a81 (5.003_02) so I'll leave - it be. */ - libdir = newSVpvn(PERLLIB_MANGLE(dir, len), len); - } else { - libdir = newSVpv(PERLLIB_MANGLE(dir, 0), 0); - } + /* I am not convinced that this is valid when PERLLIB_MANGLE is + defined to so something (in os2/os2.c), but the code has been + this way, ignoring any possible changed of length, since + 760ac839baf413929cd31cc32ffd6dba6b781a81 (5.003_02) so I'll leave + it be. */ + libdir = newSVpvn(PERLLIB_MANGLE(dir, len), len); #ifdef VMS {