X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/495c5fdc8fec0d7d0f72a84d44bb3e7cfc448d43..511dd457ec43006d88c98d57960fa4353caf989e:/perl.c?ds=sidebyside diff --git a/perl.c b/perl.c index 79fab4a..69ded97 100644 --- a/perl.c +++ b/perl.c @@ -64,6 +64,9 @@ static void my_exit_jump _((void)) __attribute__((noreturn)); static void nuke_stacks _((void)); static void open_script _((char *, bool, SV *, int *fd)); static void usage _((char *)); +#ifdef IAMSUID +static int fd_on_nosuid_fs _((int)); +#endif static void validate_suid _((char *, char*, int)); static I32 read_e_script _((int idx, SV *buf_sv, int maxlen)); #endif @@ -92,7 +95,7 @@ perl_alloc(void) void #ifdef PERL_OBJECT -CPerlObj::perl_construct(void) +perl_construct(void) #else perl_construct(register PerlInterpreter *sv_interp) #endif @@ -138,6 +141,8 @@ perl_construct(register PerlInterpreter *sv_interp) MUTEX_INIT(&PL_svref_mutex); #endif /* EMULATE_ATOMIC_REFCOUNTS */ + MUTEX_INIT(&PL_cred_mutex); + thr = init_main_thread(); #endif /* USE_THREADS */ @@ -233,7 +238,7 @@ perl_construct(register PerlInterpreter *sv_interp) void #ifdef PERL_OBJECT -CPerlObj::perl_destruct(void) +perl_destruct(void) #else perl_destruct(register PerlInterpreter *sv_interp) #endif @@ -352,6 +357,7 @@ perl_destruct(register PerlInterpreter *sv_interp) PL_main_start = Nullop; SvREFCNT_dec(PL_main_cv); PL_main_cv = Nullcv; + PL_dirty = TRUE; if (PL_sv_objcount) { /* @@ -359,8 +365,6 @@ perl_destruct(register PerlInterpreter *sv_interp) * destructors and destructees still exist. Some sv's might remain. * Non-referenced objects are on their own. */ - - PL_dirty = TRUE; sv_clean_objs(); } @@ -546,6 +550,8 @@ perl_destruct(register PerlInterpreter *sv_interp) Safefree(PL_origfilename); Safefree(PL_archpat_auto); Safefree(PL_reg_start_tmp); + if (PL_reg_curpm) + Safefree(PL_reg_curpm); Safefree(HeKEY_hek(&PL_hv_fetch_ent_mh)); Safefree(PL_op_mask); nuke_stacks(); @@ -553,8 +559,10 @@ perl_destruct(register PerlInterpreter *sv_interp) DEBUG_P(debprofdump()); #ifdef USE_THREADS + MUTEX_DESTROY(&PL_strtab_mutex); MUTEX_DESTROY(&PL_sv_mutex); MUTEX_DESTROY(&PL_eval_mutex); + MUTEX_DESTROY(&PL_cred_mutex); COND_DESTROY(&PL_eval_cond); /* As the penultimate thing, free the non-arena SV for thrsv */ @@ -589,7 +597,7 @@ perl_destruct(register PerlInterpreter *sv_interp) void #ifdef PERL_OBJECT -CPerlObj::perl_free(void) +perl_free(void) #else perl_free(PerlInterpreter *sv_interp) #endif @@ -605,7 +613,7 @@ perl_free(PerlInterpreter *sv_interp) void #ifdef PERL_OBJECT -CPerlObj::perl_atexit(void (*fn) (CPerlObj*,void *), void *ptr) +perl_atexit(void (*fn) (CPerlObj*,void *), void *ptr) #else perl_atexit(void (*fn) (void *), void *ptr) #endif @@ -618,7 +626,7 @@ perl_atexit(void (*fn) (void *), void *ptr) int #ifdef PERL_OBJECT -CPerlObj::perl_parse(void (*xsinit) (CPerlObj*), int argc, char **argv, char **env) +perl_parse(void (*xsinit) (CPerlObj*), int argc, char **argv, char **env) #else perl_parse(PerlInterpreter *sv_interp, void (*xsinit) (void), int argc, char **argv, char **env) #endif @@ -809,14 +817,11 @@ setuid perl scripts securely.\n"); #else sv_catpv(PL_Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\","); #endif -#if defined(DEBUGGING) || defined(NO_EMBED) || defined(MULTIPLICITY) +#if defined(DEBUGGING) || defined(MULTIPLICITY) sv_catpv(PL_Sv,"\" Compile-time options:"); # ifdef DEBUGGING sv_catpv(PL_Sv," DEBUGGING"); # endif -# ifdef NO_EMBED - sv_catpv(PL_Sv," NO_EMBED"); -# endif # ifdef MULTIPLICITY sv_catpv(PL_Sv," MULTIPLICITY"); # endif @@ -828,7 +833,7 @@ setuid perl scripts securely.\n"); sv_catpv(PL_Sv,"\" Locally applied patches:\\n\","); for (i = 1; i <= LOCAL_PATCH_COUNT; i++) { if (PL_localpatches[i]) - sv_catpvf(PL_Sv,"\" \\t%s\\n\",",PL_localpatches[i]); + sv_catpvf(PL_Sv,"q\" \t%s\n\",",PL_localpatches[i]); } } #endif @@ -886,19 +891,25 @@ print \" \\@INC:\\n @INC\\n\";"); switch_end: if (!PL_tainting && (s = PerlEnv_getenv("PERL5OPT"))) { - while (s && *s) { - while (isSPACE(*s)) - s++; - if (*s == '-') { - s++; - if (isSPACE(*s)) - continue; + while (isSPACE(*s)) + s++; + if (*s == '-' && *(s+1) == 'T') + PL_tainting = TRUE; + else { + while (s && *s) { + while (isSPACE(*s)) + s++; + if (*s == '-') { + s++; + if (isSPACE(*s)) + continue; + } + if (!*s) + break; + if (!strchr("DIMUdmw", *s)) + croak("Illegal switch in PERL5OPT: -%c", *s); + s = moreswitches(s); } - if (!*s) - break; - if (!strchr("DIMUdmw", *s)) - croak("Illegal switch in PERL5OPT: -%c", *s); - s = moreswitches(s); } } @@ -1014,12 +1025,12 @@ print \" \\@INC:\\n @INC\\n\";"); int #ifdef PERL_OBJECT -CPerlObj::perl_run(void) +perl_run(void) #else perl_run(PerlInterpreter *sv_interp) #endif { - dSP; + dTHR; I32 oldscope; dJMPENV; int ret; @@ -1099,7 +1110,7 @@ perl_run(PerlInterpreter *sv_interp) } SV* -perl_get_sv(char *name, I32 create) +perl_get_sv(const char *name, I32 create) { GV *gv; #ifdef USE_THREADS @@ -1118,7 +1129,7 @@ perl_get_sv(char *name, I32 create) } AV* -perl_get_av(char *name, I32 create) +perl_get_av(const char *name, I32 create) { GV* gv = gv_fetchpv(name, create, SVt_PVAV); if (create) @@ -1129,7 +1140,7 @@ perl_get_av(char *name, I32 create) } HV* -perl_get_hv(char *name, I32 create) +perl_get_hv(const char *name, I32 create) { GV* gv = gv_fetchpv(name, create, SVt_PVHV); if (create) @@ -1140,9 +1151,10 @@ perl_get_hv(char *name, I32 create) } CV* -perl_get_cv(char *name, I32 create) +perl_get_cv(const char *name, I32 create) { GV* gv = gv_fetchpv(name, create, SVt_PVCV); + /* XXX unsafe for threads if eval_owner isn't held */ if (create && !GvCVu(gv)) return newSUB(start_subparse(FALSE, 0), newSVOP(OP_CONST, 0, newSVpv(name,0)), @@ -1156,7 +1168,7 @@ perl_get_cv(char *name, I32 create) /* Be sure to refetch the stack pointer after calling these routines. */ I32 -perl_call_argv(char *sub_name, I32 flags, register char **argv) +perl_call_argv(const char *sub_name, I32 flags, register char **argv) /* See G_* flags in cop.h */ /* null terminated arg list */ @@ -1175,7 +1187,7 @@ perl_call_argv(char *sub_name, I32 flags, register char **argv) } I32 -perl_call_pv(char *sub_name, I32 flags) +perl_call_pv(const char *sub_name, I32 flags) /* name of the subroutine */ /* See G_* flags in cop.h */ { @@ -1183,7 +1195,7 @@ perl_call_pv(char *sub_name, I32 flags) } I32 -perl_call_method(char *methname, I32 flags) +perl_call_method(const char *methname, I32 flags) /* name of the subroutine */ /* See G_* flags in cop.h */ { @@ -1432,7 +1444,7 @@ perl_eval_sv(SV *sv, I32 flags) } SV* -perl_eval_pv(char *p, I32 croak_on_error) +perl_eval_pv(const char *p, I32 croak_on_error) { dSP; SV* sv = newSVpv(p, 0); @@ -1445,8 +1457,10 @@ perl_eval_pv(char *p, I32 croak_on_error) sv = POPs; PUTBACK; - if (croak_on_error && SvTRUE(ERRSV)) - croak(SvPVx(ERRSV, PL_na)); + if (croak_on_error && SvTRUE(ERRSV)) { + STRLEN n_a; + croak(SvPVx(ERRSV, n_a)); + } return sv; } @@ -1454,7 +1468,7 @@ perl_eval_pv(char *p, I32 croak_on_error) /* Require a module. */ void -perl_require_pv(char *pv) +perl_require_pv(const char *pv) { SV* sv; dSP; @@ -1745,6 +1759,15 @@ moreswitches(char *s) #ifdef __VOS__ printf("Stratus VOS port by Paul_Green@stratus.com, 1997-1998\n"); #endif +#ifdef __OPEN_VM + printf("VM/ESA port by Neale Ferguson, 1998\n"); +#endif +#ifdef POSIX_BC + printf("BS2000 (POSIX) port by Start Amadeus GmbH, 1998\n"); +#endif +#ifdef __MINT__ + printf("MiNT port by Guido Flohr, 1997\n"); +#endif #ifdef BINARY_BUILD_NOTICE BINARY_BUILD_NOTICE; #endif @@ -1762,12 +1785,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; - compiling.cop_warnings = WARN_ALL ; + PL_compiling.cop_warnings = WARN_ALL ; s++; return s; case 'X': PL_dowarn = G_WARN_ALL_OFF; - compiling.cop_warnings = WARN_NONE ; + PL_compiling.cop_warnings = WARN_NONE ; s++; return s; case '*': @@ -1843,6 +1866,7 @@ init_interp(void) PL_curcopdb = NULL; \ PL_dbargs = 0; \ PL_dlmax = 128; \ + PL_dumpindent = 4; \ PL_laststatval = -1; \ PL_laststype = OP_STAT; \ PL_maxscream = -1; \ @@ -1865,6 +1889,7 @@ init_interp(void) PL_profiledata = NULL; \ PL_rsfp = Nullfp; \ PL_rsfp_filters = Nullav; \ + PL_dirty = FALSE; \ } STMT_END I_REINIT; #else @@ -1879,7 +1904,7 @@ init_interp(void) # undef PERLVAR # undef PERLVARI # undef PERLVARIC -# else +# else # define PERLVAR(var,type) # define PERLVARI(var,type,init) PL_##var = init; # define PERLVARIC(var,type,init) PL_##var = init; @@ -1905,6 +1930,9 @@ init_main_stash(void) about not iterating on it, and not adding tie magic to it. It is properly deallocated in perl_destruct() */ PL_strtab = newHV(); +#ifdef USE_THREADS + MUTEX_INIT(&PL_strtab_mutex); +#endif HvSHAREKEYS_off(PL_strtab); /* mandatory */ hv_ksplit(PL_strtab, 512); @@ -1932,7 +1960,7 @@ init_main_stash(void) 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. */ - sv_setpvn(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), "\n", 1); + sv_setpvn(perl_get_sv("/", TRUE), "\n", 1); } STATIC void @@ -2001,6 +2029,21 @@ sed %s -e \"/^[^#]/b\" \ %s | %_ -C %_ %s", (PL_doextract ? "-e \"1,/^#/d\n\"" : ""), #else +# ifdef __OPEN_VM + sv_setpvf(cmd, "\ +%s %s -e '/^[^#]/b' \ + -e '/^#[ ]*include[ ]/b' \ + -e '/^#[ ]*define[ ]/b' \ + -e '/^#[ ]*if[ ]/b' \ + -e '/^#[ ]*ifdef[ ]/b' \ + -e '/^#[ ]*ifndef[ ]/b' \ + -e '/^#[ ]*else/b' \ + -e '/^#[ ]*elif[ ]/b' \ + -e '/^#[ ]*undef[ ]/b' \ + -e '/^#[ ]*endif/b' \ + -e 's/^[ ]*#.*//' \ + %s | %_ %_ %s", +# else sv_setpvf(cmd, "\ %s %s -e '/^[^#]/b' \ -e '/^#[ ]*include[ ]/b' \ @@ -2014,6 +2057,7 @@ sed %s -e \"/^[^#]/b\" \ -e '/^#[ ]*endif/b' \ -e 's/^[ ]*#.*//' \ %s | %_ -C %_ %s", +# endif #ifdef LOC_SED LOC_SED, #else @@ -2075,6 +2119,70 @@ sed %s -e \"/^[^#]/b\" \ } } +#ifdef IAMSUID +static int +fd_on_nosuid_fs(int fd) +{ + int on_nosuid = 0; + int check_okay = 0; +/* + * Preferred order: fstatvfs(), fstatfs(), getmntent(). + * fstatvfs() is UNIX98. + * fstatfs() is BSD. + * getmntent() is O(number-of-mounted-filesystems) and can hang. + */ + +# ifdef HAS_FSTATVFS + struct statvfs stfs; + check_okay = fstatvfs(fd, &stfs) == 0; + on_nosuid = check_okay && (stfs.f_flag & ST_NOSUID); +# else +# if defined(HAS_FSTATFS) && defined(HAS_STRUCT_STATFS_FLAGS) + struct statfs stfs; + check_okay = fstatfs(fd, &stfs) == 0; +# undef PERL_MOUNT_NOSUID +# if !defined(PERL_MOUNT_NOSUID) && defined(MNT_NOSUID) +# define PERL_MOUNT_NOSUID MNT_NOSUID +# endif +# if !defined(PERL_MOUNT_NOSUID) && defined(MS_NOSUID) +# define PERL_MOUNT_NOSUID MS_NOSUID +# endif +# if !defined(PERL_MOUNT_NOSUID) && defined(M_NOSUID) +# define PERL_MOUNT_NOSUID M_NOSUID +# endif +# ifdef PERL_MOUNT_NOSUID + on_nosuid = check_okay && (stfs.f_flags & PERL_MOUNT_NOSUID); +# endif +# else +# if defined(HAS_GETMNTENT) && defined(HAS_HASMNTOPT) && defined(MNTOPT_NOSUID) + 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(). */ + } + } + if (mtab) + fclose(mtab); +# endif /* mntent */ +# endif /* statfs */ +# endif /* statvfs */ + if (!check_okay) + croak("Can't check filesystem of script \"%s\"", PL_origfilename); + return on_nosuid; +} +#endif /* IAMSUID */ + STATIC void validate_suid(char *validarg, char *scriptname, int fdscript) { @@ -2108,6 +2216,7 @@ validate_suid(char *validarg, char *scriptname, int fdscript) croak("Can't stat script \"%s\"",PL_origfilename); if (fdscript < 0 && PL_statbuf.st_mode & (S_ISUID|S_ISGID)) { I32 len; + STRLEN n_a; #ifdef IAMSUID #ifndef HAS_SETREUID @@ -2142,6 +2251,10 @@ validate_suid(char *validarg, char *scriptname, int fdscript) croak("Can't swap uid and euid"); /* really paranoid */ if (PerlLIO_stat(SvPVX(GvSV(PL_curcop->cop_filegv)),&tmpstatbuf) < 0) croak("Permission denied"); /* testing full pathname here */ +#if defined(IAMSUID) && !defined(NO_NOSUID_CHECK) + if (fd_on_nosuid_fs(PerlIO_fileno(PL_rsfp))) + croak("Permission denied"); +#endif if (tmpstatbuf.st_dev != PL_statbuf.st_dev || tmpstatbuf.st_ino != PL_statbuf.st_ino) { (void)PerlIO_close(PL_rsfp); @@ -2180,12 +2293,12 @@ validate_suid(char *validarg, char *scriptname, int fdscript) PL_doswitches = FALSE; /* -s is insecure in suid */ PL_curcop->cop_line++; if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch || - strnNE(SvPV(PL_linestr,PL_na),"#!",2) ) /* required even on Sys V */ + strnNE(SvPV(PL_linestr,n_a),"#!",2) ) /* required even on Sys V */ croak("No #! line"); - s = SvPV(PL_linestr,PL_na)+2; + s = SvPV(PL_linestr,n_a)+2; if (*s == ' ') s++; while (!isSPACE(*s)) s++; - for (s2 = s; (s2 > SvPV(PL_linestr,PL_na)+2 && + for (s2 = s; (s2 > SvPV(PL_linestr,n_a)+2 && (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ; if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */ croak("Not a perl script"); @@ -2724,7 +2837,7 @@ incpush(char *p, int addsubdirs) char *unix; STRLEN len; - if ((unix = tounixspec_ts(SvPV(libdir,PL_na),Nullch)) != Nullch) { + if ((unix = tounixspec_ts(SvPV(libdir,len),Nullch)) != Nullch) { len = strlen(unix); while (unix[len-1] == '/') len--; /* Cosmetic */ sv_usepvn(libdir,unix,len); @@ -2732,7 +2845,7 @@ incpush(char *p, int addsubdirs) else PerlIO_printf(PerlIO_stderr(), "Failed to unixify @INC element \"%s\"\n", - SvPV(libdir,PL_na)); + SvPV(libdir,len)); #endif /* .../archname/version if -d .../archname/version/auto */ sv_setsv(subdir, libdir); @@ -2784,6 +2897,7 @@ init_main_thread() *SvEND(PL_thrsv) = '\0'; /* in the trailing_nul field */ thr->oursv = PL_thrsv; PL_chopset = " \n-"; + PL_dumpindent = 4; MUTEX_LOCK(&PL_threads_mutex); PL_nthreads++; @@ -2952,7 +3066,7 @@ my_failure_exit(void) STATIC void my_exit_jump(void) { - dSP; + dTHR; register PERL_CONTEXT *cx; I32 gimme; SV **newsp;