static void find_beginning _((void));
static void forbid_setid _((char *));
-static void incpush _((char *));
+static void incpush _((char *, int));
static void init_ids _((void));
static void init_debugger _((void));
static void init_lexer _((void));
static void init_postdump_symbols _((int, char **, char **));
static void init_predump_symbols _((void));
static void init_stacks _((void));
+static void my_exit_jump _((void)) __attribute__((noreturn));
static void nuke_stacks _((void));
static void open_script _((char *, bool, SV *));
static void usage _((char *));
init_ids();
+ STATUS_ALL_SUCCESS;
+
SET_NUMERIC_STANDARD();
#if defined(SUBVERSION) && SUBVERSION > 0
sprintf(patchlevel, "%7.5f", (double) 5
op_free(main_root);
main_root = 0;
+ time(&basetime);
+
switch (Sigsetjmp(top_env,1)) {
case 1:
-#ifdef VMS
- statusvalue = 255;
-#else
- statusvalue = 1;
-#endif
+ STATUS_ALL_FAILURE;
+ /* FALL THROUGH */
case 2:
+ /* my_exit() was called */
curstash = defstash;
if (endav)
calllist(endav);
- return(statusvalue); /* my_exit() was called */
+ return STATUS_NATIVE_EXPORT;
case 3:
PerlIO_printf(PerlIO_stderr(), "panic: top_env\n");
return 1;
case 'n':
case 'p':
case 's':
- case 'T':
case 'u':
case 'U':
case 'v':
goto reswitch;
break;
+ case 'T':
+ tainting = TRUE;
+ s++;
+ goto reswitch;
+
case 'e':
if (euid != uid || egid != gid)
croak("No -e allowed in setuid scripts");
sv_catpv(sv,s);
sv_catpv(sv," ");
if (*++s) {
- av_push(GvAVn(incgv),newSVpv(s,0));
+ incpush(s, TRUE);
}
else if (argv[1]) {
- av_push(GvAVn(incgv),newSVpv(argv[1],0));
+ incpush(argv[1], TRUE);
sv_catpv(sv,argv[1]);
argc--,argv++;
sv_catpv(sv," ");
cxstack_ix = -1; /* start context stack again */
break;
case 2:
+ /* my_exit() was called */
curstash = defstash;
if (endav)
calllist(endav);
if (getenv("PERL_DEBUG_MSTATS"))
dump_mstats("after execution: ");
#endif
- return(statusvalue); /* my_exit() was called */
+ return STATUS_NATIVE_EXPORT;
case 3:
if (!restartop) {
PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
return 0;
}
-void
-my_exit(status)
-U32 status;
-{
- register CONTEXT *cx;
- I32 gimme;
- SV **newsp;
-
- statusvalue = FIXSTATUS(status);
- if (cxstack_ix >= 0) {
- if (cxstack_ix > 0)
- dounwind(0);
- POPBLOCK(cx,curpm);
- LEAVE;
- }
- Siglongjmp(top_env, 2);
-}
-
SV*
perl_get_sv(name, create)
char* name;
{
GV* gv = gv_fetchpv(name, create, SVt_PVCV);
if (create && !GvCVu(gv))
- return newSUB(start_subparse(0),
+ return newSUB(start_subparse(FALSE, 0),
newSVOP(OP_CONST, 0, newSVpv(name,0)),
Nullop,
Nullop);
case 0:
break;
case 1:
-#ifdef VMS
- statusvalue = 255; /* XXX I don't think we use 1 anymore. */
-#else
- statusvalue = 1;
-#endif
+ STATUS_ALL_FAILURE;
/* FALL THROUGH */
case 2:
/* my_exit() was called */
Copy(oldtop, top_env, 1, Sigjmp_buf);
if (statusvalue)
croak("Callback called exit");
- my_exit(statusvalue);
+ my_exit_jump();
/* NOTREACHED */
case 3:
if (restartop) {
case 0:
break;
case 1:
-#ifdef VMS
- statusvalue = 255; /* XXX I don't think we use 1 anymore. */
-#else
- statusvalue = 1;
-#endif
+ STATUS_ALL_FAILURE;
/* FALL THROUGH */
case 2:
/* my_exit() was called */
Copy(oldtop, top_env, 1, Sigjmp_buf);
if (statusvalue)
croak("Callback called exit");
- my_exit(statusvalue);
+ my_exit_jump();
/* NOTREACHED */
case 3:
if (restartop) {
sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
}
-#if defined(DOSISH)
-# define PERLLIB_SEP ';'
-#else
-# if defined(VMS)
-# define PERLLIB_SEP '|'
-# else
-# define PERLLIB_SEP ':'
-# endif
-#endif
-#ifndef PERLLIB_MANGLE
-# define PERLLIB_MANGLE(s,n) (s)
-#endif
-
-static void
-incpush(p)
-char *p;
-{
- char *s;
-
- if (!p)
- return;
-
- /* Break at all separators */
- while (*p) {
- /* First, skip any consecutive separators */
- while ( *p == PERLLIB_SEP ) {
- /* Uncomment the next line for PATH semantics */
- /* av_push(GvAVn(incgv), newSVpv(".", 1)); */
- p++;
- }
- if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
- av_push(GvAVn(incgv), newSVpv(PERLLIB_MANGLE(p, (STRLEN)(s - p)),
- (STRLEN)(s - p)));
- p = s + 1;
- } else {
- av_push(GvAVn(incgv), newSVpv(PERLLIB_MANGLE(p, 0), 0));
- break;
- }
- }
-}
-
static void
usage(name) /* XXX move this out into a module ? */
char *name;
case 'I':
forbid_setid("-I");
if (*++s) {
- char *e;
+ char *e, *p;
for (e = s; *e && !isSPACE(*e); e++) ;
- av_push(GvAVn(incgv),newSVpv(s,e-s));
+ p = savepvn(s, e-s);
+ incpush(p, TRUE);
+ Safefree(p);
if (*e)
return e;
}
s++;
return s;
case 'T':
- tainting = TRUE;
+ if (!tainting)
+ croak("Too late for \"-T\" option (try putting it first)");
s++;
return s;
case 'u':
#endif
printf("\n\nCopyright 1987-1997, Larry Wall\n");
- printf("\n\t+ suidperl security patch");
#ifdef MSDOS
printf("\n\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
#endif
sv_setpv(GvSV(tmpgv),origfilename);
magicname("0", "0", 1);
}
- if (tmpgv = gv_fetchpv("\024",TRUE, SVt_PV))
- time(&basetime);
if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
sv_setpv(GvSV(tmpgv),origargv[0]);
if (argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
#ifndef VMS
s = getenv("PERL5LIB");
if (s)
- incpush(s);
+ incpush(s, TRUE);
else
- incpush(getenv("PERLLIB"));
+ incpush(getenv("PERLLIB"), FALSE);
#else /* VMS */
/* Treat PERL5?LIB as a possible search list logical name -- the
* "natural" VMS idiom for a Unix path string. We allow each
char buf[256];
int idx = 0;
if (my_trnlnm("PERL5LIB",buf,0))
- do { incpush(buf); } while (my_trnlnm("PERL5LIB",buf,++idx));
+ do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
else
- while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf);
+ while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
#endif /* VMS */
}
ARCHLIB PRIVLIB SITEARCH SITELIB and OLDARCHLIB
*/
#ifdef APPLLIB_EXP
- incpush(APPLLIB_EXP);
+ incpush(APPLLIB_EXP, FALSE);
#endif
#ifdef ARCHLIB_EXP
- incpush(ARCHLIB_EXP);
+ incpush(ARCHLIB_EXP, FALSE);
#endif
#ifndef PRIVLIB_EXP
#define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
#endif
- incpush(PRIVLIB_EXP);
+ incpush(PRIVLIB_EXP, FALSE);
#ifdef SITEARCH_EXP
- incpush(SITEARCH_EXP);
+ incpush(SITEARCH_EXP, FALSE);
#endif
#ifdef SITELIB_EXP
- incpush(SITELIB_EXP);
+ incpush(SITELIB_EXP, FALSE);
#endif
#ifdef OLDARCHLIB_EXP /* 5.00[01] compatibility */
- incpush(OLDARCHLIB_EXP);
+ incpush(OLDARCHLIB_EXP, FALSE);
#endif
if (!tainting)
- incpush(".");
+ incpush(".", FALSE);
+}
+
+#if defined(DOSISH)
+# define PERLLIB_SEP ';'
+#else
+# if defined(VMS)
+# define PERLLIB_SEP '|'
+# else
+# define PERLLIB_SEP ':'
+# endif
+#endif
+#ifndef PERLLIB_MANGLE
+# define PERLLIB_MANGLE(s,n) (s)
+#endif
+
+static void
+incpush(p, addsubdirs)
+char *p;
+int addsubdirs;
+{
+ SV *subdir = Nullsv;
+ static char *archpat_auto;
+
+ if (!p)
+ return;
+
+ if (addsubdirs) {
+ subdir = newSV(0);
+ if (!archpat_auto) {
+ STRLEN len = (sizeof(ARCHNAME) + strlen(patchlevel)
+ + sizeof("//auto"));
+ New(55, archpat_auto, len, char);
+ sprintf(archpat_auto, "/%s/%s/auto", ARCHNAME, patchlevel);
+ }
+ }
+
+ /* Break at all separators */
+ while (p && *p) {
+ SV *libdir = newSV(0);
+ char *s;
+
+ /* skip any consecutive separators */
+ while ( *p == PERLLIB_SEP ) {
+ /* Uncomment the next line for PATH semantics */
+ /* av_push(GvAVn(incgv), newSVpv(".", 1)); */
+ p++;
+ }
+
+ if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
+ sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
+ (STRLEN)(s - p));
+ p = s + 1;
+ }
+ else {
+ sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
+ p = Nullch; /* break out */
+ }
+
+ /*
+ * BEFORE pushing libdir onto @INC we may first push version- and
+ * archname-specific sub-directories.
+ */
+ if (addsubdirs) {
+ struct stat tmpstatbuf;
+
+ /* .../archname/version if -d .../archname/auto */
+ sv_setsv(subdir, libdir);
+ sv_catpv(subdir, archpat_auto);
+ if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
+ S_ISDIR(tmpstatbuf.st_mode))
+ av_push(GvAVn(incgv),
+ newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
+
+ /* .../archname/version if -d .../archname/version/auto */
+ sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME),
+ strlen(patchlevel) + 1, "", 0);
+ if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
+ S_ISDIR(tmpstatbuf.st_mode))
+ av_push(GvAVn(incgv),
+ newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
+ }
+
+ /* finally push this lib directory on the end of @INC */
+ av_push(GvAVn(incgv), libdir);
+ }
+
+ SvREFCNT_dec(subdir);
}
void
}
break;
case 1:
-#ifdef VMS
- statusvalue = 255; /* XXX I don't think we use 1 anymore. */
-#else
- statusvalue = 1;
-#endif
+ STATUS_ALL_FAILURE;
/* FALL THROUGH */
case 2:
/* my_exit() was called */
else
croak("END failed--cleanup aborted");
}
- my_exit(statusvalue);
+ my_exit_jump();
/* NOTREACHED */
- return;
case 3:
if (!restartop) {
PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
Copy(oldtop, top_env, 1, Sigjmp_buf);
}
+void
+my_exit(status)
+U32 status;
+{
+ switch (status) {
+ case 0:
+ STATUS_ALL_SUCCESS;
+ break;
+ case 1:
+ STATUS_ALL_FAILURE;
+ break;
+ default:
+ STATUS_NATIVE_SET(status);
+ break;
+ }
+ my_exit_jump();
+}
+
+void
+my_failure_exit()
+{
+#ifdef VMS
+ if (vaxc$errno & 1) {
+ if (GETSTATUS_NATIVE & 1) /* fortuitiously includes "-1" */
+ SETSTATUS_NATIVE(44);
+ }
+ else {
+ if (!vaxc$errno && errno) /* someone must have set $^E = 0 */
+ SETSTATUS_NATIVE(44);
+ else
+ SETSTATUS_NATIVE(vaxc$errno);
+ }
+#else
+ if (errno & 255)
+ STATUS_POSIX_SET(errno);
+ else if (STATUS_POSIX == 0)
+ STATUS_POSIX_SET(255);
+#endif
+ my_exit_jump();
+}
+
+static void
+my_exit_jump()
+{
+ register CONTEXT *cx;
+ I32 gimme;
+ SV **newsp;
+
+ if (e_tmpname) {
+ if (e_fp) {
+ PerlIO_close(e_fp);
+ e_fp = Nullfp;
+ }
+ (void)UNLINK(e_tmpname);
+ Safefree(e_tmpname);
+ e_tmpname = Nullch;
+ }
+
+ if (cxstack_ix >= 0) {
+ if (cxstack_ix > 0)
+ dounwind(0);
+ POPBLOCK(cx,curpm);
+ LEAVE;
+ }
+ Siglongjmp(top_env, 2);
+}
projects / p5sagit/p5-mst-13.2.git / blobdiff