X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=perl.c;h=8e11c43cbfd7c61feaa52888574ecf4b4527bb0f;hb=8f1f23e8b15dc90b39e5be39711437f27f72b526;hp=bf86fef8be40730ee82a58d77f97a3113ae1ff28;hpb=24d3c5181312bc6d6fc2f89a6710968ed97b31dc;p=p5sagit%2Fp5-mst-13.2.git diff --git a/perl.c b/perl.c index bf86fef..8e11c43 100644 --- a/perl.c +++ b/perl.c @@ -13,7 +13,6 @@ #include "EXTERN.h" #include "perl.h" -#include "patchlevel.h" /* XXX If this causes problems, set i_unistd=undef in the hint file. */ #ifdef I_UNISTD @@ -64,6 +63,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 @@ -207,13 +209,13 @@ perl_construct(register PerlInterpreter *sv_interp) STATUS_ALL_SUCCESS; SET_NUMERIC_STANDARD(); -#if defined(SUBVERSION) && SUBVERSION > 0 - sprintf(PL_patchlevel, "%7.5f", (double) 5 - + ((double) PATCHLEVEL / (double) 1000) - + ((double) SUBVERSION / (double) 100000)); +#if defined(PERL_SUBVERSION) && PERL_SUBVERSION > 0 + sprintf(PL_patchlevel, "%7.5f", (double) PERL_REVISION + + ((double) PERL_VERSION / (double) 1000) + + ((double) PERL_SUBVERSION / (double) 100000)); #else - sprintf(PL_patchlevel, "%5.3f", (double) 5 + - ((double) PATCHLEVEL / (double) 1000)); + sprintf(PL_patchlevel, "%5.3f", (double) PERL_REVISION + + ((double) PERL_VERSION / (double) 1000)); #endif #if defined(LOCAL_PATCH_COUNT) @@ -547,6 +549,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(); @@ -559,6 +563,9 @@ perl_destruct(register PerlInterpreter *sv_interp) MUTEX_DESTROY(&PL_eval_mutex); MUTEX_DESTROY(&PL_cred_mutex); COND_DESTROY(&PL_eval_cond); +#ifdef EMULATE_ATOMIC_REFCOUNTS + MUTEX_DESTROY(&PL_svref_mutex); +#endif /* EMULATE_ATOMIC_REFCOUNTS */ /* As the penultimate thing, free the non-arena SV for thrsv */ Safefree(SvPVX(PL_thrsv)); @@ -651,7 +658,7 @@ setuid perl scripts securely.\n"); return 255; #endif -#if defined(NeXT) && defined(__DYNAMIC__) +#if defined(__DYNAMIC__) && (defined(NeXT) || defined(__NeXT__)) _dyld_lookup_and_bind ("__environ", (unsigned long *) &environ_pointer, NULL); #endif /* environ */ @@ -725,6 +732,9 @@ setuid perl scripts securely.\n"); s = argv[0]+1; reswitch: switch (*s) { +#ifndef PERL_STRICT_CR + case '\r': +#endif case ' ': case '0': case 'F': @@ -886,19 +896,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); } } @@ -1099,7 +1115,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 +1134,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 +1145,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 +1156,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 +1173,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 +1192,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 +1200,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 +1449,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 +1462,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 +1473,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; @@ -1705,9 +1724,9 @@ moreswitches(char *s) s++; return s; case 'v': -#if defined(SUBVERSION) && SUBVERSION > 0 - printf("\nThis is perl, version 5.%03d_%02d built for %s", - PATCHLEVEL, SUBVERSION, ARCHNAME); +#if defined(PERL_SUBVERSION) && PERL_SUBVERSION > 0 + printf("\nThis is perl, version %d.%03d_%02d built for %s", + PERL_REVISION, PERL_VERSION, PERL_SUBVERSION, ARCHNAME); #else printf("\nThis is perl, version %s built for %s", PL_patchlevel, ARCHNAME); @@ -1751,6 +1770,9 @@ moreswitches(char *s) #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 @@ -1849,6 +1871,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; \ @@ -1886,7 +1909,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; @@ -2101,6 +2124,77 @@ sed %s -e \"/^[^#]/b\" \ } } +/* Mention + * I_SYSSTATVFS HAS_FSTATVFS + * I_SYSMOUNT + * I_STATFS HAS_FSTATFS + * I_MNTENT HAS_GETMNTENT HAS_HASMNTOPT + * here so that metaconfig picks them up. */ + +#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) { @@ -2134,6 +2228,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 @@ -2168,6 +2263,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); @@ -2206,12 +2305,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"); @@ -2750,7 +2849,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); @@ -2758,7 +2857,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); @@ -2810,6 +2909,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++;