/* perl.c
*
- * Copyright (c) 1987-1994 Larry Wall
+ * Copyright (c) 1987-1995 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.
#endif
*/
-char rcsid[] = "perl.c\nPatch level: ###\n";
+dEXT char rcsid[] = "perl.c\nPatch level: ###\n";
#ifdef IAMSUID
#ifndef DOSUID
static void find_beginning _((void));
static void incpush _((char *));
+static void init_ids _((void));
static void init_debugger _((void));
static void init_lexer _((void));
static void init_main_stash _((void));
perl_construct( sv_interp )
register PerlInterpreter *sv_interp;
{
- char* s;
-
if (!(curinterp = sv_interp))
return;
tmps_floor = -1;
#endif
- uid = (int)getuid();
- euid = (int)geteuid();
- gid = (int)getgid();
- egid = (int)getegid();
-#ifdef VMS
- uid |= gid << 16;
- euid |= egid << 16;
-#endif
- tainting = (euid != uid || egid != gid);
+ init_ids();
sprintf(patchlevel, "%5.3f", 5.0 + (PATCHLEVEL / 1000.0));
fdpid = newAV(); /* for remembering popen pids by fd */
}
void
-perl_destruct(sv_interp, destruct_level)
+perl_destruct(sv_interp)
register PerlInterpreter *sv_interp;
-int destruct_level; /* 0=none, 1=full, 2=full with checks */
{
+ int destruct_level; /* 0=none, 1=full, 2=full with checks */
I32 last_sv_count;
HV *hv;
if (!(curinterp = sv_interp))
return;
+
+ destruct_level = perl_destruct_level;
+#ifdef DEBUGGING
+ {
+ char *s;
+ if (s = getenv("PERL_DESTRUCT_LEVEL"))
+ destruct_level = atoi(s);
+ }
+#endif
+
LEAVE;
FREETMPS;
}
if (sv_count != 0)
warn("Scalars leaked: %d\n", sv_count);
+ sv_free_arenas();
DEBUG_P(debprofdump());
}
char *scriptname;
VOL bool dosearch = FALSE;
char *validarg = "";
+ AV* comppadlist;
#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
#ifdef IAMSUID
origfilename = savepv(argv[0]);
do_undump = FALSE;
cxstack_ix = -1; /* start label stack again */
+ init_ids();
init_postdump_symbols(argc,argv,env);
return 0;
}
switch (setjmp(top_env)) {
case 1:
+#ifdef VMS
statusvalue = 255;
+#else
+ statusvalue = 1;
+#endif
case 2:
curstash = defstash;
if (endav)
case 'c':
case 'd':
case 'D':
+ case 'h':
case 'i':
case 'l':
case 'n':
if (doextract)
find_beginning();
+ compcv = (CV*)NEWSV(1104,0);
+ sv_upgrade((SV *)compcv, SVt_PVCV);
+
pad = newAV();
comppad = pad;
av_push(comppad, Nullsv);
min_intro_pending = 0;
padix = 0;
+ comppadlist = newAV();
+ AvREAL_off(comppadlist);
+ av_store(comppadlist, 0, (SV*)comppad_name);
+ av_store(comppadlist, 1, (SV*)comppad);
+ CvPADLIST(compcv) = comppadlist;
+
if (xsinit)
(*xsinit)(); /* in case linked C routines want magical variables */
+#ifdef VMS
+ init_os_extras();
+#endif
init_predump_symbols();
if (!do_undump)
void
my_exit(status)
-I32 status;
+U32 status;
{
register CONTEXT *cx;
I32 gimme;
SV **newsp;
- statusvalue = (unsigned short)(status & 0xffff);
+ statusvalue = FIXSTATUS(status);
if (cxstack_ix >= 0) {
if (cxstack_ix > 0)
dounwind(0);
if (create && !GvCV(gv))
return newSUB(start_subparse(),
newSVOP(OP_CONST, 0, newSVpv(name,0)),
+ Nullop,
Nullop);
if (gv)
return GvCV(gv);
cLOGOP->op_other = op;
markstack_ptr--;
- pp_entertry();
+ /* we're trying to emulate pp_entertry() here */
+ {
+ register CONTEXT *cx;
+ I32 gimme = GIMME;
+
+ ENTER;
+ SAVETMPS;
+
+ push_return(op->op_next);
+ PUSHBLOCK(cx, CXt_EVAL, stack_sp);
+ PUSHEVAL(cx, 0, 0);
+ eval_root = op; /* Only needed so that goto works right. */
+
+ in_eval = 1;
+ if (flags & G_KEEPERR)
+ in_eval |= 4;
+ else
+ sv_setpv(GvSV(errgv),"");
+ }
markstack_ptr++;
restart:
case 0:
break;
case 1:
+#ifdef VMS
statusvalue = 255; /* XXX I don't think we use 1 anymore. */
+#else
+ statusvalue = 1;
+#endif
/* FALL THROUGH */
case 2:
/* my_exit() was called */
if (op)
run();
retval = stack_sp - (stack_base + oldmark);
- if (flags & G_EVAL)
- sv_setpv(GvSV(gv_fetchpv("@",TRUE, SVt_PV)),"");
+ if ((flags & G_EVAL) && !(flags & G_KEEPERR))
+ sv_setpv(GvSV(errgv),"");
cleanup:
if (flags & G_EVAL) {
return retval;
}
-/* Older forms, here grandfathered. */
-
-#ifdef DEPRECATED
-I32
-perl_callargv(subname, spix, gimme, argv)
-char *subname;
-register I32 spix; /* current stack pointer index */
-I32 gimme; /* See G_* flags in cop.h */
-register char **argv; /* null terminated arg list, NULL for no arglist */
-{
- stack_sp = stack_base + spix;
- return spix + perl_call_argv(subname, gimme, argv);
-}
-
-I32
-perl_callpv(subname, spix, gimme, hasargs, numargs)
-char *subname;
-I32 spix; /* stack pointer index after args are pushed */
-I32 gimme; /* See G_* flags in cop.h */
-I32 hasargs; /* whether to create a @_ array for routine */
-I32 numargs; /* how many args are pushed on the stack */
-{
- stack_sp = stack_base + spix;
- PUSHMARK(stack_sp - numargs);
- return spix - numargs + perl_call_sv((SV*)perl_get_cv(subname, TRUE),
- gimme, hasargs, numargs);
-}
+/* Eval a string. */
I32
-perl_callsv(sv, spix, gimme, hasargs, numargs)
+perl_eval_sv(sv, flags)
SV* sv;
-I32 spix; /* stack pointer index after args are pushed */
-I32 gimme; /* See G_* flags in cop.h */
-I32 hasargs; /* whether to create a @_ array for routine */
-I32 numargs; /* how many args are pushed on the stack */
-{
- stack_sp = stack_base + spix;
- PUSHMARK(stack_sp - numargs);
- return spix - numargs + perl_call_sv(sv, gimme, hasargs, numargs);
-}
-#endif
-
-/* Require a module. */
-
-void
-perl_requirepv(pv)
-char* pv;
+I32 flags; /* See G_* flags in cop.h */
{
UNOP myop; /* fake syntax tree node */
- SV* sv;
- dSP;
+ SV** sp = stack_sp;
+ I32 oldmark = sp - stack_base;
+ I32 retval;
+ jmp_buf oldtop;
+ I32 oldscope;
- ENTER;
- SAVETMPS;
+ if (flags & G_DISCARD) {
+ ENTER;
+ SAVETMPS;
+ }
+
SAVESPTR(op);
- sv = sv_newmortal();
- sv_setpv(sv, pv);
op = (OP*)&myop;
Zero(op, 1, UNOP);
- XPUSHs(sv);
+ EXTEND(stack_sp, 1);
+ *++stack_sp = sv;
+ oldscope = scopestack_ix;
- myop.op_type = OP_REQUIRE;
+ if (!(flags & G_NOARGS))
+ myop.op_flags = OPf_STACKED;
myop.op_next = Nullop;
- myop.op_private = 1;
- myop.op_flags = OPf_KNOW;
+ myop.op_flags |= OPf_KNOW;
+ if (flags & G_ARRAY)
+ myop.op_flags |= OPf_LIST;
- PUTBACK;
- if (op = pp_require())
+ Copy(top_env, oldtop, 1, jmp_buf);
+
+restart:
+ switch (setjmp(top_env)) {
+ case 0:
+ break;
+ case 1:
+#ifdef VMS
+ statusvalue = 255; /* XXX I don't think we use 1 anymore. */
+#else
+ statusvalue = 1;
+#endif
+ /* FALL THROUGH */
+ case 2:
+ /* my_exit() was called */
+ curstash = defstash;
+ FREETMPS;
+ Copy(oldtop, top_env, 1, jmp_buf);
+ if (statusvalue)
+ croak("Callback called exit");
+ my_exit(statusvalue);
+ /* NOTREACHED */
+ case 3:
+ if (restartop) {
+ op = restartop;
+ restartop = 0;
+ goto restart;
+ }
+ stack_sp = stack_base + oldmark;
+ if (flags & G_ARRAY)
+ retval = 0;
+ else {
+ retval = 1;
+ *++stack_sp = &sv_undef;
+ }
+ goto cleanup;
+ }
+
+ if (op == (OP*)&myop)
+ op = pp_entereval();
+ if (op)
run();
- stack_sp--;
- FREETMPS;
- LEAVE;
+ retval = stack_sp - (stack_base + oldmark);
+ if ((flags & G_EVAL) && !(flags & G_KEEPERR))
+ sv_setpv(GvSV(errgv),"");
+
+ cleanup:
+ Copy(oldtop, top_env, 1, jmp_buf);
+ if (flags & G_DISCARD) {
+ stack_sp = stack_base + oldmark;
+ retval = 0;
+ FREETMPS;
+ LEAVE;
+ }
+ return retval;
+}
+
+/* Require a module. */
+
+void
+perl_require_pv(pv)
+char* pv;
+{
+ SV* sv = sv_newmortal();
+ sv_setpv(sv, "require '");
+ sv_catpv(sv, pv);
+ sv_catpv(sv, "'");
+ perl_eval_sv(sv, G_DISCARD);
}
void
sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
}
-#ifdef DOSISH
-#define PERLLIB_SEP ';'
+#if defined(DOSISH)
+# define PERLLIB_SEP ';'
#else
-#define PERLLIB_SEP ':'
+# if defined(VMS)
+# define PERLLIB_SEP '|'
+# else
+# define PERLLIB_SEP ':'
+# endif
#endif
static void
}
}
+void
+usage(name)
+char *name;
+{
+ printf("\nUsage: %s [switches] [filename] [arguments]\n",name);
+ printf("\n -0[octal] specify record separator (\\0, if no argument)");
+ printf("\n -a autosplit mode with -n or -p");
+ printf("\n -c check syntax only (runs BEGIN and END blocks)");
+ printf("\n -d run scripts under debugger");
+ printf("\n -D[number/list] set debugging flags (argument is a bit mask or flags)");
+ printf("\n -e command one line of script, multiple -e options are allowed");
+ printf("\n [filename] can be ommitted when -e is used");
+ printf("\n -F regexp regular expression for autosplit (-a)");
+ printf("\n -i[extension] edit <> files in place (make backup if extension supplied)");
+ printf("\n -Idirectory specify include directory (may be used more then once)");
+ printf("\n -l[octal] enable line ending processing, specifies line teminator");
+ printf("\n -n assume 'while (<>) { ... }' loop arround your script");
+ printf("\n -p assume loop like -n but print line also like sed");
+ printf("\n -P run script through C preprocessor before compilation");
+#ifdef OS2
+ printf("\n -R enable REXX variable pool");
+#endif
+ printf("\n -s enable some switch parsing for switches after script name");
+ printf("\n -S look for the script using PATH environment variable");
+ printf("\n -T turn on tainting checks");
+ printf("\n -u dump core after parsing script");
+ printf("\n -U allow unsafe operations");
+ printf("\n -v print version number and patchlevel of perl");
+ printf("\n -w turn warnings on for compilation of your script");
+ printf("\n -x[directory] strip off text before #!perl line and perhaps cd to directory\n");
+}
+
/* This routine handles any switches that can be given during run */
char *
return s;
case 'd':
taint_not("-d");
+ s++;
+ if (*s == ':') {
+ sprintf(buf, "use Devel::%s;", ++s);
+ s += strlen(s);
+ my_setenv("PERL5DB",buf);
+ }
if (!perldb) {
perldb = TRUE;
init_debugger();
}
- s++;
return s;
case 'D':
#ifdef DEBUGGING
#endif
/*SUPPRESS 530*/
return s;
+ case 'h':
+ usage(origargv[0]);
+ exit(0);
case 'i':
if (inplace)
Safefree(inplace);
case 'I':
taint_not("-I");
if (*++s) {
- av_push(GvAVn(incgv),newSVpv(s,0));
+ char *e;
+ for (e = s; *e && !isSPACE(*e); e++) ;
+ av_push(GvAVn(incgv),newSVpv(s,e-s));
+ if (*e)
+ return e;
}
else
croak("No space allowed after -I");
s++;
return s;
case 'v':
- printf("\nThis is perl, version %s\n\n",patchlevel);
- fputs("\nCopyright 1987-1994, Larry Wall\n",stdout);
+ printf("\nThis is perl, version %s beta1g\n\n",patchlevel);
+ fputs("\nCopyright 1987-1995, Larry Wall\n",stdout);
#ifdef MSDOS
fputs("MS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n",
stdout);
+#endif
#ifdef OS2
- fputs("OS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n",
+ fputs("OS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
+ "Version 5 port Copyright (c) 1994-1995, Andreas Kaiser\n",
stdout);
#endif
-#endif
#ifdef atarist
fputs("atariST series port, ++jrb bammi@cadence.com\n", stdout);
#endif
incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
SvMULTI_on(incgv);
defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
+ errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
+ SvMULTI_on(errgv);
curstash = defstash;
compiling.cop_stash = defstash;
debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
+ /* We must init $/ before switches are processed. */
+ sv_setpvn(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), "\n", 1);
}
#ifdef CAN_PROTOTYPE
if (geteuid() != uid)
croak("Can't do seteuid!\n");
}
- uid = (int)getuid();
- euid = (int)geteuid();
- gid = (int)getgid();
- egid = (int)getegid();
- tainting |= (euid != uid || egid != gid);
+ init_ids();
if (!cando(S_IXUSR,TRUE,&statbuf))
croak("Permission denied\n"); /* they can't do this */
}
}
static void
-init_debugger()
+init_ids()
{
- GV* tmpgv;
+ uid = (int)getuid();
+ euid = (int)geteuid();
+ gid = (int)getgid();
+ egid = (int)getegid();
+#ifdef VMS
+ uid |= gid << 16;
+ euid |= egid << 16;
+#endif
+ tainting |= (uid && (euid != uid || egid != gid));
+}
+static void
+init_debugger()
+{
curstash = debstash;
- dbargs = GvAV(gv_AVadd((tmpgv = gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
+ dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
AvREAL_off(dbargs);
DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
- DBsub = gv_HVadd(tmpgv = gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
- DBsingle = GvSV((tmpgv = gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
- DBtrace = GvSV((tmpgv = gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
- DBsignal = GvSV((tmpgv = gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
+ DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
+ DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
+ DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
+ DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
curstash = defstash;
}
tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
SvMULTI_on(tmpgv);
IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = stdout;
- defoutgv = tmpgv;
+ setdefout(tmpgv);
tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(defoutgv));
SvMULTI_on(tmpgv);
toptarget = NEWSV(0,0);
sv_upgrade(toptarget, SVt_PVFM);
sv_setpvn(toptarget, "", 0);
- tmpgv = gv_fetchpv("\001",TRUE, SVt_PV);
- bodytarget = GvSV(tmpgv);
+ bodytarget = NEWSV(0,0);
sv_upgrade(bodytarget, SVt_PVFM);
sv_setpvn(bodytarget, "", 0);
formtarget = bodytarget;
hv = GvHVn(envgv);
hv_clear(hv);
#ifndef VMS /* VMS doesn't have environ array */
+ /* Note that if the supplied env parameter is actually a copy
+ of the global environ then it may now point to free'd memory
+ if the environment has been modified since. To avoid this
+ problem we treat env==NULL as meaning 'use the default'
+ */
+ if (!env)
+ env = environ;
if (env != environ) {
environ[0] = Nullch;
hv_magic(hv, envgv, 'E');
incpush(getenv("PERLLIB"));
}
+#ifdef APPLLIB_EXP
+ incpush(APPLLIB_EXP);
+#endif
+
#ifdef ARCHLIB_EXP
incpush(ARCHLIB_EXP);
#endif
#define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
#endif
incpush(PRIVLIB_EXP);
+
+#ifdef SITEARCH_EXP
+ incpush(SITEARCH_EXP);
+#endif
+#ifdef SITELIB_EXP
+ incpush(SITELIB_EXP);
+#endif
+#ifdef OLDARCHLIB_EXP /* 5.00[01] compatibility */
+ incpush(OLDARCHLIB_EXP);
+#endif
- av_push(GvAVn(incgv),newSVpv(".",1));
+ if (!tainting)
+ incpush(".");
}
void
AV* list;
{
jmp_buf oldtop;
- char *mess;
STRLEN len;
line_t oldline = curcop->cop_line;
SAVEFREESV(cv);
switch (setjmp(top_env)) {
- case 0:
- PUSHMARK(stack_sp);
- perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
- mess = SvPVx(GvSV(gv_fetchpv("@",TRUE, SVt_PV)), len);
- if (len) {
- Copy(oldtop, top_env, 1, jmp_buf);
- curcop = &compiling;
- curcop->cop_line = oldline;
- if (list == beginav)
- croak("%sBEGIN failed--compilation aborted", mess);
- else
- croak("%sEND failed--cleanup aborted", mess);
+ case 0: {
+ SV* atsv = GvSV(errgv);
+ PUSHMARK(stack_sp);
+ perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
+ (void)SvPV(atsv, len);
+ if (len) {
+ Copy(oldtop, top_env, 1, jmp_buf);
+ curcop = &compiling;
+ curcop->cop_line = oldline;
+ if (list == beginav)
+ sv_catpv(atsv, "BEGIN failed--compilation aborted");
+ else
+ sv_catpv(atsv, "END failed--cleanup aborted");
+ croak("%s", SvPVX(atsv));
+ }
}
break;
case 1:
+#ifdef VMS
statusvalue = 255; /* XXX I don't think we use 1 anymore. */
+#else
+ statusvalue = 1;
+#endif
/* FALL THROUGH */
case 2:
/* my_exit() was called */