/* perl.c
*
- * Copyright (c) 1987-1994 Larry Wall
+ * Copyright (c) 1987-1996 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;
chopset = " \n-";
copline = NOLINE;
curcop = &compiling;
+ dbargs = 0;
dlmax = 128;
laststatval = -1;
laststype = OP_STAT;
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());
}
{
register SV *sv;
register char *s;
- char *scriptname;
+ char *scriptname = NULL;
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 'M':
+ case 'm':
case 'n':
case 'p':
case 's':
dosearch = TRUE;
s++;
goto reswitch;
+ case 'V':
+ if (!preambleav)
+ preambleav = newAV();
+ av_push(preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
+ if (*++s != ':') {
+ Sv = newSVpv("print myconfig(),'@INC: '.\"@INC\\n\"",0);
+ }
+ else {
+ Sv = newSVpv("config_vars(qw(",0);
+ sv_catpv(Sv, ++s);
+ sv_catpv(Sv, "))");
+ s += strlen(s);
+ }
+ av_push(preambleav, Sv);
+ scriptname = "/dev/null"; /* don't look for script or read stdin */
+ goto reswitch;
case 'x':
doextract = TRUE;
s++;
}
}
switch_end:
- scriptname = argv[0];
+ if (!scriptname)
+ scriptname = argv[0];
if (e_fp) {
if (fflush(e_fp) || ferror(e_fp) || fclose(e_fp))
croak("Can't write to temp file for -e: %s", Strerror(errno));
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) /* XXX move this out into a module ? */
+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[:debugger] 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 -V[:variable] print perl configuration information");
+ 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");
orslen = nrslen;
}
return s;
+ case 'M':
+ taint_not("-M"); /* XXX ? */
+ /* FALL THROUGH */
+ case 'm':
+ taint_not("-m"); /* XXX ? */
+ if (*++s) {
+ char tmpbuf[90];
+ if (preambleav == NULL)
+ preambleav = newAV();
+ /* We allow -M'Module qw(Foo Bar)' */
+ if (*(s-1) == 'M')
+ sprintf(tmpbuf, "use %s;", s);
+ else
+ sprintf(tmpbuf, "use %s ();", s);
+ av_push(preambleav, newSVpv(tmpbuf,0));
+ s += strlen(s);
+ }
+ else
+ croak("No space allowed after -%c", *(s-1));
+ return s;
case 'n':
minus_n = TRUE;
s++;
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 beta2",patchlevel);
+
+#if defined(DEBUGGING) || defined(EMBED) || defined(MULTIPLICITY)
+ fputs(" with", stdout);
+#ifdef DEBUGGING
+ fputs(" DEBUGGING", stdout);
+#endif
+#ifdef EMBED
+ fputs(" EMBED", stdout);
+#endif
+#ifdef MULTIPLICITY
+ fputs(" MULTIPLICITY", stdout);
+#endif
+#endif
+
+ fputs("\n\nCopyright 1987-1996, Larry Wall\n",stdout);
#ifdef MSDOS
fputs("MS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n",
stdout);
-#ifdef OS2
- fputs("OS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n",
- stdout);
#endif
+#ifdef OS2
+ 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
#ifdef atarist
- fputs("atariST series port, ++jrb bammi@cadence.com\n", stdout);
+ fputs("atariST series port, ++jrb bammi@cadence.com\n", stdout);
#endif
fputs("\n\
Perl may be copied only under the terms of either the Artistic License or the\n\
-GNU General Public License, which may be found in the Perl 5.0 source kit.\n",stdout);
+GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n",stdout);
#ifdef MSDOS
usage(origargv[0]);
#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');
}
-#endif
-#ifdef DYNAMIC_ENV_FETCH
- HvNAME(hv) = savepv(ENV_HV_NAME);
-#endif
for (; *env; env++) {
if (!(s = strchr(*env,'=')))
continue;
(void)hv_store(hv, *env, s - *env, sv, 0);
*s = '=';
}
+#endif
+#ifdef DYNAMIC_ENV_FETCH
+ HvNAME(hv) = savepv(ENV_HV_NAME);
+#endif
hv_magic(hv, envgv, 'E');
}
tainted = 0;
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 */
projects / p5sagit/p5-mst-13.2.git / blobdiff