X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=perl.c;h=25b87c82a508772526f25fd932c8f20e5336230c;hb=360aca433d51a01ddd748b8606c6c288bdb2f7fc;hp=7433132973b1fdef22a31d04b78f52ebd6aca0ec;hpb=5ff3f7a4e03a6b103d9e628865398e498e9a7968;p=p5sagit%2Fp5-mst-13.2.git diff --git a/perl.c b/perl.c index 7433132..25b87c8 100644 --- a/perl.c +++ b/perl.c @@ -1,6 +1,6 @@ /* perl.c * - * Copyright (c) 1987-1998 Larry Wall + * Copyright (c) 1987-1999 Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -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 @@ -92,7 +94,7 @@ perl_alloc(void) void #ifdef PERL_OBJECT -CPerlObj::perl_construct(void) +perl_construct(void) #else perl_construct(register PerlInterpreter *sv_interp) #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) @@ -235,7 +237,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 @@ -354,6 +356,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) { /* @@ -361,8 +364,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(); } @@ -548,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(); @@ -560,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)); @@ -593,7 +599,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 @@ -609,7 +615,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 @@ -622,7 +628,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 @@ -726,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': @@ -813,14 +822,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 @@ -832,7 +838,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 @@ -890,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); } } @@ -1018,12 +1030,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; @@ -1103,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 @@ -1122,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) @@ -1133,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) @@ -1144,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)), @@ -1160,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 */ @@ -1179,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 */ { @@ -1187,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 */ { @@ -1436,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); @@ -1449,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; } @@ -1458,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; @@ -1709,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); @@ -1722,32 +1737,41 @@ moreswitches(char *s) LOCAL_PATCH_COUNT, (LOCAL_PATCH_COUNT!=1) ? "es" : ""); #endif - printf("\n\nCopyright 1987-1998, Larry Wall\n"); + printf("\n\nCopyright 1987-1999, Larry Wall\n"); #ifdef MSDOS printf("\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n"); #endif #ifdef DJGPP printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n"); - printf("djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1998\n"); + printf("djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n"); #endif #ifdef OS2 printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n" - "Version 5 port Copyright (c) 1994-1998, Andreas Kaiser, Ilya Zakharevich\n"); + "Version 5 port Copyright (c) 1994-1999, Andreas Kaiser, Ilya Zakharevich\n"); #endif #ifdef atarist printf("atariST series port, ++jrb bammi@cadence.com\n"); #endif #ifdef __BEOS__ - printf("BeOS port Copyright Tom Spindler, 1997-1998\n"); + printf("BeOS port Copyright Tom Spindler, 1997-1999\n"); #endif #ifdef MPE - printf("MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-1998\n"); + printf("MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-1999\n"); #endif #ifdef OEMVS - printf("MVS (OS390) port by Mortice Kern Systems, 1997-1998\n"); + printf("MVS (OS390) port by Mortice Kern Systems, 1997-1999\n"); #endif #ifdef __VOS__ - printf("Stratus VOS port by Paul_Green@stratus.com, 1997-1998\n"); + printf("Stratus VOS port by Paul_Green@stratus.com, 1997-1999\n"); +#endif +#ifdef __OPEN_VM + printf("VM/ESA port by Neale Ferguson, 1998-1999\n"); +#endif +#ifdef POSIX_BC + printf("BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n"); +#endif +#ifdef __MINT__ + printf("MiNT port by Guido Flohr, 1997-1999\n"); #endif #ifdef BINARY_BUILD_NOTICE BINARY_BUILD_NOTICE; @@ -1766,12 +1790,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 '*': @@ -1847,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; \ @@ -1869,6 +1894,7 @@ init_interp(void) PL_profiledata = NULL; \ PL_rsfp = Nullfp; \ PL_rsfp_filters = Nullav; \ + PL_dirty = FALSE; \ } STMT_END I_REINIT; #else @@ -1883,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; @@ -1939,7 +1965,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 @@ -2008,6 +2034,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' \ @@ -2021,6 +2062,7 @@ sed %s -e \"/^[^#]/b\" \ -e '/^#[ ]*endif/b' \ -e 's/^[ ]*#.*//' \ %s | %_ -C %_ %s", +# endif #ifdef LOC_SED LOC_SED, #else @@ -2082,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) { @@ -2115,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 @@ -2149,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); @@ -2187,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"); @@ -2731,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); @@ -2739,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); @@ -2791,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++; @@ -2959,7 +3078,7 @@ my_failure_exit(void) STATIC void my_exit_jump(void) { - dSP; + dTHR; register PERL_CONTEXT *cx; I32 gimme; SV **newsp;