/* 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.
#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
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
#endif
}
- PL_nrs = newSVpv("\n", 1);
+ PL_nrs = newSVpvn("\n", 1);
PL_rs = SvREFCNT_inc(PL_nrs);
init_stacks(ARGS);
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)
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();
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));
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 */
}
sv_setpvn(PL_linestr,"",0);
- sv = newSVpv("",0); /* first used for -I flags */
+ sv = newSVpvn("",0); /* first used for -I flags */
SAVEFREESV(sv);
init_main_stash();
s = argv[0]+1;
reswitch:
switch (*s) {
+#ifndef PERL_STRICT_CR
+ case '\r':
+#endif
case ' ':
case '0':
case 'F':
if (PL_euid != PL_uid || PL_egid != PL_gid)
croak("No -e allowed in setuid scripts");
if (!PL_e_script) {
- PL_e_script = newSVpv("",0);
+ PL_e_script = newSVpvn("",0);
filter_add(read_e_script, NULL);
}
if (*++s)
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);
}
}
PL_min_intro_pending = 0;
PL_padix = 0;
#ifdef USE_THREADS
- av_store(PL_comppad_name, 0, newSVpv("@_", 2));
+ av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
PL_curpad[0] = (SV*)newAV();
SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
CvOWNER(PL_compcv) = 0;
}
SV*
-perl_get_sv(char *name, I32 create)
+perl_get_sv(const char *name, I32 create)
{
GV *gv;
#ifdef USE_THREADS
}
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)
}
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)
}
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)),
/* 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 */
}
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 */
{
}
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 */
{
}
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);
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;
}
/* Require a module. */
void
-perl_require_pv(char *pv)
+perl_require_pv(const char *pv)
{
SV* sv;
dSP;
if (rschar & ~((U8)~0))
PL_nrs = &PL_sv_undef;
else if (!rschar && numlen >= 2)
- PL_nrs = newSVpv("", 0);
+ PL_nrs = newSVpvn("", 0);
else {
char ch = rschar;
- PL_nrs = newSVpv(&ch, 1);
+ PL_nrs = newSVpvn(&ch, 1);
}
return s + numlen;
}
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);
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\n");
+ printf("VM/ESA port by Neale Ferguson, 1998-1999\n");
#endif
#ifdef POSIX_BC
- printf("BS2000 (POSIX) port by Start Amadeus GmbH, 1998\n");
+ 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;
hv_ksplit(PL_strtab, 512);
PL_curstash = PL_defstash = newHV();
- PL_curstname = newSVpv("main",4);
+ PL_curstname = newSVpvn("main",4);
gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
SvREFCNT_dec(GvHV(gv));
GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash);
}
else if (PL_preprocess) {
char *cpp_cfg = CPPSTDIN;
- SV *cpp = newSVpv("",0);
+ SV *cpp = newSVpvn("",0);
SV *cmd = NEWSV(0,0);
if (strEQ(cpp_cfg, "cppstdin"))
}
}
+/* 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)
{
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
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);
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");
PL_rsfp = Nullfp;
lex_start(PL_linestr);
PL_rsfp = tmpfp;
- PL_subname = newSVpv("main",4);
+ PL_subname = newSVpvn("main",4);
}
STATIC void
/* skip any consecutive separators */
while ( *p == PERLLIB_SEP ) {
/* Uncomment the next line for PATH semantics */
- /* av_push(GvAVn(PL_incgv), newSVpv(".", 1)); */
+ /* av_push(GvAVn(PL_incgv), newSVpvn(".", 1)); */
p++;
}
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);
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);
if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
S_ISDIR(tmpstatbuf.st_mode))
av_push(GvAVn(PL_incgv),
- newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
+ newSVpvn(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
/* .../archname if -d .../archname/auto */
sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME),
if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
S_ISDIR(tmpstatbuf.st_mode))
av_push(GvAVn(PL_incgv),
- newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
+ newSVpvn(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
}
/* finally push this lib directory on the end of @INC */
sv_upgrade(PL_bodytarget, SVt_PVFM);
sv_setpvn(PL_bodytarget, "", 0);
PL_formtarget = PL_bodytarget;
- thr->errsv = newSVpv("", 0);
+ thr->errsv = newSVpvn("", 0);
(void) find_threadsv("@"); /* Ensure $@ is initialised early */
PL_maxscream = -1;
projects / p5sagit/p5-mst-13.2.git / blobdiff