3 * Copyright (c) 1987-1998 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 /* XXX If this causes problems, set i_unistd=undef in the hint file. */
23 #if !defined(STANDARD_C) && !defined(HAS_GETENV_PROTOTYPE)
24 char *getenv _((char *)); /* Usually in <stdlib.h> */
34 dEXTCONST char rcsid[] = "perl.c\nPatch level: ###\n";
42 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
52 curcop = &compiling; \
59 laststype = OP_STAT; \
61 maxsysfd = MAXSYSFD; \
68 laststype = OP_STAT; \
73 static I32 read_e_script _((CPerlObj* pPerl, int idx, SV *buf_sv, int maxlen));
75 static void find_beginning _((void));
76 static void forbid_setid _((char *));
77 static void incpush _((char *, int));
78 static void init_ids _((void));
79 static void init_debugger _((void));
80 static void init_lexer _((void));
81 static void init_main_stash _((void));
83 static struct perl_thread * init_main_thread _((void));
84 #endif /* USE_THREADS */
85 static void init_perllib _((void));
86 static void init_postdump_symbols _((int, char **, char **));
87 static void init_predump_symbols _((void));
88 static void my_exit_jump _((void)) __attribute__((noreturn));
89 static void nuke_stacks _((void));
90 static void open_script _((char *, bool, SV *, int *fd));
91 static void usage _((char *));
92 static void validate_suid _((char *, char*, int));
93 static I32 read_e_script _((int idx, SV *buf_sv, int maxlen));
97 CPerlObj* perl_alloc(IPerlMem* ipM, IPerlEnv* ipE, IPerlStdIO* ipStd,
98 IPerlLIO* ipLIO, IPerlDir* ipD, IPerlSock* ipS, IPerlProc* ipP)
100 CPerlObj* pPerl = new(ipM) CPerlObj(ipM, ipE, ipStd, ipLIO, ipD, ipS, ipP);
110 PerlInterpreter *sv_interp;
113 New(53, sv_interp, 1, PerlInterpreter);
116 #endif /* PERL_OBJECT */
120 CPerlObj::perl_construct(void)
122 perl_construct(register PerlInterpreter *sv_interp)
128 struct perl_thread *thr;
129 #endif /* FAKE_THREADS */
130 #endif /* USE_THREADS */
133 if (!(curinterp = sv_interp))
138 Zero(sv_interp, 1, PerlInterpreter);
141 /* Init the real globals (and main thread)? */
146 #ifdef ALLOC_THREAD_KEY
149 if (pthread_key_create(&thr_key, 0))
150 croak("panic: pthread_key_create");
152 MUTEX_INIT(&sv_mutex);
154 * Safe to use basic SV functions from now on (though
155 * not things like mortals or tainting yet).
157 MUTEX_INIT(&eval_mutex);
158 COND_INIT(&eval_cond);
159 MUTEX_INIT(&threads_mutex);
160 COND_INIT(&nthreads_cond);
161 #ifdef EMULATE_ATOMIC_REFCOUNTS
162 MUTEX_INIT(&svref_mutex);
163 #endif /* EMULATE_ATOMIC_REFCOUNTS */
165 thr = init_main_thread();
166 #endif /* USE_THREADS */
168 linestr = NEWSV(65,80);
169 sv_upgrade(linestr,SVt_PVIV);
171 if (!SvREADONLY(&sv_undef)) {
172 SvREADONLY_on(&sv_undef);
176 SvREADONLY_on(&sv_no);
178 sv_setpv(&sv_yes,Yes);
180 SvREADONLY_on(&sv_yes);
183 nrs = newSVpv("\n", 1);
184 rs = SvREFCNT_inc(nrs);
188 /* sighandlerp = sighandler; */
190 sighandlerp = sighandler;
196 * There is no way we can refer to them from Perl so close them to save
197 * space. The other alternative would be to provide STDAUX and STDPRN
200 (void)fclose(stdaux);
201 (void)fclose(stdprn);
208 perl_destruct_level = 1;
210 if(perl_destruct_level > 0)
215 lex_state = LEX_NOTPARSING;
217 install_tryblock_method(0); /* default to set/longjmp style tryblock */
218 JMPENV_TOPINIT(start_env);
221 SET_NUMERIC_STANDARD();
222 #if defined(SUBVERSION) && SUBVERSION > 0
223 sprintf(patchlevel, "%7.5f", (double) 5
224 + ((double) PATCHLEVEL / (double) 1000)
225 + ((double) SUBVERSION / (double) 100000));
227 sprintf(patchlevel, "%5.3f", (double) 5 +
228 ((double) PATCHLEVEL / (double) 1000));
231 #if defined(LOCAL_PATCH_COUNT)
232 localpatches = local_patches; /* For possible -v */
235 PerlIO_init(); /* Hook to IO system */
237 fdpid = newAV(); /* for remembering popen pids by fd */
238 modglobal = newHV(); /* pointers to per-interpreter module globals */
241 New(51,debname,128,char);
242 New(52,debdelim,128,char);
250 CPerlObj::perl_destruct(void)
252 perl_destruct(register PerlInterpreter *sv_interp)
256 int destruct_level; /* 0=none, 1=full, 2=full with checks */
261 #endif /* USE_THREADS */
264 if (!(curinterp = sv_interp))
270 /* Pass 1 on any remaining threads: detach joinables, join zombies */
272 MUTEX_LOCK(&threads_mutex);
273 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
274 "perl_destruct: waiting for %d threads...\n",
276 for (t = thr->next; t != thr; t = t->next) {
277 MUTEX_LOCK(&t->mutex);
278 switch (ThrSTATE(t)) {
281 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
282 "perl_destruct: joining zombie %p\n", t));
283 ThrSETSTATE(t, THRf_DEAD);
284 MUTEX_UNLOCK(&t->mutex);
287 * The SvREFCNT_dec below may take a long time (e.g. av
288 * may contain an object scalar whose destructor gets
289 * called) so we have to unlock threads_mutex and start
292 MUTEX_UNLOCK(&threads_mutex);
294 SvREFCNT_dec((SV*)av);
295 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
296 "perl_destruct: joined zombie %p OK\n", t));
298 case THRf_R_JOINABLE:
299 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
300 "perl_destruct: detaching thread %p\n", t));
301 ThrSETSTATE(t, THRf_R_DETACHED);
303 * We unlock threads_mutex and t->mutex in the opposite order
304 * from which we locked them just so that DETACH won't
305 * deadlock if it panics. It's only a breach of good style
306 * not a bug since they are unlocks not locks.
308 MUTEX_UNLOCK(&threads_mutex);
310 MUTEX_UNLOCK(&t->mutex);
313 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
314 "perl_destruct: ignoring %p (state %u)\n",
316 MUTEX_UNLOCK(&t->mutex);
317 /* fall through and out */
320 /* We leave the above "Pass 1" loop with threads_mutex still locked */
322 /* Pass 2 on remaining threads: wait for the thread count to drop to one */
325 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
326 "perl_destruct: final wait for %d threads\n",
328 COND_WAIT(&nthreads_cond, &threads_mutex);
330 /* At this point, we're the last thread */
331 MUTEX_UNLOCK(&threads_mutex);
332 DEBUG_L(PerlIO_printf(PerlIO_stderr(), "perl_destruct: armageddon has arrived\n"));
333 MUTEX_DESTROY(&threads_mutex);
334 COND_DESTROY(&nthreads_cond);
335 #endif /* !defined(FAKE_THREADS) */
336 #endif /* USE_THREADS */
338 destruct_level = perl_destruct_level;
342 if (s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL")) {
344 if (destruct_level < i)
353 /* We must account for everything. */
355 /* Destroy the main CV and syntax tree */
357 curpad = AvARRAY(comppad);
363 SvREFCNT_dec(main_cv);
368 * Try to destruct global references. We do this first so that the
369 * destructors and destructees still exist. Some sv's might remain.
370 * Non-referenced objects are on their own.
377 /* unhook hooks which will soon be, or use, destroyed data */
378 SvREFCNT_dec(warnhook);
380 SvREFCNT_dec(diehook);
382 SvREFCNT_dec(parsehook);
385 /* call exit list functions */
386 while (exitlistlen-- > 0)
387 exitlist[exitlistlen].fn(PERL_OBJECT_THIS_ exitlist[exitlistlen].ptr);
391 if (destruct_level == 0){
393 DEBUG_P(debprofdump());
395 /* The exit() function will do everything that needs doing. */
399 /* loosen bonds of global variables */
402 (void)PerlIO_close(rsfp);
406 /* Filters for program text */
407 SvREFCNT_dec(rsfp_filters);
408 rsfp_filters = Nullav;
420 sawampersand = FALSE; /* must save all match strings */
421 sawstudy = FALSE; /* do fbm_instr on all strings */
429 SvREFCNT_dec(e_script);
433 /* magical thingies */
435 Safefree(ofs); /* $, */
438 Safefree(ors); /* $\ */
441 SvREFCNT_dec(nrs); /* $\ helper */
444 multiline = 0; /* $* */
446 SvREFCNT_dec(statname);
450 /* defgv, aka *_ should be taken care of elsewhere */
452 /* clean up after study() */
453 SvREFCNT_dec(lastscream);
455 Safefree(screamfirst);
457 Safefree(screamnext);
460 /* startup and shutdown function lists */
461 SvREFCNT_dec(beginav);
463 SvREFCNT_dec(initav);
468 /* shortcuts just get cleared */
479 /* reset so print() ends up where we expect */
482 /* Prepare to destruct main symbol table. */
489 if (destruct_level >= 2) {
490 if (scopestack_ix != 0)
491 warn("Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
492 (long)scopestack_ix);
493 if (savestack_ix != 0)
494 warn("Unbalanced saves: %ld more saves than restores\n",
496 if (tmps_floor != -1)
497 warn("Unbalanced tmps: %ld more allocs than frees\n",
498 (long)tmps_floor + 1);
499 if (cxstack_ix != -1)
500 warn("Unbalanced context: %ld more PUSHes than POPs\n",
501 (long)cxstack_ix + 1);
504 /* Now absolutely destruct everything, somehow or other, loops or no. */
506 SvFLAGS(strtab) |= SVTYPEMASK; /* don't clean out strtab now */
507 while (sv_count != 0 && sv_count != last_sv_count) {
508 last_sv_count = sv_count;
511 SvFLAGS(strtab) &= ~SVTYPEMASK;
512 SvFLAGS(strtab) |= SVt_PVHV;
514 /* Destruct the global string table. */
516 /* Yell and reset the HeVAL() slots that are still holding refcounts,
517 * so that sv_free() won't fail on them.
526 array = HvARRAY(strtab);
530 warn("Unbalanced string table refcount: (%d) for \"%s\"",
531 HeVAL(hent) - Nullsv, HeKEY(hent));
532 HeVAL(hent) = Nullsv;
542 SvREFCNT_dec(strtab);
545 warn("Scalars leaked: %ld\n", (long)sv_count);
549 /* No SVs have survived, need to clean out */
553 Safefree(origfilename);
555 hints = 0; /* Reset hints. Should hints be per-interpreter ? */
557 DEBUG_P(debprofdump());
559 MUTEX_DESTROY(&sv_mutex);
560 MUTEX_DESTROY(&eval_mutex);
561 COND_DESTROY(&eval_cond);
563 /* As the penultimate thing, free the non-arena SV for thrsv */
564 Safefree(SvPVX(thrsv));
565 Safefree(SvANY(thrsv));
568 #endif /* USE_THREADS */
570 /* As the absolutely last thing, free the non-arena SV for mess() */
573 /* we know that type >= SVt_PV */
575 Safefree(SvPVX(mess_sv));
576 Safefree(SvANY(mess_sv));
584 CPerlObj::perl_free(void)
586 perl_free(PerlInterpreter *sv_interp)
592 if (!(curinterp = sv_interp))
600 CPerlObj::perl_atexit(void (*fn) (CPerlObj*,void *), void *ptr)
602 perl_atexit(void (*fn) (void *), void *ptr)
605 Renew(exitlist, exitlistlen+1, PerlExitListEntry);
606 exitlist[exitlistlen].fn = fn;
607 exitlist[exitlistlen].ptr = ptr;
611 struct try_parse_locals {
619 typedef struct try_parse_locals TRY_PARSE_LOCALS;
620 static TRYVTBL PerlParseVtbl;
624 CPerlObj::perl_parse(void (*xsinit) (CPerlObj*), int argc, char **argv, char **env)
626 perl_parse(PerlInterpreter *sv_interp, void (*xsinit) (void), int argc, char **argv, char **env)
630 TRY_PARSE_LOCALS locals;
631 locals.xsinit = xsinit;
636 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
639 croak("suidperl is no longer needed since the kernel can now execute\n\
640 setuid perl scripts securely.\n");
645 if (!(curinterp = sv_interp))
649 #if defined(NeXT) && defined(__DYNAMIC__)
650 _dyld_lookup_and_bind
651 ("__environ", (unsigned long *) &environ_pointer, NULL);
656 #ifndef VMS /* VMS doesn't have environ array */
657 origenviron = environ;
662 /* Come here if running an undumped a.out. */
664 origfilename = savepv(argv[0]);
666 cxstack_ix = -1; /* start label stack again */
668 init_postdump_symbols(argc,argv,env);
673 curpad = AvARRAY(comppad);
678 SvREFCNT_dec(main_cv);
682 locals.oldscope = scopestack_ix;
684 TRYBLOCK(PerlParseVtbl, locals);
688 struct try_run_locals {
692 typedef struct try_run_locals TRY_RUN_LOCALS;
693 static TRYVTBL PerlRunVtbl;
697 CPerlObj::perl_run(void)
699 perl_run(PerlInterpreter *sv_interp)
703 TRY_RUN_LOCALS locals;
706 if (!(curinterp = sv_interp))
710 locals.oldscope = scopestack_ix;
711 TRYBLOCK(PerlRunVtbl, locals);
716 perl_get_sv(char *name, I32 create)
720 if (name[1] == '\0' && !isALPHA(name[0])) {
721 PADOFFSET tmp = find_threadsv(name);
722 if (tmp != NOT_IN_PAD) {
724 return THREADSV(tmp);
727 #endif /* USE_THREADS */
728 gv = gv_fetchpv(name, create, SVt_PV);
735 perl_get_av(char *name, I32 create)
737 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
746 perl_get_hv(char *name, I32 create)
748 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
757 perl_get_cv(char *name, I32 create)
759 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
760 if (create && !GvCVu(gv))
761 return newSUB(start_subparse(FALSE, 0),
762 newSVOP(OP_CONST, 0, newSVpv(name,0)),
770 /* Be sure to refetch the stack pointer after calling these routines. */
773 perl_call_argv(char *sub_name, I32 flags, register char **argv)
775 /* See G_* flags in cop.h */
776 /* null terminated arg list */
783 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
788 return perl_call_pv(sub_name, flags);
792 perl_call_pv(char *sub_name, I32 flags)
793 /* name of the subroutine */
794 /* See G_* flags in cop.h */
796 return perl_call_sv((SV*)perl_get_cv(sub_name, TRUE), flags);
800 perl_call_method(char *methname, I32 flags)
801 /* name of the subroutine */
802 /* See G_* flags in cop.h */
808 XPUSHs(sv_2mortal(newSVpv(methname,0)));
813 return perl_call_sv(*stack_sp--, flags);
816 /* May be called with any of a CV, a GV, or an SV containing the name. */
818 perl_call_sv(SV *sv, I32 flags)
820 /* See G_* flags in cop.h */
823 LOGOP myop; /* fake syntax tree node */
827 bool oldcatch = CATCH_GET;
832 if (flags & G_DISCARD) {
837 Zero(&myop, 1, LOGOP);
838 myop.op_next = Nullop;
839 if (!(flags & G_NOARGS))
840 myop.op_flags |= OPf_STACKED;
841 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
842 (flags & G_ARRAY) ? OPf_WANT_LIST :
850 oldscope = scopestack_ix;
852 if (PERLDB_SUB && curstash != debstash
853 /* Handle first BEGIN of -d. */
854 && (DBcv || (DBcv = GvCV(DBsub)))
855 /* Try harder, since this may have been a sighandler, thus
856 * curstash may be meaningless. */
857 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != debstash)
858 && !(flags & G_NODEBUG))
859 op->op_private |= OPpENTERSUB_DB;
861 if (flags & G_EVAL) {
862 cLOGOP->op_other = op;
864 /* we're trying to emulate pp_entertry() here */
866 register PERL_CONTEXT *cx;
872 push_return(op->op_next);
873 PUSHBLOCK(cx, CXt_EVAL, stack_sp);
875 eval_root = op; /* Only needed so that goto works right. */
878 if (flags & G_KEEPERR)
885 JMPENV_PUSH(jmpstat);
893 /* my_exit() was called */
898 croak("Callback called exit");
907 stack_sp = stack_base + oldmark;
912 *++stack_sp = &sv_undef;
920 if (op == (OP*)&myop)
921 op = pp_entersub(ARGS);
924 retval = stack_sp - (stack_base + oldmark);
925 if ((flags & G_EVAL) && !(flags & G_KEEPERR))
929 if (flags & G_EVAL) {
930 if (scopestack_ix > oldscope) {
934 register PERL_CONTEXT *cx;
948 if (flags & G_DISCARD) {
949 stack_sp = stack_base + oldmark;
958 /* Eval a string. The G_EVAL flag is always assumed. */
961 perl_eval_sv(SV *sv, I32 flags)
963 /* See G_* flags in cop.h */
966 UNOP myop; /* fake syntax tree node */
967 I32 oldmark = SP - stack_base;
974 if (flags & G_DISCARD) {
984 oldscope = scopestack_ix;
986 if (!(flags & G_NOARGS))
987 myop.op_flags = OPf_STACKED;
988 myop.op_next = Nullop;
989 myop.op_type = OP_ENTEREVAL;
990 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
991 (flags & G_ARRAY) ? OPf_WANT_LIST :
993 if (flags & G_KEEPERR)
994 myop.op_flags |= OPf_SPECIAL;
996 JMPENV_PUSH(jmpstat);
1004 /* my_exit() was called */
1005 curstash = defstash;
1009 croak("Callback called exit");
1018 stack_sp = stack_base + oldmark;
1019 if (flags & G_ARRAY)
1023 *++stack_sp = &sv_undef;
1028 if (op == (OP*)&myop)
1029 op = pp_entereval(ARGS);
1032 retval = stack_sp - (stack_base + oldmark);
1033 if (!(flags & G_KEEPERR))
1038 if (flags & G_DISCARD) {
1039 stack_sp = stack_base + oldmark;
1049 perl_eval_pv(char *p, I32 croak_on_error)
1052 SV* sv = newSVpv(p, 0);
1055 perl_eval_sv(sv, G_SCALAR);
1062 if (croak_on_error && SvTRUE(ERRSV))
1063 croak(SvPVx(ERRSV, na));
1068 /* Require a module. */
1071 perl_require_pv(char *pv)
1073 SV* sv = sv_newmortal();
1074 sv_setpv(sv, "require '");
1077 perl_eval_sv(sv, G_DISCARD);
1081 magicname(char *sym, char *name, I32 namlen)
1085 if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
1086 sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
1090 usage(char *name) /* XXX move this out into a module ? */
1093 /* This message really ought to be max 23 lines.
1094 * Removed -h because the user already knows that opton. Others? */
1096 static char *usage_msg[] = {
1097 "-0[octal] specify record separator (\\0, if no argument)",
1098 "-a autosplit mode with -n or -p (splits $_ into @F)",
1099 "-c check syntax only (runs BEGIN and END blocks)",
1100 "-d[:debugger] run scripts under debugger",
1101 "-D[number/list] set debugging flags (argument is a bit mask or flags)",
1102 "-e 'command' one line of script. Several -e's allowed. Omit [programfile].",
1103 "-F/pattern/ split() pattern for autosplit (-a). The //'s are optional.",
1104 "-i[extension] edit <> files in place (make backup if extension supplied)",
1105 "-Idirectory specify @INC/#include directory (may be used more than once)",
1106 "-l[octal] enable line ending processing, specifies line terminator",
1107 "-[mM][-]module.. executes `use/no module...' before executing your script.",
1108 "-n assume 'while (<>) { ... }' loop around your script",
1109 "-p assume loop like -n but print line also like sed",
1110 "-P run script through C preprocessor before compilation",
1111 "-s enable some switch parsing for switches after script name",
1112 "-S look for the script using PATH environment variable",
1113 "-T turn on tainting checks",
1114 "-u dump core after parsing script",
1115 "-U allow unsafe operations",
1116 "-v print version number, patchlevel plus VERY IMPORTANT perl info",
1117 "-V[:variable] print perl configuration information",
1118 "-w TURN WARNINGS ON FOR COMPILATION OF YOUR SCRIPT. Recommended.",
1119 "-x[directory] strip off text before #!perl line and perhaps cd to directory",
1123 char **p = usage_msg;
1125 printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
1127 printf("\n %s", *p++);
1130 /* This routine handles any switches that can be given during run */
1133 moreswitches(char *s)
1142 rschar = scan_oct(s, 4, &numlen);
1144 if (rschar & ~((U8)~0))
1146 else if (!rschar && numlen >= 2)
1147 nrs = newSVpv("", 0);
1150 nrs = newSVpv(&ch, 1);
1156 splitstr = savepv(s + 1);
1170 if (*s == ':' || *s == '=') {
1171 my_setenv("PERL5DB", form("use Devel::%s;", ++s));
1175 perldb = PERLDB_ALL;
1182 if (isALPHA(s[1])) {
1183 static char debopts[] = "psltocPmfrxuLHXD";
1186 for (s++; *s && (d = strchr(debopts,*s)); s++)
1187 debug |= 1 << (d - debopts);
1191 for (s++; isDIGIT(*s); s++) ;
1193 debug |= 0x80000000;
1195 warn("Recompile perl with -DDEBUGGING to use -D switch\n");
1196 for (s++; isALNUM(*s); s++) ;
1206 inplace = savepv(s+1);
1208 for (s = inplace; *s && !isSPACE(*s); s++) ;
1211 if (*s == '-') /* Additional switches on #! line. */
1215 case 'I': /* -I handled both here and in parse_perl() */
1218 while (*s && isSPACE(*s))
1222 for (e = s; *e && !isSPACE(*e); e++) ;
1223 p = savepvn(s, e-s);
1229 croak("No space allowed after -I");
1239 *ors = scan_oct(s, 3 + (*s == '0'), &numlen);
1249 ors = SvPV(nrs, orslen);
1250 ors = savepvn(ors, orslen);
1254 forbid_setid("-M"); /* XXX ? */
1257 forbid_setid("-m"); /* XXX ? */
1262 /* -M-foo == 'no foo' */
1263 if (*s == '-') { use = "no "; ++s; }
1264 sv = newSVpv(use,0);
1266 /* We allow -M'Module qw(Foo Bar)' */
1267 while(isALNUM(*s) || *s==':') ++s;
1269 sv_catpv(sv, start);
1270 if (*(start-1) == 'm') {
1272 croak("Can't use '%c' after -mname", *s);
1273 sv_catpv( sv, " ()");
1276 sv_catpvn(sv, start, s-start);
1277 sv_catpv(sv, " split(/,/,q{");
1282 if (preambleav == NULL)
1283 preambleav = newAV();
1284 av_push(preambleav, sv);
1287 croak("No space allowed after -%c", *(s-1));
1304 croak("Too late for \"-T\" option");
1316 #if defined(SUBVERSION) && SUBVERSION > 0
1317 printf("\nThis is perl, version 5.%03d_%02d built for %s",
1318 PATCHLEVEL, SUBVERSION, ARCHNAME);
1320 printf("\nThis is perl, version %s built for %s",
1321 patchlevel, ARCHNAME);
1323 #if defined(LOCAL_PATCH_COUNT)
1324 if (LOCAL_PATCH_COUNT > 0)
1325 printf("\n(with %d registered patch%s, see perl -V for more detail)",
1326 LOCAL_PATCH_COUNT, (LOCAL_PATCH_COUNT!=1) ? "es" : "");
1329 printf("\n\nCopyright 1987-1998, Larry Wall\n");
1331 printf("\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
1334 printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
1335 printf("djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1998\n");
1338 printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
1339 "Version 5 port Copyright (c) 1994-1998, Andreas Kaiser, Ilya Zakharevich\n");
1342 printf("atariST series port, ++jrb bammi@cadence.com\n");
1345 Perl may be copied only under the terms of either the Artistic License or the\n\
1346 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n\
1347 Complete documentation for Perl, including FAQ lists, should be found on\n\
1348 this system using `man perl' or `perldoc perl'. If you have access to the\n\
1349 Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n");
1357 if (s[1] == '-') /* Additional switches on #! line. */
1368 #ifdef ALTERNATE_SHEBANG
1369 case 'S': /* OS/2 needs -S on "extproc" line. */
1377 croak("Can't emulate -%.1s on #! line",s);
1382 /* compliments of Tom Christiansen */
1384 /* unexec() can be found in the Gnu emacs distribution */
1385 /* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
1396 prog = newSVpv(BIN_EXP, 0);
1397 sv_catpv(prog, "/perl");
1398 file = newSVpv(origfilename, 0);
1399 sv_catpv(file, ".perldump");
1401 unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
1402 /* unexec prints msg to stderr in case of failure */
1403 PerlProc_exit(status);
1406 # include <lib$routines.h>
1407 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
1409 ABORT(); /* for use with undump */
1415 init_main_stash(void)
1420 /* Note that strtab is a rather special HV. Assumptions are made
1421 about not iterating on it, and not adding tie magic to it.
1422 It is properly deallocated in perl_destruct() */
1424 HvSHAREKEYS_off(strtab); /* mandatory */
1425 Newz(506,((XPVHV*)SvANY(strtab))->xhv_array,
1426 sizeof(HE*) * (((XPVHV*)SvANY(strtab))->xhv_max + 1), char);
1428 curstash = defstash = newHV();
1429 curstname = newSVpv("main",4);
1430 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
1431 SvREFCNT_dec(GvHV(gv));
1432 GvHV(gv) = (HV*)SvREFCNT_inc(defstash);
1434 HvNAME(defstash) = savepv("main");
1435 incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
1437 defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
1438 errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
1440 replgv = gv_HVadd(gv_fetchpv("\022", TRUE, SVt_PV)); /* ^R */
1442 (void)form("%240s",""); /* Preallocate temp - for immediate signals. */
1443 sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
1444 sv_setpvn(ERRSV, "", 0);
1445 curstash = defstash;
1446 compiling.cop_stash = defstash;
1447 debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
1448 globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
1449 /* We must init $/ before switches are processed. */
1450 sv_setpvn(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), "\n", 1);
1454 open_script(char *scriptname, bool dosearch, SV *sv, int *fdscript)
1459 scriptname = find_script(scriptname, dosearch, NULL, 0);
1461 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
1462 char *s = scriptname + 8;
1463 *fdscript = atoi(s);
1471 origfilename = savepv(e_script ? "-e" : scriptname);
1472 curcop->cop_filegv = gv_fetchfile(origfilename);
1473 if (strEQ(origfilename,"-"))
1475 if (*fdscript >= 0) {
1476 rsfp = PerlIO_fdopen(*fdscript,PERL_SCRIPT_MODE);
1477 #if defined(HAS_FCNTL) && defined(F_SETFD)
1479 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
1482 else if (preprocess) {
1483 char *cpp_cfg = CPPSTDIN;
1484 SV *cpp = NEWSV(0,0);
1485 SV *cmd = NEWSV(0,0);
1487 if (strEQ(cpp_cfg, "cppstdin"))
1488 sv_catpvf(cpp, "%s/", BIN_EXP);
1489 sv_catpv(cpp, cpp_cfg);
1492 sv_catpv(sv,PRIVLIB_EXP);
1496 sed %s -e \"/^[^#]/b\" \
1497 -e \"/^#[ ]*include[ ]/b\" \
1498 -e \"/^#[ ]*define[ ]/b\" \
1499 -e \"/^#[ ]*if[ ]/b\" \
1500 -e \"/^#[ ]*ifdef[ ]/b\" \
1501 -e \"/^#[ ]*ifndef[ ]/b\" \
1502 -e \"/^#[ ]*else/b\" \
1503 -e \"/^#[ ]*elif[ ]/b\" \
1504 -e \"/^#[ ]*undef[ ]/b\" \
1505 -e \"/^#[ ]*endif/b\" \
1508 (doextract ? "-e \"1,/^#/d\n\"" : ""),
1511 %s %s -e '/^[^#]/b' \
1512 -e '/^#[ ]*include[ ]/b' \
1513 -e '/^#[ ]*define[ ]/b' \
1514 -e '/^#[ ]*if[ ]/b' \
1515 -e '/^#[ ]*ifdef[ ]/b' \
1516 -e '/^#[ ]*ifndef[ ]/b' \
1517 -e '/^#[ ]*else/b' \
1518 -e '/^#[ ]*elif[ ]/b' \
1519 -e '/^#[ ]*undef[ ]/b' \
1520 -e '/^#[ ]*endif/b' \
1528 (doextract ? "-e '1,/^#/d\n'" : ""),
1530 scriptname, cpp, sv, CPPMINUS);
1532 #ifdef IAMSUID /* actually, this is caught earlier */
1533 if (euid != uid && !euid) { /* if running suidperl */
1535 (void)seteuid(uid); /* musn't stay setuid root */
1538 (void)setreuid((Uid_t)-1, uid);
1540 #ifdef HAS_SETRESUID
1541 (void)setresuid((Uid_t)-1, uid, (Uid_t)-1);
1543 PerlProc_setuid(uid);
1547 if (PerlProc_geteuid() != uid)
1548 croak("Can't do seteuid!\n");
1550 #endif /* IAMSUID */
1551 rsfp = PerlProc_popen(SvPVX(cmd), "r");
1555 else if (!*scriptname) {
1556 forbid_setid("program input from stdin");
1557 rsfp = PerlIO_stdin();
1560 rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
1561 #if defined(HAS_FCNTL) && defined(F_SETFD)
1563 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
1568 #ifndef IAMSUID /* in case script is not readable before setuid */
1569 if (euid && PerlLIO_stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 &&
1570 statbuf.st_mode & (S_ISUID|S_ISGID)) {
1572 PerlProc_execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
1573 croak("Can't do setuid\n");
1577 croak("Can't open perl script \"%s\": %s\n",
1578 SvPVX(GvSV(curcop->cop_filegv)), Strerror(errno));
1583 validate_suid(char *validarg, char *scriptname, int fdscript)
1587 /* do we need to emulate setuid on scripts? */
1589 /* This code is for those BSD systems that have setuid #! scripts disabled
1590 * in the kernel because of a security problem. Merely defining DOSUID
1591 * in perl will not fix that problem, but if you have disabled setuid
1592 * scripts in the kernel, this will attempt to emulate setuid and setgid
1593 * on scripts that have those now-otherwise-useless bits set. The setuid
1594 * root version must be called suidperl or sperlN.NNN. If regular perl
1595 * discovers that it has opened a setuid script, it calls suidperl with
1596 * the same argv that it had. If suidperl finds that the script it has
1597 * just opened is NOT setuid root, it sets the effective uid back to the
1598 * uid. We don't just make perl setuid root because that loses the
1599 * effective uid we had before invoking perl, if it was different from the
1602 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
1603 * be defined in suidperl only. suidperl must be setuid root. The
1604 * Configure script will set this up for you if you want it.
1611 if (PerlLIO_fstat(PerlIO_fileno(rsfp),&statbuf) < 0) /* normal stat is insecure */
1612 croak("Can't stat script \"%s\"",origfilename);
1613 if (fdscript < 0 && statbuf.st_mode & (S_ISUID|S_ISGID)) {
1617 #ifndef HAS_SETREUID
1618 /* On this access check to make sure the directories are readable,
1619 * there is actually a small window that the user could use to make
1620 * filename point to an accessible directory. So there is a faint
1621 * chance that someone could execute a setuid script down in a
1622 * non-accessible directory. I don't know what to do about that.
1623 * But I don't think it's too important. The manual lies when
1624 * it says access() is useful in setuid programs.
1626 if (PerlLIO_access(SvPVX(GvSV(curcop->cop_filegv)),1)) /*double check*/
1627 croak("Permission denied");
1629 /* If we can swap euid and uid, then we can determine access rights
1630 * with a simple stat of the file, and then compare device and
1631 * inode to make sure we did stat() on the same file we opened.
1632 * Then we just have to make sure he or she can execute it.
1635 struct stat tmpstatbuf;
1639 setreuid(euid,uid) < 0
1642 setresuid(euid,uid,(Uid_t)-1) < 0
1645 || PerlProc_getuid() != euid || PerlProc_geteuid() != uid)
1646 croak("Can't swap uid and euid"); /* really paranoid */
1647 if (PerlLIO_stat(SvPVX(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0)
1648 croak("Permission denied"); /* testing full pathname here */
1649 if (tmpstatbuf.st_dev != statbuf.st_dev ||
1650 tmpstatbuf.st_ino != statbuf.st_ino) {
1651 (void)PerlIO_close(rsfp);
1652 if (rsfp = PerlProc_popen("/bin/mail root","w")) { /* heh, heh */
1654 "User %ld tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
1655 (Filename of set-id script was %s, uid %ld gid %ld.)\n\nSincerely,\nperl\n",
1656 (long)uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
1657 (long)statbuf.st_dev, (long)statbuf.st_ino,
1658 SvPVX(GvSV(curcop->cop_filegv)),
1659 (long)statbuf.st_uid, (long)statbuf.st_gid);
1660 (void)PerlProc_pclose(rsfp);
1662 croak("Permission denied\n");
1666 setreuid(uid,euid) < 0
1668 # if defined(HAS_SETRESUID)
1669 setresuid(uid,euid,(Uid_t)-1) < 0
1672 || PerlProc_getuid() != uid || PerlProc_geteuid() != euid)
1673 croak("Can't reswap uid and euid");
1674 if (!cando(S_IXUSR,FALSE,&statbuf)) /* can real uid exec? */
1675 croak("Permission denied\n");
1677 #endif /* HAS_SETREUID */
1678 #endif /* IAMSUID */
1680 if (!S_ISREG(statbuf.st_mode))
1681 croak("Permission denied");
1682 if (statbuf.st_mode & S_IWOTH)
1683 croak("Setuid/gid script is writable by world");
1684 doswitches = FALSE; /* -s is insecure in suid */
1686 if (sv_gets(linestr, rsfp, 0) == Nullch ||
1687 strnNE(SvPV(linestr,na),"#!",2) ) /* required even on Sys V */
1688 croak("No #! line");
1689 s = SvPV(linestr,na)+2;
1691 while (!isSPACE(*s)) s++;
1692 for (s2 = s; (s2 > SvPV(linestr,na)+2 &&
1693 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
1694 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
1695 croak("Not a perl script");
1696 while (*s == ' ' || *s == '\t') s++;
1698 * #! arg must be what we saw above. They can invoke it by
1699 * mentioning suidperl explicitly, but they may not add any strange
1700 * arguments beyond what #! says if they do invoke suidperl that way.
1702 len = strlen(validarg);
1703 if (strEQ(validarg," PHOOEY ") ||
1704 strnNE(s,validarg,len) || !isSPACE(s[len]))
1705 croak("Args must match #! line");
1708 if (euid != uid && (statbuf.st_mode & S_ISUID) &&
1709 euid == statbuf.st_uid)
1711 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
1712 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
1713 #endif /* IAMSUID */
1715 if (euid) { /* oops, we're not the setuid root perl */
1716 (void)PerlIO_close(rsfp);
1719 PerlProc_execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
1721 croak("Can't do setuid\n");
1724 if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid) {
1726 (void)setegid(statbuf.st_gid);
1729 (void)setregid((Gid_t)-1,statbuf.st_gid);
1731 #ifdef HAS_SETRESGID
1732 (void)setresgid((Gid_t)-1,statbuf.st_gid,(Gid_t)-1);
1734 PerlProc_setgid(statbuf.st_gid);
1738 if (PerlProc_getegid() != statbuf.st_gid)
1739 croak("Can't do setegid!\n");
1741 if (statbuf.st_mode & S_ISUID) {
1742 if (statbuf.st_uid != euid)
1744 (void)seteuid(statbuf.st_uid); /* all that for this */
1747 (void)setreuid((Uid_t)-1,statbuf.st_uid);
1749 #ifdef HAS_SETRESUID
1750 (void)setresuid((Uid_t)-1,statbuf.st_uid,(Uid_t)-1);
1752 PerlProc_setuid(statbuf.st_uid);
1756 if (PerlProc_geteuid() != statbuf.st_uid)
1757 croak("Can't do seteuid!\n");
1759 else if (uid) { /* oops, mustn't run as root */
1761 (void)seteuid((Uid_t)uid);
1764 (void)setreuid((Uid_t)-1,(Uid_t)uid);
1766 #ifdef HAS_SETRESUID
1767 (void)setresuid((Uid_t)-1,(Uid_t)uid,(Uid_t)-1);
1769 PerlProc_setuid((Uid_t)uid);
1773 if (PerlProc_geteuid() != uid)
1774 croak("Can't do seteuid!\n");
1777 if (!cando(S_IXUSR,TRUE,&statbuf))
1778 croak("Permission denied\n"); /* they can't do this */
1781 else if (preprocess)
1782 croak("-P not allowed for setuid/setgid script\n");
1783 else if (fdscript >= 0)
1784 croak("fd script not allowed in suidperl\n");
1786 croak("Script is not setuid/setgid in suidperl\n");
1788 /* We absolutely must clear out any saved ids here, so we */
1789 /* exec the real perl, substituting fd script for scriptname. */
1790 /* (We pass script name as "subdir" of fd, which perl will grok.) */
1791 PerlIO_rewind(rsfp);
1792 PerlLIO_lseek(PerlIO_fileno(rsfp),(Off_t)0,0); /* just in case rewind didn't */
1793 for (which = 1; origargv[which] && origargv[which] != scriptname; which++) ;
1794 if (!origargv[which])
1795 croak("Permission denied");
1796 origargv[which] = savepv(form("/dev/fd/%d/%s",
1797 PerlIO_fileno(rsfp), origargv[which]));
1798 #if defined(HAS_FCNTL) && defined(F_SETFD)
1799 fcntl(PerlIO_fileno(rsfp),F_SETFD,0); /* ensure no close-on-exec */
1801 PerlProc_execv(form("%s/perl%s", BIN_EXP, patchlevel), origargv); /* try again */
1802 croak("Can't do setuid\n");
1803 #endif /* IAMSUID */
1805 if (euid != uid || egid != gid) { /* (suidperl doesn't exist, in fact) */
1806 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
1808 PerlLIO_fstat(PerlIO_fileno(rsfp),&statbuf); /* may be either wrapped or real suid */
1809 if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
1811 (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
1814 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
1815 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
1816 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
1817 /* not set-id, must be wrapped */
1823 find_beginning(void)
1825 register char *s, *s2;
1827 /* skip forward in input to the real script? */
1831 if ((s = sv_gets(linestr, rsfp, 0)) == Nullch)
1832 croak("No Perl script found in input\n");
1833 if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
1834 PerlIO_ungetc(rsfp, '\n'); /* to keep line count right */
1836 while (*s && !(isSPACE (*s) || *s == '#')) s++;
1838 while (*s == ' ' || *s == '\t') s++;
1840 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
1841 if (strnEQ(s2-4,"perl",4))
1843 while (s = moreswitches(s)) ;
1845 if (cddir && PerlDir_chdir(cddir) < 0)
1846 croak("Can't chdir to %s",cddir);
1855 uid = (int)PerlProc_getuid();
1856 euid = (int)PerlProc_geteuid();
1857 gid = (int)PerlProc_getgid();
1858 egid = (int)PerlProc_getegid();
1863 tainting |= (uid && (euid != uid || egid != gid));
1867 forbid_setid(char *s)
1870 croak("No %s allowed while running setuid", s);
1872 croak("No %s allowed while running setgid", s);
1879 curstash = debstash;
1880 dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
1882 DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
1883 DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
1884 DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
1885 DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
1886 sv_setiv(DBsingle, 0);
1887 DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
1888 sv_setiv(DBtrace, 0);
1889 DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
1890 sv_setiv(DBsignal, 0);
1891 curstash = defstash;
1894 #ifndef STRESS_REALLOC
1895 #define REASONABLE(size) (size)
1897 #define REASONABLE(size) (1) /* unreasonable */
1901 init_stacks(ARGSproto)
1903 /* start with 128-item stack and 8K cxstack */
1904 curstackinfo = new_stackinfo(REASONABLE(128),
1905 REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
1906 curstackinfo->si_type = SI_MAIN;
1907 curstack = curstackinfo->si_stack;
1908 mainstack = curstack; /* remember in case we switch stacks */
1910 stack_base = AvARRAY(curstack);
1911 stack_sp = stack_base;
1912 stack_max = stack_base + AvMAX(curstack);
1914 New(50,tmps_stack,REASONABLE(128),SV*);
1917 tmps_max = REASONABLE(128);
1920 * The following stacks almost certainly should be per-interpreter,
1921 * but for now they're not. XXX
1925 markstack_ptr = markstack;
1927 New(54,markstack,REASONABLE(32),I32);
1928 markstack_ptr = markstack;
1929 markstack_max = markstack + REASONABLE(32);
1937 New(54,scopestack,REASONABLE(32),I32);
1939 scopestack_max = REASONABLE(32);
1945 New(54,savestack,REASONABLE(128),ANY);
1947 savestack_max = REASONABLE(128);
1953 New(54,retstack,REASONABLE(16),OP*);
1955 retstack_max = REASONABLE(16);
1965 while (curstackinfo->si_next)
1966 curstackinfo = curstackinfo->si_next;
1967 while (curstackinfo) {
1968 PERL_SI *p = curstackinfo->si_prev;
1969 /* curstackinfo->si_stack got nuked by sv_free_arenas() */
1970 Safefree(curstackinfo->si_cxstack);
1971 Safefree(curstackinfo);
1974 Safefree(tmps_stack);
1982 static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
1995 subname = newSVpv("main",4);
1999 init_predump_symbols(void)
2005 sv_setpvn(perl_get_sv("\"", TRUE), " ", 1);
2006 stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2007 GvMULTI_on(stdingv);
2008 IoIFP(GvIOp(stdingv)) = PerlIO_stdin();
2009 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
2011 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(stdingv));
2013 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2015 IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = PerlIO_stdout();
2017 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2019 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(defoutgv));
2021 othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2022 GvMULTI_on(othergv);
2023 IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = PerlIO_stderr();
2024 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
2026 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv));
2028 statname = NEWSV(66,0); /* last filename we did stat on */
2031 osname = savepv(OSNAME);
2035 init_postdump_symbols(register int argc, register char **argv, register char **env)
2042 argc--,argv++; /* skip name of script */
2044 for (; argc > 0 && **argv == '-'; argc--,argv++) {
2047 if (argv[0][1] == '-') {
2051 if (s = strchr(argv[0], '=')) {
2053 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
2056 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
2059 toptarget = NEWSV(0,0);
2060 sv_upgrade(toptarget, SVt_PVFM);
2061 sv_setpvn(toptarget, "", 0);
2062 bodytarget = NEWSV(0,0);
2063 sv_upgrade(bodytarget, SVt_PVFM);
2064 sv_setpvn(bodytarget, "", 0);
2065 formtarget = bodytarget;
2068 if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
2069 sv_setpv(GvSV(tmpgv),origfilename);
2070 magicname("0", "0", 1);
2072 if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
2073 sv_setpv(GvSV(tmpgv),origargv[0]);
2074 if (argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
2076 (void)gv_AVadd(argvgv);
2077 av_clear(GvAVn(argvgv));
2078 for (; argc > 0; argc--,argv++) {
2079 av_push(GvAVn(argvgv),newSVpv(argv[0],0));
2082 if (envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
2086 hv_magic(hv, envgv, 'E');
2087 #ifndef VMS /* VMS doesn't have environ array */
2088 /* Note that if the supplied env parameter is actually a copy
2089 of the global environ then it may now point to free'd memory
2090 if the environment has been modified since. To avoid this
2091 problem we treat env==NULL as meaning 'use the default'
2096 environ[0] = Nullch;
2097 for (; *env; env++) {
2098 if (!(s = strchr(*env,'=')))
2104 sv = newSVpv(s--,0);
2105 (void)hv_store(hv, *env, s - *env, sv, 0);
2107 #if defined(__BORLANDC__) && defined(USE_WIN32_RTL_ENV)
2108 /* Sins of the RTL. See note in my_setenv(). */
2109 (void)PerlEnv_putenv(savepv(*env));
2113 #ifdef DYNAMIC_ENV_FETCH
2114 HvNAME(hv) = savepv(ENV_HV_NAME);
2118 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
2119 sv_setiv(GvSV(tmpgv), (IV)getpid());
2128 s = PerlEnv_getenv("PERL5LIB");
2132 incpush(PerlEnv_getenv("PERLLIB"), FALSE);
2134 /* Treat PERL5?LIB as a possible search list logical name -- the
2135 * "natural" VMS idiom for a Unix path string. We allow each
2136 * element to be a set of |-separated directories for compatibility.
2140 if (my_trnlnm("PERL5LIB",buf,0))
2141 do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
2143 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
2147 /* Use the ~-expanded versions of APPLLIB (undocumented),
2148 ARCHLIB PRIVLIB SITEARCH and SITELIB
2151 incpush(APPLLIB_EXP, TRUE);
2155 incpush(ARCHLIB_EXP, FALSE);
2158 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
2161 incpush(PRIVLIB_EXP, TRUE);
2163 incpush(PRIVLIB_EXP, FALSE);
2167 incpush(SITEARCH_EXP, FALSE);
2171 incpush(SITELIB_EXP, TRUE);
2173 incpush(SITELIB_EXP, FALSE);
2177 incpush(".", FALSE);
2181 # define PERLLIB_SEP ';'
2184 # define PERLLIB_SEP '|'
2186 # define PERLLIB_SEP ':'
2189 #ifndef PERLLIB_MANGLE
2190 # define PERLLIB_MANGLE(s,n) (s)
2194 incpush(char *p, int addsubdirs)
2196 SV *subdir = Nullsv;
2202 subdir = NEWSV(55,0);
2203 if (!archpat_auto) {
2204 STRLEN len = (sizeof(ARCHNAME) + strlen(patchlevel)
2205 + sizeof("//auto"));
2206 New(55, archpat_auto, len, char);
2207 sprintf(archpat_auto, "/%s/%s/auto", ARCHNAME, patchlevel);
2209 for (len = sizeof(ARCHNAME) + 2;
2210 archpat_auto[len] != '\0' && archpat_auto[len] != '/'; len++)
2211 if (archpat_auto[len] == '.') archpat_auto[len] = '_';
2216 /* Break at all separators */
2218 SV *libdir = NEWSV(55,0);
2221 /* skip any consecutive separators */
2222 while ( *p == PERLLIB_SEP ) {
2223 /* Uncomment the next line for PATH semantics */
2224 /* av_push(GvAVn(incgv), newSVpv(".", 1)); */
2228 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
2229 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
2234 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
2235 p = Nullch; /* break out */
2239 * BEFORE pushing libdir onto @INC we may first push version- and
2240 * archname-specific sub-directories.
2243 struct stat tmpstatbuf;
2248 if ((unix = tounixspec_ts(SvPV(libdir,na),Nullch)) != Nullch) {
2250 while (unix[len-1] == '/') len--; /* Cosmetic */
2251 sv_usepvn(libdir,unix,len);
2254 PerlIO_printf(PerlIO_stderr(),
2255 "Failed to unixify @INC element \"%s\"\n",
2258 /* .../archname/version if -d .../archname/version/auto */
2259 sv_setsv(subdir, libdir);
2260 sv_catpv(subdir, archpat_auto);
2261 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2262 S_ISDIR(tmpstatbuf.st_mode))
2263 av_push(GvAVn(incgv),
2264 newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2266 /* .../archname if -d .../archname/auto */
2267 sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME),
2268 strlen(patchlevel) + 1, "", 0);
2269 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2270 S_ISDIR(tmpstatbuf.st_mode))
2271 av_push(GvAVn(incgv),
2272 newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2275 /* finally push this lib directory on the end of @INC */
2276 av_push(GvAVn(incgv), libdir);
2279 SvREFCNT_dec(subdir);
2283 STATIC struct perl_thread *
2286 struct perl_thread *thr;
2289 Newz(53, thr, 1, struct perl_thread);
2290 curcop = &compiling;
2291 thr->cvcache = newHV();
2292 thr->threadsv = newAV();
2293 /* thr->threadsvp is set when find_threadsv is called */
2294 thr->specific = newAV();
2295 thr->errhv = newHV();
2296 thr->flags = THRf_R_JOINABLE;
2297 MUTEX_INIT(&thr->mutex);
2298 /* Handcraft thrsv similarly to mess_sv */
2299 New(53, thrsv, 1, SV);
2300 Newz(53, xpv, 1, XPV);
2301 SvFLAGS(thrsv) = SVt_PV;
2302 SvANY(thrsv) = (void*)xpv;
2303 SvREFCNT(thrsv) = 1 << 30; /* practically infinite */
2304 SvPVX(thrsv) = (char*)thr;
2305 SvCUR_set(thrsv, sizeof(thr));
2306 SvLEN_set(thrsv, sizeof(thr));
2307 *SvEND(thrsv) = '\0'; /* in the trailing_nul field */
2311 MUTEX_LOCK(&threads_mutex);
2316 MUTEX_UNLOCK(&threads_mutex);
2318 #ifdef HAVE_THREAD_INTERN
2319 init_thread_intern(thr);
2322 #ifdef SET_THREAD_SELF
2323 SET_THREAD_SELF(thr);
2325 thr->self = pthread_self();
2326 #endif /* SET_THREAD_SELF */
2330 * These must come after the SET_THR because sv_setpvn does
2331 * SvTAINT and the taint fields require dTHR.
2333 toptarget = NEWSV(0,0);
2334 sv_upgrade(toptarget, SVt_PVFM);
2335 sv_setpvn(toptarget, "", 0);
2336 bodytarget = NEWSV(0,0);
2337 sv_upgrade(bodytarget, SVt_PVFM);
2338 sv_setpvn(bodytarget, "", 0);
2339 formtarget = bodytarget;
2340 thr->errsv = newSVpv("", 0);
2341 (void) find_threadsv("@"); /* Ensure $@ is initialised early */
2344 #endif /* USE_THREADS */
2347 call_list(I32 oldscope, AV *paramList)
2350 line_t oldline = curcop->cop_line;
2355 while (AvFILL(paramList) >= 0) {
2356 CV *cv = (CV*)av_shift(paramList);
2360 JMPENV_PUSH(jmpstat);
2365 perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
2366 (void)SvPV(atsv, len);
2369 curcop = &compiling;
2370 curcop->cop_line = oldline;
2371 if (paramList == beginav)
2372 sv_catpv(atsv, "BEGIN failed--compilation aborted");
2374 sv_catpv(atsv, "END failed--cleanup aborted");
2375 while (scopestack_ix > oldscope)
2377 croak("%s", SvPVX(atsv));
2385 /* my_exit() was called */
2386 while (scopestack_ix > oldscope)
2389 curstash = defstash;
2391 call_list(oldscope, endav);
2393 curcop = &compiling;
2394 curcop->cop_line = oldline;
2396 if (paramList == beginav)
2397 croak("BEGIN failed--compilation aborted");
2399 croak("END failed--cleanup aborted");
2405 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
2410 curcop = &compiling;
2411 curcop->cop_line = oldline;
2412 JMPENV_JUMP(JMP_EXCEPTION);
2424 DEBUG_L(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
2425 thr, (unsigned long) status));
2426 #endif /* USE_THREADS */
2435 STATUS_NATIVE_SET(status);
2442 my_failure_exit(void)
2445 if (vaxc$errno & 1) {
2446 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
2447 STATUS_NATIVE_SET(44);
2450 if (!vaxc$errno && errno) /* unlikely */
2451 STATUS_NATIVE_SET(44);
2453 STATUS_NATIVE_SET(vaxc$errno);
2458 STATUS_POSIX_SET(errno);
2460 exitstatus = STATUS_POSIX >> 8;
2461 if (exitstatus & 255)
2462 STATUS_POSIX_SET(exitstatus);
2464 STATUS_POSIX_SET(255);
2474 register PERL_CONTEXT *cx;
2479 SvREFCNT_dec(e_script);
2483 POPSTACK_TO(mainstack);
2484 if (cxstack_ix >= 0) {
2491 JMPENV_JUMP(JMP_MYEXIT);
2498 read_e_script(CPERLarg_ int idx, SV *buf_sv, int maxlen)
2501 p = SvPVX(e_script);
2502 nl = strchr(p, '\n');
2503 nl = (nl) ? nl+1 : SvEND(e_script);
2506 sv_catpvn(buf_sv, p, nl-p);
2507 sv_chop(e_script, nl);
2511 /******************************************* perl_parse TRYBLOCK branches */
2513 #define TRY_LOCAL(name) ((TRY_PARSE_LOCALS*)locals)->name
2516 try_parse_normal0(CPERLarg_ void *locals)
2521 char *scriptname = NULL;
2522 VOL bool dosearch = FALSE;
2523 char *validarg = "";
2527 void (*xsinit)() = TRY_LOCAL(xsinit);
2528 int argc = TRY_LOCAL(argc);
2529 char **argv = TRY_LOCAL(argv);
2530 char **env = TRY_LOCAL(env);
2532 sv_setpvn(linestr,"",0);
2533 sv = newSVpv("",0); /* first used for -I flags */
2537 for (argc--,argv++; argc > 0; argc--,argv++) {
2538 if (argv[0][0] != '-' || !argv[0][1])
2542 validarg = " PHOOEY ";
2568 if (s = moreswitches(s))
2578 if (euid != uid || egid != gid)
2579 croak("No -e allowed in setuid scripts");
2581 e_script = newSVpv("",0);
2582 filter_add(read_e_script, NULL);
2585 sv_catpv(e_script, s);
2587 sv_catpv(e_script, argv[1]);
2591 croak("No code specified for -e");
2592 sv_catpv(e_script, "\n");
2595 case 'I': /* -I handled both here and in moreswitches() */
2597 if (!*++s && (s=argv[1]) != Nullch) {
2600 while (s && isSPACE(*s))
2604 for (e = s; *e && !isSPACE(*e); e++) ;
2605 p = savepvn(s, e-s);
2611 } /* XXX else croak? */
2625 preambleav = newAV();
2626 av_push(preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
2628 Sv = newSVpv("print myconfig();",0);
2630 sv_catpv(Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
2632 sv_catpv(Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
2634 #if defined(DEBUGGING) || defined(NO_EMBED) || defined(MULTIPLICITY)
2635 sv_catpv(Sv,"\" Compile-time options:");
2637 sv_catpv(Sv," DEBUGGING");
2640 sv_catpv(Sv," NO_EMBED");
2642 # ifdef MULTIPLICITY
2643 sv_catpv(Sv," MULTIPLICITY");
2645 sv_catpv(Sv,"\\n\",");
2647 #if defined(LOCAL_PATCH_COUNT)
2648 if (LOCAL_PATCH_COUNT > 0) {
2650 sv_catpv(Sv,"\" Locally applied patches:\\n\",");
2651 for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
2652 if (localpatches[i])
2653 sv_catpvf(Sv,"\" \\t%s\\n\",",localpatches[i]);
2657 sv_catpvf(Sv,"\" Built under %s\\n\"",OSNAME);
2660 sv_catpvf(Sv,",\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
2662 sv_catpvf(Sv,",\" Compiled on %s\\n\"",__DATE__);
2667 @env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; \
2668 print \" \\%ENV:\\n @env\\n\" if @env; \
2669 print \" \\@INC:\\n @INC\\n\";");
2672 Sv = newSVpv("config_vars(qw(",0);
2677 av_push(preambleav, Sv);
2678 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
2689 if (!*++s || isSPACE(*s)) {
2693 /* catch use of gnu style long options */
2694 if (strEQ(s, "version")) {
2698 if (strEQ(s, "help")) {
2705 croak("Unrecognized switch: -%s (-h will show valid options)",s);
2710 if (!tainting && (s = PerlEnv_getenv("PERL5OPT"))) {
2721 if (!strchr("DIMUdmw", *s))
2722 croak("Illegal switch in PERL5OPT: -%c", *s);
2723 s = moreswitches(s);
2728 scriptname = argv[0];
2731 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
2733 else if (scriptname == Nullch) {
2735 if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
2743 open_script(scriptname,dosearch,sv,&fdscript);
2745 validate_suid(validarg, scriptname,fdscript);
2750 main_cv = compcv = (CV*)NEWSV(1104,0);
2751 sv_upgrade((SV *)compcv, SVt_PVCV);
2752 CvUNIQUE_on(compcv);
2755 av_push(comppad, Nullsv);
2756 curpad = AvARRAY(comppad);
2757 comppad_name = newAV();
2758 comppad_name_fill = 0;
2759 min_intro_pending = 0;
2762 av_store(comppad_name, 0, newSVpv("@_", 2));
2763 curpad[0] = (SV*)newAV();
2764 SvPADMY_on(curpad[0]); /* XXX Needed? */
2765 CvOWNER(compcv) = 0;
2766 New(666, CvMUTEXP(compcv), 1, perl_mutex);
2767 MUTEX_INIT(CvMUTEXP(compcv));
2768 #endif /* USE_THREADS */
2770 comppadlist = newAV();
2771 AvREAL_off(comppadlist);
2772 av_store(comppadlist, 0, (SV*)comppad_name);
2773 av_store(comppadlist, 1, (SV*)comppad);
2774 CvPADLIST(compcv) = comppadlist;
2776 boot_core_UNIVERSAL();
2779 (*xsinit)(PERL_OBJECT_THIS); /* in case linked C routines want magical variables */
2780 #if defined(VMS) || defined(WIN32) || defined(DJGPP)
2784 init_predump_symbols();
2785 /* init_postdump_symbols not currently designed to be called */
2786 /* more than once (ENV isn't cleared first, for example) */
2787 /* But running with -u leaves %ENV & @ARGV undefined! XXX */
2789 init_postdump_symbols(argc,argv,env);
2793 /* now parse the script */
2795 SETERRNO(0,SS$_NORMAL);
2797 if (yyparse() || error_count) {
2799 croak("%s had compilation errors.\n", origfilename);
2801 croak("Execution of %s aborted due to compilation errors.\n",
2805 curcop->cop_line = 0;
2806 curstash = defstash;
2809 SvREFCNT_dec(e_script);
2813 /* now that script is parsed, we can modify record separator */
2815 rs = SvREFCNT_inc(nrs);
2816 sv_setsv(perl_get_sv("/", TRUE), rs);
2827 if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
2828 dump_mstats("after compilation:");
2837 try_parse_exception1(CPERLarg_ void *locals)
2839 PerlIO_printf(PerlIO_stderr(), no_top_env);
2844 try_parse_myexit0(CPERLarg_ void *locals)
2847 I32 oldscope = TRY_LOCAL(oldscope);
2848 while (scopestack_ix > oldscope)
2851 curstash = defstash;
2853 call_list(oldscope, endav);
2854 TRY_LOCAL(ret) = STATUS_NATIVE_EXPORT;
2858 try_parse_abnormal0(CPERLarg_ void *locals)
2861 try_parse_myexit0(locals);
2865 static TRYVTBL PerlParseVtbl = {
2867 try_parse_normal0, 0,
2868 try_parse_abnormal0, 0,
2869 0, try_parse_exception1,
2870 try_parse_myexit0, 0,
2873 /******************************************* perl_run TRYBLOCK branches */
2875 #define TRY_LOCAL(name) ((TRY_RUN_LOCALS*)locals)->name
2878 try_run_normal0(CPERLarg_ void *locals)
2881 I32 oldscope = TRY_LOCAL(oldscope);
2883 DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
2884 sawampersand ? "Enabling" : "Omitting"));
2887 DEBUG_x(dump_all());
2888 DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
2890 DEBUG_L(PerlIO_printf(Perl_debug_log, "main thread is 0x%lx\n",
2891 (unsigned long) thr));
2892 #endif /* USE_THREADS */
2895 PerlIO_printf(PerlIO_stderr(), "%s syntax OK\n", origfilename);
2898 if (PERLDB_SINGLE && DBsingle)
2899 sv_setiv(DBsingle, 1);
2901 call_list(oldscope, initav);
2911 else if (main_start) {
2912 CvDEPTH(main_cv) = 1;
2921 try_run_abnormal0(CPERLarg_ void *locals)
2924 cxstack_ix = -1; /* start context stack again */
2925 try_run_normal0(locals);
2929 try_run_exception0(CPERLarg_ void *locals)
2933 PerlIO_printf(PerlIO_stderr(), no_restartop);
2937 POPSTACK_TO(mainstack);
2938 try_run_normal0(locals);
2943 try_run_myexit0(CPERLarg_ void *locals)
2946 I32 oldscope = TRY_LOCAL(oldscope);
2948 while (scopestack_ix > oldscope)
2951 curstash = defstash;
2953 call_list(oldscope, endav);
2955 if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
2956 dump_mstats("after execution: ");
2958 TRY_LOCAL(ret) = STATUS_NATIVE_EXPORT;
2962 static TRYVTBL PerlRunVtbl = {
2965 try_run_abnormal0, 0,
2966 try_run_exception0, 0,