3 * Copyright (c) 1987-1996 Larry Wall
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
11 * "A ship then new they built for him/of mithril and of elven glass" --Bilbo
16 #include "patchlevel.h"
18 /* Omit -- it causes too much grief on mixed systems.
24 dEXT char rcsid[] = "perl.c\nPatch level: ###\n";
32 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
38 static void find_beginning _((void));
39 static void incpush _((char *));
40 static void init_ids _((void));
41 static void init_debugger _((void));
42 static void init_lexer _((void));
43 static void init_main_stash _((void));
44 static void init_perllib _((void));
45 static void init_postdump_symbols _((int, char **, char **));
46 static void init_predump_symbols _((void));
47 static void init_stacks _((void));
48 static void open_script _((char *, bool, SV *));
49 static void validate_suid _((char *));
54 PerlInterpreter *sv_interp;
57 New(53, sv_interp, 1, PerlInterpreter);
62 perl_construct( sv_interp )
63 register PerlInterpreter *sv_interp;
65 if (!(curinterp = sv_interp))
69 Zero(sv_interp, 1, PerlInterpreter);
72 /* Init the real globals? */
74 linestr = NEWSV(65,80);
75 sv_upgrade(linestr,SVt_PVIV);
77 SvREADONLY_on(&sv_undef);
81 SvREADONLY_on(&sv_no);
83 sv_setpv(&sv_yes,Yes);
85 SvREADONLY_on(&sv_yes);
87 nrs = newSVpv("\n", 1);
88 rs = SvREFCNT_inc(nrs);
92 * There is no way we can refer to them from Perl so close them to save
93 * space. The other alternative would be to provide STDAUX and STDPRN
118 #if defined(SUBVERSION) && SUBVERSION > 0
119 sprintf(patchlevel, "%7.5f", 5.0 + (PATCHLEVEL / 1000.0)
120 + (SUBVERSION / 100000.0));
122 sprintf(patchlevel, "%5.3f", 5.0 + (PATCHLEVEL / 1000.0));
125 fdpid = newAV(); /* for remembering popen pids by fd */
126 pidstatus = newHV();/* for remembering status of dead pids */
133 perl_destruct(sv_interp)
134 register PerlInterpreter *sv_interp;
136 int destruct_level; /* 0=none, 1=full, 2=full with checks */
140 if (!(curinterp = sv_interp))
143 destruct_level = perl_destruct_level;
147 if (s = getenv("PERL_DESTRUCT_LEVEL"))
148 destruct_level = atoi(s);
156 /* We must account for everything. First the syntax tree. */
158 curpad = AvARRAY(comppad);
165 * Try to destruct global references. We do this first so that the
166 * destructors and destructees still exist. Some sv's might remain.
167 * Non-referenced objects are on their own.
174 if (destruct_level == 0){
176 DEBUG_P(debprofdump());
178 /* The exit() function will do everything that needs doing. */
182 /* Prepare to destruct main symbol table. */
188 if (destruct_level >= 2) {
189 if (scopestack_ix != 0)
190 warn("Unbalanced scopes: %d more ENTERs than LEAVEs\n", scopestack_ix);
191 if (savestack_ix != 0)
192 warn("Unbalanced saves: %d more saves than restores\n", savestack_ix);
193 if (tmps_floor != -1)
194 warn("Unbalanced tmps: %d more allocs than frees\n", tmps_floor + 1);
195 if (cxstack_ix != -1)
196 warn("Unbalanced context: %d more PUSHes than POPs\n", cxstack_ix + 1);
199 /* Now absolutely destruct everything, somehow or other, loops or no. */
201 while (sv_count != 0 && sv_count != last_sv_count) {
202 last_sv_count = sv_count;
206 warn("Scalars leaked: %d\n", sv_count);
209 DEBUG_P(debprofdump());
214 PerlInterpreter *sv_interp;
216 if (!(curinterp = sv_interp))
220 #if !defined(STANDARD_C) && !defined(HAS_GETENV_PROTOTYPE)
221 char *getenv _((char *)); /* Usually in <stdlib.h> */
225 perl_parse(sv_interp, xsinit, argc, argv, env)
226 PerlInterpreter *sv_interp;
227 void (*xsinit)_((void));
234 char *scriptname = NULL;
235 VOL bool dosearch = FALSE;
239 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
242 croak("suidperl is no longer needed since the kernel can now execute\n\
243 setuid perl scripts securely.\n");
247 if (!(curinterp = sv_interp))
252 #ifndef VMS /* VMS doesn't have environ array */
253 origenviron = environ;
258 /* Come here if running an undumped a.out. */
260 origfilename = savepv(argv[0]);
262 cxstack_ix = -1; /* start label stack again */
264 init_postdump_symbols(argc,argv,env);
272 switch (Sigsetjmp(top_env,1)) {
283 return(statusvalue); /* my_exit() was called */
285 fprintf(stderr, "panic: top_env\n");
289 sv_setpvn(linestr,"",0);
290 sv = newSVpv("",0); /* first used for -I flags */
293 for (argc--,argv++; argc > 0; argc--,argv++) {
294 if (argv[0][0] != '-' || !argv[0][1])
298 validarg = " PHOOEY ";
324 if (s = moreswitches(s))
329 if (euid != uid || egid != gid)
330 croak("No -e allowed in setuid scripts");
332 e_tmpname = savepv(TMPPATH);
333 (void)mktemp(e_tmpname);
335 croak("Can't mktemp()");
336 e_fp = fopen(e_tmpname,"w");
338 croak("Cannot open temporary file");
344 (void)putc('\n', e_fp);
352 av_push(GvAVn(incgv),newSVpv(s,0));
355 av_push(GvAVn(incgv),newSVpv(argv[1],0));
356 sv_catpv(sv,argv[1]);
373 preambleav = newAV();
374 av_push(preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
376 Sv = newSVpv("print myconfig(),'@INC: '.\"@INC\\n\"",0);
379 Sv = newSVpv("config_vars(qw(",0);
384 av_push(preambleav, Sv);
385 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
399 croak("Unrecognized switch: -%s",s);
404 scriptname = argv[0];
406 if (Fflush(e_fp) || ferror(e_fp) || fclose(e_fp))
407 croak("Can't write to temp file for -e: %s", Strerror(errno));
409 scriptname = e_tmpname;
411 else if (scriptname == Nullch) {
413 if ( isatty(fileno(stdin)) )
421 open_script(scriptname,dosearch,sv);
423 validate_suid(validarg);
428 compcv = (CV*)NEWSV(1104,0);
429 sv_upgrade((SV *)compcv, SVt_PVCV);
433 av_push(comppad, Nullsv);
434 curpad = AvARRAY(comppad);
436 comppad_name = padname;
437 comppad_name_fill = 0;
438 min_intro_pending = 0;
441 comppadlist = newAV();
442 AvREAL_off(comppadlist);
443 av_store(comppadlist, 0, (SV*)comppad_name);
444 av_store(comppadlist, 1, (SV*)comppad);
445 CvPADLIST(compcv) = comppadlist;
448 (*xsinit)(); /* in case linked C routines want magical variables */
453 init_predump_symbols();
455 init_postdump_symbols(argc,argv,env);
459 /* now parse the script */
462 if (yyparse() || error_count) {
464 croak("%s had compilation errors.\n", origfilename);
466 croak("Execution of %s aborted due to compilation errors.\n",
470 curcop->cop_line = 0;
476 (void)UNLINK(e_tmpname);
479 /* now that script is parsed, we can modify record separator */
481 rs = SvREFCNT_inc(nrs);
482 sv_setsv(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), rs);
493 #ifdef DEBUGGING_MSTATS
494 if ((s=getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
495 dump_mstats("after compilation:");
505 PerlInterpreter *sv_interp;
507 if (!(curinterp = sv_interp))
509 switch (Sigsetjmp(top_env,1)) {
511 cxstack_ix = -1; /* start context stack again */
518 #ifdef DEBUGGING_MSTATS
519 if (getenv("PERL_DEBUG_MSTATS"))
520 dump_mstats("after execution: ");
522 return(statusvalue); /* my_exit() was called */
525 fprintf(stderr, "panic: restartop\n");
529 if (stack != mainstack) {
531 SWITCHSTACK(stack, mainstack);
538 DEBUG(fprintf(stderr,"\nEXECUTING...\n\n"));
541 fprintf(stderr,"%s syntax OK\n", origfilename);
544 if (perldb && DBsingle)
545 sv_setiv(DBsingle, 1);
555 else if (main_start) {
568 register CONTEXT *cx;
572 statusvalue = FIXSTATUS(status);
573 if (cxstack_ix >= 0) {
579 Siglongjmp(top_env, 2);
583 perl_get_sv(name, create)
587 GV* gv = gv_fetchpv(name, create, SVt_PV);
594 perl_get_av(name, create)
598 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
607 perl_get_hv(name, create)
611 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
620 perl_get_cv(name, create)
624 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
625 if (create && !GvCV(gv))
626 return newSUB(start_subparse(),
627 newSVOP(OP_CONST, 0, newSVpv(name,0)),
635 /* Be sure to refetch the stack pointer after calling these routines. */
638 perl_call_argv(subname, flags, argv)
640 I32 flags; /* See G_* flags in cop.h */
641 register char **argv; /* null terminated arg list */
648 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
653 return perl_call_pv(subname, flags);
657 perl_call_pv(subname, flags)
658 char *subname; /* name of the subroutine */
659 I32 flags; /* See G_* flags in cop.h */
661 return perl_call_sv((SV*)perl_get_cv(subname, TRUE), flags);
665 perl_call_method(methname, flags)
666 char *methname; /* name of the subroutine */
667 I32 flags; /* See G_* flags in cop.h */
673 XPUSHs(sv_2mortal(newSVpv(methname,0)));
676 return perl_call_sv(*stack_sp--, flags);
679 /* May be called with any of a CV, a GV, or an SV containing the name. */
681 perl_call_sv(sv, flags)
683 I32 flags; /* See G_* flags in cop.h */
685 LOGOP myop; /* fake syntax tree node */
687 I32 oldmark = TOPMARK;
692 if (flags & G_DISCARD) {
702 oldscope = scopestack_ix;
704 if (!(flags & G_NOARGS))
705 myop.op_flags = OPf_STACKED;
706 myop.op_next = Nullop;
707 myop.op_flags |= OPf_KNOW;
709 myop.op_flags |= OPf_LIST;
711 if (flags & G_EVAL) {
712 Copy(top_env, oldtop, 1, Sigjmp_buf);
714 cLOGOP->op_other = op;
716 /* we're trying to emulate pp_entertry() here */
718 register CONTEXT *cx;
724 push_return(op->op_next);
725 PUSHBLOCK(cx, CXt_EVAL, stack_sp);
727 eval_root = op; /* Only needed so that goto works right. */
730 if (flags & G_KEEPERR)
733 sv_setpv(GvSV(errgv),"");
738 switch (Sigsetjmp(top_env,1)) {
743 statusvalue = 255; /* XXX I don't think we use 1 anymore. */
749 /* my_exit() was called */
752 Copy(oldtop, top_env, 1, Sigjmp_buf);
754 croak("Callback called exit");
755 my_exit(statusvalue);
763 stack_sp = stack_base + oldmark;
768 *++stack_sp = &sv_undef;
774 if (op == (OP*)&myop)
778 retval = stack_sp - (stack_base + oldmark);
779 if ((flags & G_EVAL) && !(flags & G_KEEPERR))
780 sv_setpv(GvSV(errgv),"");
783 if (flags & G_EVAL) {
784 if (scopestack_ix > oldscope) {
788 register CONTEXT *cx;
797 Copy(oldtop, top_env, 1, Sigjmp_buf);
799 if (flags & G_DISCARD) {
800 stack_sp = stack_base + oldmark;
811 perl_eval_sv(sv, flags)
813 I32 flags; /* See G_* flags in cop.h */
815 UNOP myop; /* fake syntax tree node */
817 I32 oldmark = sp - stack_base;
822 if (flags & G_DISCARD) {
832 oldscope = scopestack_ix;
834 if (!(flags & G_NOARGS))
835 myop.op_flags = OPf_STACKED;
836 myop.op_next = Nullop;
837 myop.op_flags |= OPf_KNOW;
839 myop.op_flags |= OPf_LIST;
841 Copy(top_env, oldtop, 1, Sigjmp_buf);
844 switch (Sigsetjmp(top_env,1)) {
849 statusvalue = 255; /* XXX I don't think we use 1 anymore. */
855 /* my_exit() was called */
858 Copy(oldtop, top_env, 1, Sigjmp_buf);
860 croak("Callback called exit");
861 my_exit(statusvalue);
869 stack_sp = stack_base + oldmark;
874 *++stack_sp = &sv_undef;
879 if (op == (OP*)&myop)
883 retval = stack_sp - (stack_base + oldmark);
884 if ((flags & G_EVAL) && !(flags & G_KEEPERR))
885 sv_setpv(GvSV(errgv),"");
888 Copy(oldtop, top_env, 1, Sigjmp_buf);
889 if (flags & G_DISCARD) {
890 stack_sp = stack_base + oldmark;
898 /* Require a module. */
904 SV* sv = sv_newmortal();
905 sv_setpv(sv, "require '");
908 perl_eval_sv(sv, G_DISCARD);
912 magicname(sym,name,namlen)
919 if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
920 sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
924 # define PERLLIB_SEP ';'
927 # define PERLLIB_SEP '|'
929 # define PERLLIB_SEP ':'
942 /* Break at all separators */
944 /* First, skip any consecutive separators */
945 while ( *p == PERLLIB_SEP ) {
946 /* Uncomment the next line for PATH semantics */
947 /* av_push(GvAVn(incgv), newSVpv(".", 1)); */
950 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
951 av_push(GvAVn(incgv), newSVpv(p, (STRLEN)(s - p)));
954 av_push(GvAVn(incgv), newSVpv(p, 0));
961 usage(name) /* XXX move this out into a module ? */
964 printf("\nUsage: %s [switches] [filename] [arguments]\n",name);
965 printf("\n -0[octal] specify record separator (\\0, if no argument)");
966 printf("\n -a autosplit mode with -n or -p");
967 printf("\n -c check syntax only (runs BEGIN and END blocks)");
968 printf("\n -d[:debugger] run scripts under debugger");
969 printf("\n -D[number/list] set debugging flags (argument is a bit mask or flags)");
970 printf("\n -e command one line of script, multiple -e options are allowed");
971 printf("\n [filename] can be ommitted when -e is used");
972 printf("\n -F regexp regular expression for autosplit (-a)");
973 printf("\n -i[extension] edit <> files in place (make backup if extension supplied)");
974 printf("\n -Idirectory specify include directory (may be used more then once)");
975 printf("\n -l[octal] enable line ending processing, specifies line teminator");
976 printf("\n -n assume 'while (<>) { ... }' loop arround your script");
977 printf("\n -p assume loop like -n but print line also like sed");
978 printf("\n -P run script through C preprocessor before compilation");
980 printf("\n -R enable REXX variable pool");
982 printf("\n -s enable some switch parsing for switches after script name");
983 printf("\n -S look for the script using PATH environment variable");
984 printf("\n -T turn on tainting checks");
985 printf("\n -u dump core after parsing script");
986 printf("\n -U allow unsafe operations");
987 printf("\n -v print version number and patchlevel of perl");
988 printf("\n -V[:variable] print perl configuration information");
989 printf("\n -w turn warnings on for compilation of your script");
990 printf("\n -x[directory] strip off text before #!perl line and perhaps cd to directory\n");
993 /* This routine handles any switches that can be given during run */
1004 rschar = scan_oct(s, 4, &numlen);
1006 if (rschar & ~((U8)~0))
1008 else if (!rschar && numlen >= 2)
1009 nrs = newSVpv("", 0);
1012 nrs = newSVpv(&ch, 1);
1017 splitstr = savepv(s + 1);
1031 if (*s == ':' || *s == '=') {
1032 sprintf(buf, "use Devel::%s;", ++s);
1034 my_setenv("PERL5DB",buf);
1044 if (isALPHA(s[1])) {
1045 static char debopts[] = "psltocPmfrxuLHXD";
1048 for (s++; *s && (d = strchr(debopts,*s)); s++)
1049 debug |= 1 << (d - debopts);
1053 for (s++; isDIGIT(*s); s++) ;
1055 debug |= 0x80000000;
1057 warn("Recompile perl with -DDEBUGGING to use -D switch\n");
1058 for (s++; isALNUM(*s); s++) ;
1068 inplace = savepv(s+1);
1070 for (s = inplace; *s && !isSPACE(*s); s++) ;
1077 for (e = s; *e && !isSPACE(*e); e++) ;
1078 av_push(GvAVn(incgv),newSVpv(s,e-s));
1083 croak("No space allowed after -I");
1093 *ors = scan_oct(s, 3 + (*s == '0'), &numlen);
1098 ors = savepvn("\n\n", 2);
1102 ors = SvPV(nrs, orslen);
1106 taint_not("-M"); /* XXX ? */
1109 taint_not("-m"); /* XXX ? */
1113 /* -M-foo == 'no foo' */
1114 if (*s == '-') { use = "no "; ++s; }
1115 Sv = newSVpv(use,0);
1117 /* We allow -M'Module qw(Foo Bar)' */
1118 while(isALNUM(*s) || *s==':') ++s;
1120 sv_catpv(Sv, start);
1121 if (*(start-1) == 'm') {
1123 croak("Can't use '%c' after -mname", *s);
1124 sv_catpv( Sv, " ()");
1127 sv_catpvn(Sv, start, s-start);
1128 sv_catpv(Sv, " split(/,/,q{");
1133 if (preambleav == NULL)
1134 preambleav = newAV();
1135 av_push(preambleav, Sv);
1138 croak("No space allowed after -%c", *(s-1));
1166 #if defined(SUBVERSION) && SUBVERSION > 0
1167 printf("\nThis is perl, version 5.%03d_%02d", PATCHLEVEL, SUBVERSION);
1169 printf("\nThis is perl, version %s",patchlevel);
1172 #if defined(DEBUGGING) || defined(EMBED) || defined(MULTIPLICITY)
1173 fputs(" with", stdout);
1175 fputs(" DEBUGGING", stdout);
1178 fputs(" EMBED", stdout);
1181 fputs(" MULTIPLICITY", stdout);
1185 fputs("\n\nCopyright 1987-1996, Larry Wall\n",stdout);
1187 fputs("MS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n",
1191 fputs("OS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
1192 "Version 5 port Copyright (c) 1994-1995, Andreas Kaiser\n", stdout);
1195 fputs("atariST series port, ++jrb bammi@cadence.com\n", stdout);
1198 Perl may be copied only under the terms of either the Artistic License or the\n\
1199 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n",stdout);
1210 if (s[1] == '-') /* Additional switches on #! line. */
1223 croak("Can't emulate -%.1s on #! line",s);
1228 /* compliments of Tom Christiansen */
1230 /* unexec() can be found in the Gnu emacs distribution */
1239 sprintf (buf, "%s.perldump", origfilename);
1240 sprintf (tokenbuf, "%s/perl", BIN);
1242 status = unexec(buf, tokenbuf, &etext, sbrk(0), 0);
1244 fprintf(stderr, "unexec of %s into %s failed!\n", tokenbuf, buf);
1248 # include <lib$routines.h>
1249 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
1251 ABORT(); /* for use with undump */
1260 curstash = defstash = newHV();
1261 curstname = newSVpv("main",4);
1262 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
1263 SvREFCNT_dec(GvHV(gv));
1264 GvHV(gv) = (HV*)SvREFCNT_inc(defstash);
1266 HvNAME(defstash) = savepv("main");
1267 incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
1269 defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
1270 errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
1272 curstash = defstash;
1273 compiling.cop_stash = defstash;
1274 debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
1275 /* We must init $/ before switches are processed. */
1276 sv_setpvn(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), "\n", 1);
1279 #ifdef CAN_PROTOTYPE
1281 open_script(char *scriptname, bool dosearch, SV *sv)
1284 open_script(scriptname,dosearch,sv)
1290 char *xfound = Nullch;
1291 char *xfailed = Nullch;
1295 #if defined(DOSISH) && !defined(OS2) && !defined(atarist)
1296 #define SEARCH_EXTS ".bat", ".cmd", NULL
1298 /* additional extensions to try in each dir if scriptname not found */
1300 char *ext[] = { SEARCH_EXTS };
1301 int extidx = (strchr(scriptname,'.')) ? -1 : 0; /* has ext already */
1305 if (dosearch && !strpbrk(scriptname,":[</") && (my_getenv("DCL$PATH"))) {
1308 while (my_trnlnm("DCL$PATH",tokenbuf,idx++)) {
1309 strcat(tokenbuf,scriptname);
1311 if (dosearch && !strchr(scriptname, '/') && (s = getenv("PATH"))) {
1313 bufend = s + strlen(s);
1316 s = cpytill(tokenbuf,s,bufend,':',&len);
1319 for (len = 0; *s && *s != ',' && *s != ';'; tokenbuf[len++] = *s++);
1320 tokenbuf[len] = '\0';
1322 for (len = 0; *s && *s != ';'; tokenbuf[len++] = *s++);
1323 tokenbuf[len] = '\0';
1329 if (len && tokenbuf[len-1] != '/')
1332 if (len && ((tokenbuf[len-1] != '\\') && (tokenbuf[len-1] != '/')))
1334 if (len && tokenbuf[len-1] != '\\')
1337 (void)strcat(tokenbuf+len,"/");
1338 (void)strcat(tokenbuf+len,scriptname);
1342 len = strlen(tokenbuf);
1343 if (extidx > 0) /* reset after previous loop */
1347 DEBUG_p(fprintf(stderr,"Looking for %s\n",tokenbuf));
1348 retval = Stat(tokenbuf,&statbuf);
1350 } while ( retval < 0 /* not there */
1351 && extidx>=0 && ext[extidx] /* try an extension? */
1352 && strcpy(tokenbuf+len, ext[extidx++])
1357 if (S_ISREG(statbuf.st_mode)
1358 && cando(S_IRUSR,TRUE,&statbuf) && cando(S_IXUSR,TRUE,&statbuf)) {
1359 xfound = tokenbuf; /* bingo! */
1363 xfailed = savepv(tokenbuf);
1366 croak("Can't execute %s", xfailed ? xfailed : scriptname );
1369 scriptname = xfound;
1372 origfilename = savepv(e_fp ? "-e" : scriptname);
1373 curcop->cop_filegv = gv_fetchfile(origfilename);
1374 if (strEQ(origfilename,"-"))
1377 char *cpp = CPPSTDIN;
1379 if (strEQ(cpp,"cppstdin"))
1380 sprintf(tokenbuf, "%s/%s", SCRIPTDIR, cpp);
1382 sprintf(tokenbuf, "%s", cpp);
1384 sv_catpv(sv,PRIVLIB_EXP);
1386 (void)sprintf(buf, "\
1387 sed %s -e \"/^[^#]/b\" \
1388 -e \"/^#[ ]*include[ ]/b\" \
1389 -e \"/^#[ ]*define[ ]/b\" \
1390 -e \"/^#[ ]*if[ ]/b\" \
1391 -e \"/^#[ ]*ifdef[ ]/b\" \
1392 -e \"/^#[ ]*ifndef[ ]/b\" \
1393 -e \"/^#[ ]*else/b\" \
1394 -e \"/^#[ ]*elif[ ]/b\" \
1395 -e \"/^#[ ]*undef[ ]/b\" \
1396 -e \"/^#[ ]*endif/b\" \
1399 (doextract ? "-e \"1,/^#/d\n\"" : ""),
1401 (void)sprintf(buf, "\
1402 %s %s -e '/^[^#]/b' \
1403 -e '/^#[ ]*include[ ]/b' \
1404 -e '/^#[ ]*define[ ]/b' \
1405 -e '/^#[ ]*if[ ]/b' \
1406 -e '/^#[ ]*ifdef[ ]/b' \
1407 -e '/^#[ ]*ifndef[ ]/b' \
1408 -e '/^#[ ]*else/b' \
1409 -e '/^#[ ]*elif[ ]/b' \
1410 -e '/^#[ ]*undef[ ]/b' \
1411 -e '/^#[ ]*endif/b' \
1419 (doextract ? "-e '1,/^#/d\n'" : ""),
1421 scriptname, tokenbuf, SvPV(sv, na), CPPMINUS);
1423 #ifdef IAMSUID /* actually, this is caught earlier */
1424 if (euid != uid && !euid) { /* if running suidperl */
1426 (void)seteuid(uid); /* musn't stay setuid root */
1429 (void)setreuid((Uid_t)-1, uid);
1431 #ifdef HAS_SETRESUID
1432 (void)setresuid((Uid_t)-1, uid, (Uid_t)-1);
1438 if (geteuid() != uid)
1439 croak("Can't do seteuid!\n");
1441 #endif /* IAMSUID */
1442 rsfp = my_popen(buf,"r");
1444 else if (!*scriptname) {
1445 taint_not("program input from stdin");
1449 rsfp = fopen(scriptname,"r");
1450 if ((FILE*)rsfp == Nullfp) {
1452 #ifndef IAMSUID /* in case script is not readable before setuid */
1453 if (euid && Stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 &&
1454 statbuf.st_mode & (S_ISUID|S_ISGID)) {
1455 (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
1456 execv(buf, origargv); /* try again */
1457 croak("Can't do setuid\n");
1461 croak("Can't open perl script \"%s\": %s\n",
1462 SvPVX(GvSV(curcop->cop_filegv)), Strerror(errno));
1467 validate_suid(validarg)
1470 /* do we need to emulate setuid on scripts? */
1472 /* This code is for those BSD systems that have setuid #! scripts disabled
1473 * in the kernel because of a security problem. Merely defining DOSUID
1474 * in perl will not fix that problem, but if you have disabled setuid
1475 * scripts in the kernel, this will attempt to emulate setuid and setgid
1476 * on scripts that have those now-otherwise-useless bits set. The setuid
1477 * root version must be called suidperl or sperlN.NNN. If regular perl
1478 * discovers that it has opened a setuid script, it calls suidperl with
1479 * the same argv that it had. If suidperl finds that the script it has
1480 * just opened is NOT setuid root, it sets the effective uid back to the
1481 * uid. We don't just make perl setuid root because that loses the
1482 * effective uid we had before invoking perl, if it was different from the
1485 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
1486 * be defined in suidperl only. suidperl must be setuid root. The
1487 * Configure script will set this up for you if you want it.
1493 if (Fstat(fileno(rsfp),&statbuf) < 0) /* normal stat is insecure */
1494 croak("Can't stat script \"%s\"",origfilename);
1495 if (statbuf.st_mode & (S_ISUID|S_ISGID)) {
1499 #ifndef HAS_SETREUID
1500 /* On this access check to make sure the directories are readable,
1501 * there is actually a small window that the user could use to make
1502 * filename point to an accessible directory. So there is a faint
1503 * chance that someone could execute a setuid script down in a
1504 * non-accessible directory. I don't know what to do about that.
1505 * But I don't think it's too important. The manual lies when
1506 * it says access() is useful in setuid programs.
1508 if (access(SvPVX(GvSV(curcop->cop_filegv)),1)) /*double check*/
1509 croak("Permission denied");
1511 /* If we can swap euid and uid, then we can determine access rights
1512 * with a simple stat of the file, and then compare device and
1513 * inode to make sure we did stat() on the same file we opened.
1514 * Then we just have to make sure he or she can execute it.
1517 struct stat tmpstatbuf;
1521 setreuid(euid,uid) < 0
1524 setresuid(euid,uid,(Uid_t)-1) < 0
1527 || getuid() != euid || geteuid() != uid)
1528 croak("Can't swap uid and euid"); /* really paranoid */
1529 if (Stat(SvPVX(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0)
1530 croak("Permission denied"); /* testing full pathname here */
1531 if (tmpstatbuf.st_dev != statbuf.st_dev ||
1532 tmpstatbuf.st_ino != statbuf.st_ino) {
1534 if (rsfp = my_popen("/bin/mail root","w")) { /* heh, heh */
1536 "User %d tried to run dev %d ino %d in place of dev %d ino %d!\n\
1537 (Filename of set-id script was %s, uid %d gid %d.)\n\nSincerely,\nperl\n",
1538 uid,tmpstatbuf.st_dev, tmpstatbuf.st_ino,
1539 statbuf.st_dev, statbuf.st_ino,
1540 SvPVX(GvSV(curcop->cop_filegv)),
1541 statbuf.st_uid, statbuf.st_gid);
1542 (void)my_pclose(rsfp);
1544 croak("Permission denied\n");
1548 setreuid(uid,euid) < 0
1550 # if defined(HAS_SETRESUID)
1551 setresuid(uid,euid,(Uid_t)-1) < 0
1554 || getuid() != uid || geteuid() != euid)
1555 croak("Can't reswap uid and euid");
1556 if (!cando(S_IXUSR,FALSE,&statbuf)) /* can real uid exec? */
1557 croak("Permission denied\n");
1559 #endif /* HAS_SETREUID */
1560 #endif /* IAMSUID */
1562 if (!S_ISREG(statbuf.st_mode))
1563 croak("Permission denied");
1564 if (statbuf.st_mode & S_IWOTH)
1565 croak("Setuid/gid script is writable by world");
1566 doswitches = FALSE; /* -s is insecure in suid */
1568 if (fgets(tokenbuf,sizeof tokenbuf, rsfp) == Nullch ||
1569 strnNE(tokenbuf,"#!",2) ) /* required even on Sys V */
1570 croak("No #! line");
1573 while (!isSPACE(*s)) s++;
1574 if (strnNE(s-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
1575 croak("Not a perl script");
1576 while (*s == ' ' || *s == '\t') s++;
1578 * #! arg must be what we saw above. They can invoke it by
1579 * mentioning suidperl explicitly, but they may not add any strange
1580 * arguments beyond what #! says if they do invoke suidperl that way.
1582 len = strlen(validarg);
1583 if (strEQ(validarg," PHOOEY ") ||
1584 strnNE(s,validarg,len) || !isSPACE(s[len]))
1585 croak("Args must match #! line");
1588 if (euid != uid && (statbuf.st_mode & S_ISUID) &&
1589 euid == statbuf.st_uid)
1591 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
1592 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
1593 #endif /* IAMSUID */
1595 if (euid) { /* oops, we're not the setuid root perl */
1598 (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
1599 execv(buf, origargv); /* try again */
1601 croak("Can't do setuid\n");
1604 if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid) {
1606 (void)setegid(statbuf.st_gid);
1609 (void)setregid((Gid_t)-1,statbuf.st_gid);
1611 #ifdef HAS_SETRESGID
1612 (void)setresgid((Gid_t)-1,statbuf.st_gid,(Gid_t)-1);
1614 setgid(statbuf.st_gid);
1618 if (getegid() != statbuf.st_gid)
1619 croak("Can't do setegid!\n");
1621 if (statbuf.st_mode & S_ISUID) {
1622 if (statbuf.st_uid != euid)
1624 (void)seteuid(statbuf.st_uid); /* all that for this */
1627 (void)setreuid((Uid_t)-1,statbuf.st_uid);
1629 #ifdef HAS_SETRESUID
1630 (void)setresuid((Uid_t)-1,statbuf.st_uid,(Uid_t)-1);
1632 setuid(statbuf.st_uid);
1636 if (geteuid() != statbuf.st_uid)
1637 croak("Can't do seteuid!\n");
1639 else if (uid) { /* oops, mustn't run as root */
1641 (void)seteuid((Uid_t)uid);
1644 (void)setreuid((Uid_t)-1,(Uid_t)uid);
1646 #ifdef HAS_SETRESUID
1647 (void)setresuid((Uid_t)-1,(Uid_t)uid,(Uid_t)-1);
1653 if (geteuid() != uid)
1654 croak("Can't do seteuid!\n");
1657 if (!cando(S_IXUSR,TRUE,&statbuf))
1658 croak("Permission denied\n"); /* they can't do this */
1661 else if (preprocess)
1662 croak("-P not allowed for setuid/setgid script\n");
1664 croak("Script is not setuid/setgid in suidperl\n");
1665 #endif /* IAMSUID */
1667 if (euid != uid || egid != gid) { /* (suidperl doesn't exist, in fact) */
1668 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
1669 Fstat(fileno(rsfp),&statbuf); /* may be either wrapped or real suid */
1670 if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
1672 (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
1675 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
1676 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
1677 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
1678 /* not set-id, must be wrapped */
1688 /* skip forward in input to the real script? */
1692 if ((s = sv_gets(linestr, rsfp, 0)) == Nullch)
1693 croak("No Perl script found in input\n");
1694 if (*s == '#' && s[1] == '!' && instr(s,"perl")) {
1695 ungetc('\n',rsfp); /* to keep line count right */
1697 if (s = instr(s,"perl -")) {
1700 while (s = moreswitches(s)) ;
1702 if (cddir && chdir(cddir) < 0)
1703 croak("Can't chdir to %s",cddir);
1711 uid = (int)getuid();
1712 euid = (int)geteuid();
1713 gid = (int)getgid();
1714 egid = (int)getegid();
1719 tainting |= (uid && (euid != uid || egid != gid));
1725 curstash = debstash;
1726 dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
1728 DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
1729 DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
1730 DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
1731 DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
1732 sv_setiv(DBsingle, 0);
1733 DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
1734 sv_setiv(DBtrace, 0);
1735 DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
1736 sv_setiv(DBsignal, 0);
1737 curstash = defstash;
1744 mainstack = stack; /* remember in case we switch stacks */
1745 AvREAL_off(stack); /* not a real array */
1746 av_extend(stack,127);
1748 stack_base = AvARRAY(stack);
1749 stack_sp = stack_base;
1750 stack_max = stack_base + 127;
1752 New(54,markstack,64,I32);
1753 markstack_ptr = markstack;
1754 markstack_max = markstack + 64;
1756 New(54,scopestack,32,I32);
1758 scopestack_max = 32;
1760 New(54,savestack,128,ANY);
1762 savestack_max = 128;
1764 New(54,retstack,16,OP*);
1768 cxstack_max = 8192 / sizeof(CONTEXT) - 2; /* Use most of 8K. */
1769 New(50,cxstack,cxstack_max + 1,CONTEXT);
1772 New(50,tmps_stack,128,SV*);
1777 New(51,debname,128,char);
1778 New(52,debdelim,128,char);
1782 static FILE *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
1790 subname = newSVpv("main",4);
1794 init_predump_symbols()
1799 sv_setpvn(GvSV(gv_fetchpv("\"", TRUE, SVt_PV)), " ", 1);
1801 stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
1802 GvMULTI_on(stdingv);
1803 IoIFP(GvIOp(stdingv)) = stdin;
1804 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
1806 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(stdingv));
1808 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
1810 IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = stdout;
1812 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
1814 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(defoutgv));
1816 othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
1817 GvMULTI_on(othergv);
1818 IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = stderr;
1819 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
1821 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv));
1823 statname = NEWSV(66,0); /* last filename we did stat on */
1827 init_postdump_symbols(argc,argv,env)
1829 register char **argv;
1830 register char **env;
1836 argc--,argv++; /* skip name of script */
1838 for (; argc > 0 && **argv == '-'; argc--,argv++) {
1841 if (argv[0][1] == '-') {
1845 if (s = strchr(argv[0], '=')) {
1847 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
1850 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
1853 toptarget = NEWSV(0,0);
1854 sv_upgrade(toptarget, SVt_PVFM);
1855 sv_setpvn(toptarget, "", 0);
1856 bodytarget = NEWSV(0,0);
1857 sv_upgrade(bodytarget, SVt_PVFM);
1858 sv_setpvn(bodytarget, "", 0);
1859 formtarget = bodytarget;
1862 if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
1863 sv_setpv(GvSV(tmpgv),origfilename);
1864 magicname("0", "0", 1);
1866 if (tmpgv = gv_fetchpv("\024",TRUE, SVt_PV))
1868 if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
1869 sv_setpv(GvSV(tmpgv),origargv[0]);
1870 if (argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
1872 (void)gv_AVadd(argvgv);
1873 av_clear(GvAVn(argvgv));
1874 for (; argc > 0; argc--,argv++) {
1875 av_push(GvAVn(argvgv),newSVpv(argv[0],0));
1878 if (envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
1883 #ifndef VMS /* VMS doesn't have environ array */
1884 /* Note that if the supplied env parameter is actually a copy
1885 of the global environ then it may now point to free'd memory
1886 if the environment has been modified since. To avoid this
1887 problem we treat env==NULL as meaning 'use the default'
1891 if (env != environ) {
1892 environ[0] = Nullch;
1893 hv_magic(hv, envgv, 'E');
1895 for (; *env; env++) {
1896 if (!(s = strchr(*env,'=')))
1899 sv = newSVpv(s--,0);
1900 sv_magic(sv, sv, 'e', *env, s - *env);
1901 (void)hv_store(hv, *env, s - *env, sv, 0);
1905 #ifdef DYNAMIC_ENV_FETCH
1906 HvNAME(hv) = savepv(ENV_HV_NAME);
1908 hv_magic(hv, envgv, 'E');
1911 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
1912 sv_setiv(GvSV(tmpgv),(I32)getpid());
1921 s = getenv("PERL5LIB");
1925 incpush(getenv("PERLLIB"));
1929 incpush(APPLLIB_EXP);
1933 incpush(ARCHLIB_EXP);
1936 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
1938 incpush(PRIVLIB_EXP);
1941 incpush(SITEARCH_EXP);
1944 incpush(SITELIB_EXP);
1946 #ifdef OLDARCHLIB_EXP /* 5.00[01] compatibility */
1947 incpush(OLDARCHLIB_EXP);
1960 line_t oldline = curcop->cop_line;
1962 Copy(top_env, oldtop, 1, Sigjmp_buf);
1964 while (AvFILL(list) >= 0) {
1965 CV *cv = (CV*)av_shift(list);
1969 switch (Sigsetjmp(top_env,1)) {
1971 SV* atsv = GvSV(errgv);
1973 perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
1974 (void)SvPV(atsv, len);
1976 Copy(oldtop, top_env, 1, Sigjmp_buf);
1977 curcop = &compiling;
1978 curcop->cop_line = oldline;
1979 if (list == beginav)
1980 sv_catpv(atsv, "BEGIN failed--compilation aborted");
1982 sv_catpv(atsv, "END failed--cleanup aborted");
1983 croak("%s", SvPVX(atsv));
1989 statusvalue = 255; /* XXX I don't think we use 1 anymore. */
1995 /* my_exit() was called */
1996 curstash = defstash;
2000 Copy(oldtop, top_env, 1, Sigjmp_buf);
2001 curcop = &compiling;
2002 curcop->cop_line = oldline;
2004 if (list == beginav)
2005 croak("BEGIN failed--compilation aborted");
2007 croak("END failed--cleanup aborted");
2009 my_exit(statusvalue);
2014 fprintf(stderr, "panic: restartop\n");
2018 Copy(oldtop, top_env, 1, Sigjmp_buf);
2019 curcop = &compiling;
2020 curcop->cop_line = oldline;
2021 Siglongjmp(top_env, 3);
2025 Copy(oldtop, top_env, 1, Sigjmp_buf);