X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=perl.c;h=ff851b441782c779781faefa1d8459017b8d773c;hb=765e9edb2de192ef033766d867f9bd290e9935e9;hp=715f4da4ae59fd73cc2877d17a1fe08f197672e0;hpb=534825c439e9bf017f3cdaf88d284d58d5eac6bd;p=p5sagit%2Fp5-mst-13.2.git diff --git a/perl.c b/perl.c index 715f4da..ff851b4 100644 --- a/perl.c +++ b/perl.c @@ -276,6 +276,7 @@ perl_construct(pTHXx) PL_fdpid = newAV(); /* for remembering popen pids by fd */ PL_modglobal = newHV(); /* pointers to per-interpreter module globals */ + PL_errors = newSVpvn("",0); ENTER; } @@ -683,12 +684,12 @@ perl_destruct(pTHXx) SvREFCNT(&PL_sv_yes) = 0; sv_clear(&PL_sv_yes); SvANY(&PL_sv_yes) = NULL; - SvREADONLY_off(&PL_sv_yes); + SvFLAGS(&PL_sv_yes) = 0; SvREFCNT(&PL_sv_no) = 0; sv_clear(&PL_sv_no); SvANY(&PL_sv_no) = NULL; - SvREADONLY_off(&PL_sv_no); + SvFLAGS(&PL_sv_no) = 0; SvREFCNT(&PL_sv_undef) = 0; SvREADONLY_off(&PL_sv_undef); @@ -764,7 +765,13 @@ perl_free(pTHXx) #if defined(PERL_OBJECT) PerlMem_free(this); #else +# 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 } @@ -1645,7 +1652,7 @@ Perl_call_sv(pTHX_ 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. */ @@ -1977,6 +1984,7 @@ Perl_moreswitches(pTHX_ char *s) case '0': { dTHR; + numlen = 0; /* disallow underscores */ rschar = (U32)scan_oct(s, 4, &numlen); SvREFCNT_dec(PL_nrs); if (rschar & ~((U8)~0)) @@ -2092,6 +2100,7 @@ Perl_moreswitches(pTHX_ char *s) if (isDIGIT(*s)) { PL_ors = savepv("\n"); PL_orslen = 1; + numlen = 0; /* disallow underscores */ *PL_ors = (char)scan_oct(s, 3 + (*s == '0'), &numlen); s += numlen; } @@ -2129,6 +2138,9 @@ Perl_moreswitches(pTHX_ char *s) sv_catpv( sv, " ()"); } } else { + if (s == start) + Perl_croak(aTHX_ "Module name required with -%c option", + s[-1]); sv_catpvn(sv, start, s-start); sv_catpv(sv, " split(/,/,q{"); sv_catpv(sv, ++s); @@ -2233,12 +2245,12 @@ Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n"); return s; case 'W': PL_dowarn = G_WARN_ALL_ON|G_WARN_ON; - PL_compiling.cop_warnings = WARN_ALL ; + PL_compiling.cop_warnings = pWARN_ALL ; s++; return s; case 'X': PL_dowarn = G_WARN_ALL_OFF; - PL_compiling.cop_warnings = WARN_NONE ; + PL_compiling.cop_warnings = pWARN_NONE ; s++; return s; case '*': @@ -2419,6 +2431,7 @@ S_init_main_stash(pTHX) 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)); + PL_nullstash = GvHV(gv_fetchpv("::", GV_ADDMULTI, SVt_PVHV)); /* We must init $/ before switches are processed. */ sv_setpvn(get_sv("/", TRUE), "\n", 1); } @@ -2602,72 +2615,85 @@ S_fd_on_nosuid_fs(pTHX_ int fd) * an irrelevant filesystem while trying to reach the right one. */ -# ifdef HAS_FSTATVFS +#undef FD_ON_NOSUID_CHECK_OKAY /* found the syscalls to do the check? */ + +# if !defined(FD_ON_NOSUID_CHECK_OKAY) && \ + defined(HAS_FSTATVFS) +# define FD_ON_NOSUID_CHECK_OKAY struct statvfs stfs; + check_okay = fstatvfs(fd, &stfs) == 0; on_nosuid = check_okay && (stfs.f_flag & ST_NOSUID); -# else -# ifdef PERL_MOUNT_NOSUID -# if defined(HAS_FSTATFS) && \ - defined(HAS_STRUCT_STATFS) && \ - defined(HAS_STRUCT_STATFS_F_FLAGS) +# endif /* fstatvfs */ + +# if !defined(FD_ON_NOSUID_CHECK_OKAY) && \ + defined(PERL_MOUNT_NOSUID) && \ + defined(HAS_FSTATFS) && \ + defined(HAS_STRUCT_STATFS) && \ + defined(HAS_STRUCT_STATFS_F_FLAGS) +# define FD_ON_NOSUID_CHECK_OKAY struct statfs stfs; + check_okay = fstatfs(fd, &stfs) == 0; on_nosuid = check_okay && (stfs.f_flags & PERL_MOUNT_NOSUID); -# else -# if defined(HAS_FSTAT) && \ - defined(HAS_USTAT) && \ - defined(HAS_GETMNT) && \ - defined(HAS_STRUCT_FS_DATA) && \ - defined(NOSTAT_ONE) +# endif /* fstatfs */ + +# if !defined(FD_ON_NOSUID_CHECK_OKAY) && \ + defined(PERL_MOUNT_NOSUID) && \ + defined(HAS_FSTAT) && \ + defined(HAS_USTAT) && \ + defined(HAS_GETMNT) && \ + defined(HAS_STRUCT_FS_DATA) && \ + defined(NOSTAT_ONE) +# define FD_ON_NOSUID_CHECK_OKAY 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. */ + 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) - FILE *mtab = fopen("/etc/mtab", "r"); - struct mntent *entry; - struct stat stb, fsb; + 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 */ + +# if !defined(FD_ON_NOSUID_CHECK_OKAY) && \ + defined(HAS_GETMNTENT) && \ + defined(HAS_HASMNTOPT) && \ + defined(MNTOPT_NOSUID) +# define FD_ON_NOSUID_CHECK_OKAY + FILE *mtab = fopen("/etc/mtab", "r"); + struct mntent *entry; + struct stat stb, fsb; if (mtab && (fstat(fd, &stb) == 0)) { - while (entry = getmntent(mtab)) { - if (stat(entry->mnt_dir, &fsb) == 0 - && fsb.st_dev == stb.st_dev) - { - /* found the filesystem */ - check_okay = 1; - if (hasmntopt(entry, MNTOPT_NOSUID)) - on_nosuid = 1; - break; - } /* A single fs may well fail its stat(). */ - } + while (entry = getmntent(mtab)) { + if (stat(entry->mnt_dir, &fsb) == 0 + && fsb.st_dev == stb.st_dev) + { + /* found the filesystem */ + check_okay = 1; + if (hasmntopt(entry, MNTOPT_NOSUID)) + on_nosuid = 1; + break; + } /* A single fs may well fail its stat(). */ + } } if (mtab) - fclose(mtab); -# endif /* getmntent+hasmntopt */ -# endif /* PERL_MOUNT_NOSUID: fstatfs or fstat+ustat+statfs */ -# endif /* statvfs */ + fclose(mtab); +# endif /* getmntent+hasmntopt */ if (!check_okay) Perl_croak(aTHX_ "Can't check filesystem of script \"%s\" for nosuid", PL_origfilename); @@ -3301,6 +3327,10 @@ S_init_perllib(pTHX) incpush(PERL_VENDORLIB_STEM, FALSE, TRUE); #endif +#ifdef PERL_OTHERLIBDIRS + incpush(PERL_OTHERLIBDIRS, TRUE, TRUE); +#endif + if (!PL_tainting) incpush(".", FALSE, FALSE); } @@ -3402,8 +3432,8 @@ S_incpush(pTHX_ char *p, int addsubdirs, int addoldvers) av_push(GvAVn(PL_incgv), newSVsv(subdir)); } - if (addoldvers) { #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);