This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
add const qualifier to most char* prototypes, handle ripple effect
[perl5.git] / perl.c
CommitLineData
a0d0e21e
LW
1/* perl.c
2 *
a411490c 3 * Copyright (c) 1987-1998 Larry Wall
a687059c 4 *
352d5a3a
LW
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.
a687059c 7 *
8d063cd8
LW
8 */
9
a0d0e21e
LW
10/*
11 * "A ship then new they built for him/of mithril and of elven glass" --Bilbo
12 */
45d8adaa 13
378cc40b
LW
14#include "EXTERN.h"
15#include "perl.h"
a687059c 16#include "patchlevel.h"
378cc40b 17
df5cef82 18/* XXX If this causes problems, set i_unistd=undef in the hint file. */
a0d0e21e
LW
19#ifdef I_UNISTD
20#include <unistd.h>
21#endif
a0d0e21e 22
54310121
PP
23#if !defined(STANDARD_C) && !defined(HAS_GETENV_PROTOTYPE)
24char *getenv _((char *)); /* Usually in <stdlib.h> */
25#endif
26
51fa4eea
JH
27#ifdef I_FCNTL
28#include <fcntl.h>
29#endif
30#ifdef I_SYS_FILE
31#include <sys/file.h>
32#endif
33
a687059c
LW
34#ifdef IAMSUID
35#ifndef DOSUID
36#define DOSUID
37#endif
38#endif
378cc40b 39
a687059c
LW
40#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
41#ifdef DOSUID
42#undef DOSUID
43#endif
44#endif
8d063cd8 45
873ef191
GS
46#ifdef PERL_OBJECT
47static I32 read_e_script _((CPerlObj* pPerl, int idx, SV *buf_sv, int maxlen));
48#else
a0d0e21e 49static void find_beginning _((void));
bbce6d69 50static void forbid_setid _((char *));
774d564b 51static void incpush _((char *, int));
cb68f92d 52static void init_interp _((void));
748a9306 53static void init_ids _((void));
a0d0e21e
LW
54static void init_debugger _((void));
55static void init_lexer _((void));
56static void init_main_stash _((void));
199100c8 57#ifdef USE_THREADS
52e1cb5e 58static struct perl_thread * init_main_thread _((void));
199100c8 59#endif /* USE_THREADS */
a0d0e21e
LW
60static void init_perllib _((void));
61static void init_postdump_symbols _((int, char **, char **));
62static void init_predump_symbols _((void));
f86702cc 63static void my_exit_jump _((void)) __attribute__((noreturn));
6e72f9df 64static void nuke_stacks _((void));
01f988be 65static void open_script _((char *, bool, SV *, int *fd));
ab821d7f 66static void usage _((char *));
104d25b7
JH
67#ifdef IAMSUID
68static int fd_on_nosuid_fs _((int));
69#endif
01f988be 70static void validate_suid _((char *, char*, int));
afe37c7d 71static I32 read_e_script _((int idx, SV *buf_sv, int maxlen));
76e3520e 72#endif
96436eeb 73
01f988be
GS
74#ifdef PERL_OBJECT
75CPerlObj* perl_alloc(IPerlMem* ipM, IPerlEnv* ipE, IPerlStdIO* ipStd,
76 IPerlLIO* ipLIO, IPerlDir* ipD, IPerlSock* ipS, IPerlProc* ipP)
77{
78 CPerlObj* pPerl = new(ipM) CPerlObj(ipM, ipE, ipStd, ipLIO, ipD, ipS, ipP);
79 if(pPerl != NULL)
80 pPerl->Init();
79072805 81
01f988be
GS
82 return pPerl;
83}
84#else
93a17b20 85PerlInterpreter *
8ac85365 86perl_alloc(void)
79072805 87{
93a17b20 88 PerlInterpreter *sv_interp;
79072805 89
3280af22 90 PL_curinterp = 0;
93a17b20 91 New(53, sv_interp, 1, PerlInterpreter);
79072805
LW
92 return sv_interp;
93}
01f988be 94#endif /* PERL_OBJECT */
79072805
LW
95
96void
76e3520e 97#ifdef PERL_OBJECT
22c35a8c 98perl_construct(void)
76e3520e 99#else
8ac85365 100perl_construct(register PerlInterpreter *sv_interp)
76e3520e 101#endif
79072805 102{
a863c7d1
MB
103#ifdef USE_THREADS
104 int i;
105#ifndef FAKE_THREADS
52e1cb5e 106 struct perl_thread *thr;
a863c7d1
MB
107#endif /* FAKE_THREADS */
108#endif /* USE_THREADS */
11343788 109
76e3520e 110#ifndef PERL_OBJECT
3280af22 111 if (!(PL_curinterp = sv_interp))
79072805 112 return;
76e3520e 113#endif
79072805 114
8990e307 115#ifdef MULTIPLICITY
8f872242 116 ++PL_ninterps;
93a17b20 117 Zero(sv_interp, 1, PerlInterpreter);
8990e307 118#endif
79072805 119
33f46ff6 120 /* Init the real globals (and main thread)? */
3280af22 121 if (!PL_linestr) {
11343788 122#ifdef USE_THREADS
8023c3ce 123
33f46ff6 124 INIT_THREADS;
d55594ae
GS
125#ifdef ALLOC_THREAD_KEY
126 ALLOC_THREAD_KEY;
127#else
533c011a 128 if (pthread_key_create(&PL_thr_key, 0))
a863c7d1 129 croak("panic: pthread_key_create");
d55594ae 130#endif
533c011a 131 MUTEX_INIT(&PL_sv_mutex);
a863c7d1
MB
132 /*
133 * Safe to use basic SV functions from now on (though
134 * not things like mortals or tainting yet).
135 */
533c011a
NIS
136 MUTEX_INIT(&PL_eval_mutex);
137 COND_INIT(&PL_eval_cond);
138 MUTEX_INIT(&PL_threads_mutex);
139 COND_INIT(&PL_nthreads_cond);
dce16143 140#ifdef EMULATE_ATOMIC_REFCOUNTS
533c011a 141 MUTEX_INIT(&PL_svref_mutex);
dce16143 142#endif /* EMULATE_ATOMIC_REFCOUNTS */
a863c7d1 143
5ff3f7a4
GS
144 MUTEX_INIT(&PL_cred_mutex);
145
199100c8 146 thr = init_main_thread();
11343788
MB
147#endif /* USE_THREADS */
148
2aea9f8a
GS
149 PL_curcop = &PL_compiling; /* needed by ckWARN, right away */
150
3280af22
NIS
151 PL_linestr = NEWSV(65,79);
152 sv_upgrade(PL_linestr,SVt_PVIV);
79072805 153
3280af22 154 if (!SvREADONLY(&PL_sv_undef)) {
d689ffdd
JP
155 /* set read-only and try to insure than we wont see REFCNT==0
156 very often */
157
3280af22
NIS
158 SvREADONLY_on(&PL_sv_undef);
159 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
79072805 160
3280af22
NIS
161 sv_setpv(&PL_sv_no,PL_No);
162 SvNV(&PL_sv_no);
163 SvREADONLY_on(&PL_sv_no);
164 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
79072805 165
3280af22
NIS
166 sv_setpv(&PL_sv_yes,PL_Yes);
167 SvNV(&PL_sv_yes);
168 SvREADONLY_on(&PL_sv_yes);
169 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
6e72f9df 170 }
79072805 171
76e3520e
GS
172#ifdef PERL_OBJECT
173 /* TODO: */
6b88bc9c 174 /* PL_sighandlerp = sighandler; */
76e3520e 175#else
3280af22 176 PL_sighandlerp = sighandler;
76e3520e 177#endif
3280af22 178 PL_pidstatus = newHV();
44a8e56a 179
79072805
LW
180#ifdef MSDOS
181 /*
182 * There is no way we can refer to them from Perl so close them to save
183 * space. The other alternative would be to provide STDAUX and STDPRN
184 * filehandles.
185 */
186 (void)fclose(stdaux);
187 (void)fclose(stdprn);
188#endif
189 }
190
3280af22
NIS
191 PL_nrs = newSVpv("\n", 1);
192 PL_rs = SvREFCNT_inc(PL_nrs);
dc92893f 193
1a441de9 194 init_stacks(ARGS);
8990e307 195#ifdef MULTIPLICITY
cb68f92d 196 init_interp();
8f872242 197 PL_perl_destruct_level = 1;
8ebc5c01 198#else
3280af22 199 if (PL_perl_destruct_level > 0)
cb68f92d 200 init_interp();
79072805
LW
201#endif
202
748a9306 203 init_ids();
3280af22 204 PL_lex_state = LEX_NOTPARSING;
a5f75d66 205
3280af22
NIS
206 PL_start_env.je_prev = NULL;
207 PL_start_env.je_ret = -1;
208 PL_start_env.je_mustcatch = TRUE;
209 PL_top_env = &PL_start_env;
f86702cc
PP
210 STATUS_ALL_SUCCESS;
211
36477c24 212 SET_NUMERIC_STANDARD();
a5f75d66 213#if defined(SUBVERSION) && SUBVERSION > 0
3280af22 214 sprintf(PL_patchlevel, "%7.5f", (double) 5
e2666263
PP
215 + ((double) PATCHLEVEL / (double) 1000)
216 + ((double) SUBVERSION / (double) 100000));
a5f75d66 217#else
6b88bc9c 218 sprintf(PL_patchlevel, "%5.3f", (double) 5 +
e2666263 219 ((double) PATCHLEVEL / (double) 1000));
a5f75d66 220#endif
79072805 221
ab821d7f 222#if defined(LOCAL_PATCH_COUNT)
3280af22 223 PL_localpatches = local_patches; /* For possible -v */
ab821d7f
PP
224#endif
225
4b556e6c 226 PerlIO_init(); /* Hook to IO system */
760ac839 227
3280af22
NIS
228 PL_fdpid = newAV(); /* for remembering popen pids by fd */
229 PL_modglobal = newHV(); /* pointers to per-interpreter module globals */
8990e307 230
11343788 231 DEBUG( {
3280af22
NIS
232 New(51,PL_debname,128,char);
233 New(52,PL_debdelim,128,char);
11343788
MB
234 } )
235
8990e307 236 ENTER;
79072805
LW
237}
238
239void
76e3520e 240#ifdef PERL_OBJECT
22c35a8c 241perl_destruct(void)
76e3520e 242#else
8ac85365 243perl_destruct(register PerlInterpreter *sv_interp)
76e3520e 244#endif
79072805 245{
11343788 246 dTHR;
748a9306 247 int destruct_level; /* 0=none, 1=full, 2=full with checks */
8990e307 248 I32 last_sv_count;
a0d0e21e 249 HV *hv;
1f2bfc8a 250#ifdef USE_THREADS
33f46ff6 251 Thread t;
1f2bfc8a 252#endif /* USE_THREADS */
8990e307 253
76e3520e 254#ifndef PERL_OBJECT
3280af22 255 if (!(PL_curinterp = sv_interp))
79072805 256 return;
76e3520e 257#endif
748a9306 258
11343788 259#ifdef USE_THREADS
0f15f207 260#ifndef FAKE_THREADS
8023c3ce
MB
261 /* Pass 1 on any remaining threads: detach joinables, join zombies */
262 retry_cleanup:
533c011a 263 MUTEX_LOCK(&PL_threads_mutex);
8b73bbec 264 DEBUG_S(PerlIO_printf(PerlIO_stderr(),
c7848ba1 265 "perl_destruct: waiting for %d threads...\n",
533c011a 266 PL_nthreads - 1));
33f46ff6 267 for (t = thr->next; t != thr; t = t->next) {
605e5515
MB
268 MUTEX_LOCK(&t->mutex);
269 switch (ThrSTATE(t)) {
270 AV *av;
c7848ba1 271 case THRf_ZOMBIE:
8b73bbec 272 DEBUG_S(PerlIO_printf(PerlIO_stderr(),
c7848ba1 273 "perl_destruct: joining zombie %p\n", t));
605e5515
MB
274 ThrSETSTATE(t, THRf_DEAD);
275 MUTEX_UNLOCK(&t->mutex);
533c011a 276 PL_nthreads--;
8023c3ce
MB
277 /*
278 * The SvREFCNT_dec below may take a long time (e.g. av
279 * may contain an object scalar whose destructor gets
280 * called) so we have to unlock threads_mutex and start
281 * all over again.
282 */
533c011a 283 MUTEX_UNLOCK(&PL_threads_mutex);
ea0efc06 284 JOIN(t, &av);
605e5515 285 SvREFCNT_dec((SV*)av);
8b73bbec 286 DEBUG_S(PerlIO_printf(PerlIO_stderr(),
c7848ba1 287 "perl_destruct: joined zombie %p OK\n", t));
8023c3ce 288 goto retry_cleanup;
c7848ba1 289 case THRf_R_JOINABLE:
8b73bbec 290 DEBUG_S(PerlIO_printf(PerlIO_stderr(),
c7848ba1
MB
291 "perl_destruct: detaching thread %p\n", t));
292 ThrSETSTATE(t, THRf_R_DETACHED);
293 /*
294 * We unlock threads_mutex and t->mutex in the opposite order
295 * from which we locked them just so that DETACH won't
296 * deadlock if it panics. It's only a breach of good style
297 * not a bug since they are unlocks not locks.
298 */
533c011a 299 MUTEX_UNLOCK(&PL_threads_mutex);
c7848ba1
MB
300 DETACH(t);
301 MUTEX_UNLOCK(&t->mutex);
8023c3ce 302 goto retry_cleanup;
c7848ba1 303 default:
8b73bbec 304 DEBUG_S(PerlIO_printf(PerlIO_stderr(),
c7848ba1
MB
305 "perl_destruct: ignoring %p (state %u)\n",
306 t, ThrSTATE(t)));
307 MUTEX_UNLOCK(&t->mutex);
c7848ba1 308 /* fall through and out */
33f46ff6
MB
309 }
310 }
8023c3ce
MB
311 /* We leave the above "Pass 1" loop with threads_mutex still locked */
312
313 /* Pass 2 on remaining threads: wait for the thread count to drop to one */
533c011a 314 while (PL_nthreads > 1)
11343788 315 {
8b73bbec 316 DEBUG_S(PerlIO_printf(PerlIO_stderr(),
c7848ba1 317 "perl_destruct: final wait for %d threads\n",
533c011a
NIS
318 PL_nthreads - 1));
319 COND_WAIT(&PL_nthreads_cond, &PL_threads_mutex);
11343788
MB
320 }
321 /* At this point, we're the last thread */
533c011a 322 MUTEX_UNLOCK(&PL_threads_mutex);
8b73bbec 323 DEBUG_S(PerlIO_printf(PerlIO_stderr(), "perl_destruct: armageddon has arrived\n"));
533c011a
NIS
324 MUTEX_DESTROY(&PL_threads_mutex);
325 COND_DESTROY(&PL_nthreads_cond);
0f15f207 326#endif /* !defined(FAKE_THREADS) */
11343788
MB
327#endif /* USE_THREADS */
328
3280af22 329 destruct_level = PL_perl_destruct_level;
4633a7c4
LW
330#ifdef DEBUGGING
331 {
332 char *s;
76e3520e 333 if (s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL")) {
5f05dabc
PP
334 int i = atoi(s);
335 if (destruct_level < i)
336 destruct_level = i;
337 }
4633a7c4
LW
338 }
339#endif
340
8990e307 341 LEAVE;
a0d0e21e
LW
342 FREETMPS;
343
cb68f92d 344#ifdef MULTIPLICITY
8f872242 345 --PL_ninterps;
cb68f92d
GS
346#endif
347
ff0cee69
PP
348 /* We must account for everything. */
349
350 /* Destroy the main CV and syntax tree */
3280af22
NIS
351 if (PL_main_root) {
352 PL_curpad = AvARRAY(PL_comppad);
353 op_free(PL_main_root);
354 PL_main_root = Nullop;
a0d0e21e 355 }
3280af22
NIS
356 PL_curcop = &PL_compiling;
357 PL_main_start = Nullop;
358 SvREFCNT_dec(PL_main_cv);
359 PL_main_cv = Nullcv;
24d3c518 360 PL_dirty = TRUE;
ff0cee69 361
3280af22 362 if (PL_sv_objcount) {
a0d0e21e
LW
363 /*
364 * Try to destruct global references. We do this first so that the
365 * destructors and destructees still exist. Some sv's might remain.
366 * Non-referenced objects are on their own.
367 */
a0d0e21e 368 sv_clean_objs();
8990e307
LW
369 }
370
5cd24f17 371 /* unhook hooks which will soon be, or use, destroyed data */
3280af22
NIS
372 SvREFCNT_dec(PL_warnhook);
373 PL_warnhook = Nullsv;
374 SvREFCNT_dec(PL_diehook);
375 PL_diehook = Nullsv;
376 SvREFCNT_dec(PL_parsehook);
377 PL_parsehook = Nullsv;
5cd24f17 378
4b556e6c 379 /* call exit list functions */
3280af22
NIS
380 while (PL_exitlistlen-- > 0)
381 PL_exitlist[PL_exitlistlen].fn(PERL_OBJECT_THIS_ PL_exitlist[PL_exitlistlen].ptr);
4b556e6c 382
3280af22 383 Safefree(PL_exitlist);
4b556e6c 384
a0d0e21e 385 if (destruct_level == 0){
8990e307 386
a0d0e21e
LW
387 DEBUG_P(debprofdump());
388
389 /* The exit() function will do everything that needs doing. */
390 return;
391 }
5dd60ef7 392
5f05dabc
PP
393 /* loosen bonds of global variables */
394
3280af22
NIS
395 if(PL_rsfp) {
396 (void)PerlIO_close(PL_rsfp);
397 PL_rsfp = Nullfp;
8ebc5c01
PP
398 }
399
400 /* Filters for program text */
3280af22
NIS
401 SvREFCNT_dec(PL_rsfp_filters);
402 PL_rsfp_filters = Nullav;
8ebc5c01
PP
403
404 /* switches */
3280af22
NIS
405 PL_preprocess = FALSE;
406 PL_minus_n = FALSE;
407 PL_minus_p = FALSE;
408 PL_minus_l = FALSE;
409 PL_minus_a = FALSE;
410 PL_minus_F = FALSE;
411 PL_doswitches = FALSE;
599cee73 412 PL_dowarn = G_WARN_OFF;
3280af22
NIS
413 PL_doextract = FALSE;
414 PL_sawampersand = FALSE; /* must save all match strings */
415 PL_sawstudy = FALSE; /* do fbm_instr on all strings */
416 PL_sawvec = FALSE;
417 PL_unsafe = FALSE;
418
419 Safefree(PL_inplace);
420 PL_inplace = Nullch;
421
422 if (PL_e_script) {
423 SvREFCNT_dec(PL_e_script);
424 PL_e_script = Nullsv;
8ebc5c01
PP
425 }
426
427 /* magical thingies */
428
3280af22
NIS
429 Safefree(PL_ofs); /* $, */
430 PL_ofs = Nullch;
5f05dabc 431
3280af22
NIS
432 Safefree(PL_ors); /* $\ */
433 PL_ors = Nullch;
8ebc5c01 434
3280af22
NIS
435 SvREFCNT_dec(PL_rs); /* $/ */
436 PL_rs = Nullsv;
dc92893f 437
3280af22
NIS
438 SvREFCNT_dec(PL_nrs); /* $/ helper */
439 PL_nrs = Nullsv;
5f05dabc 440
3280af22 441 PL_multiline = 0; /* $* */
5f05dabc 442
3280af22
NIS
443 SvREFCNT_dec(PL_statname);
444 PL_statname = Nullsv;
445 PL_statgv = Nullgv;
5f05dabc 446
8ebc5c01
PP
447 /* defgv, aka *_ should be taken care of elsewhere */
448
8ebc5c01 449 /* clean up after study() */
3280af22
NIS
450 SvREFCNT_dec(PL_lastscream);
451 PL_lastscream = Nullsv;
452 Safefree(PL_screamfirst);
453 PL_screamfirst = 0;
454 Safefree(PL_screamnext);
455 PL_screamnext = 0;
8ebc5c01
PP
456
457 /* startup and shutdown function lists */
3280af22
NIS
458 SvREFCNT_dec(PL_beginav);
459 SvREFCNT_dec(PL_endav);
460 SvREFCNT_dec(PL_initav);
461 PL_beginav = Nullav;
462 PL_endav = Nullav;
463 PL_initav = Nullav;
5618dfe8 464
8ebc5c01 465 /* shortcuts just get cleared */
3280af22
NIS
466 PL_envgv = Nullgv;
467 PL_siggv = Nullgv;
468 PL_incgv = Nullgv;
469 PL_hintgv = Nullgv;
470 PL_errgv = Nullgv;
471 PL_argvgv = Nullgv;
472 PL_argvoutgv = Nullgv;
473 PL_stdingv = Nullgv;
474 PL_last_in_gv = Nullgv;
475 PL_replgv = Nullgv;
8ebc5c01
PP
476
477 /* reset so print() ends up where we expect */
478 setdefout(Nullgv);
479
a0d0e21e 480 /* Prepare to destruct main symbol table. */
5f05dabc 481
3280af22
NIS
482 hv = PL_defstash;
483 PL_defstash = 0;
a0d0e21e
LW
484 SvREFCNT_dec(hv);
485
486 FREETMPS;
487 if (destruct_level >= 2) {
3280af22 488 if (PL_scopestack_ix != 0)
ff0cee69 489 warn("Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
3280af22
NIS
490 (long)PL_scopestack_ix);
491 if (PL_savestack_ix != 0)
ff0cee69 492 warn("Unbalanced saves: %ld more saves than restores\n",
3280af22
NIS
493 (long)PL_savestack_ix);
494 if (PL_tmps_floor != -1)
ff0cee69 495 warn("Unbalanced tmps: %ld more allocs than frees\n",
3280af22 496 (long)PL_tmps_floor + 1);
a0d0e21e 497 if (cxstack_ix != -1)
ff0cee69
PP
498 warn("Unbalanced context: %ld more PUSHes than POPs\n",
499 (long)cxstack_ix + 1);
a0d0e21e 500 }
8990e307
LW
501
502 /* Now absolutely destruct everything, somehow or other, loops or no. */
8990e307 503 last_sv_count = 0;
3280af22
NIS
504 SvFLAGS(PL_strtab) |= SVTYPEMASK; /* don't clean out strtab now */
505 while (PL_sv_count != 0 && PL_sv_count != last_sv_count) {
506 last_sv_count = PL_sv_count;
8990e307
LW
507 sv_clean_all();
508 }
3280af22
NIS
509 SvFLAGS(PL_strtab) &= ~SVTYPEMASK;
510 SvFLAGS(PL_strtab) |= SVt_PVHV;
6e72f9df
PP
511
512 /* Destruct the global string table. */
513 {
514 /* Yell and reset the HeVAL() slots that are still holding refcounts,
515 * so that sv_free() won't fail on them.
516 */
517 I32 riter;
518 I32 max;
519 HE *hent;
520 HE **array;
521
522 riter = 0;
3280af22
NIS
523 max = HvMAX(PL_strtab);
524 array = HvARRAY(PL_strtab);
6e72f9df
PP
525 hent = array[0];
526 for (;;) {
527 if (hent) {
528 warn("Unbalanced string table refcount: (%d) for \"%s\"",
529 HeVAL(hent) - Nullsv, HeKEY(hent));
530 HeVAL(hent) = Nullsv;
531 hent = HeNEXT(hent);
532 }
533 if (!hent) {
534 if (++riter > max)
535 break;
536 hent = array[riter];
537 }
538 }
539 }
3280af22 540 SvREFCNT_dec(PL_strtab);
6e72f9df 541
3280af22
NIS
542 if (PL_sv_count != 0)
543 warn("Scalars leaked: %ld\n", (long)PL_sv_count);
6e72f9df 544
4633a7c4 545 sv_free_arenas();
44a8e56a
PP
546
547 /* No SVs have survived, need to clean out */
3280af22
NIS
548 PL_linestr = NULL;
549 PL_pidstatus = Nullhv;
550 Safefree(PL_origfilename);
551 Safefree(PL_archpat_auto);
552 Safefree(PL_reg_start_tmp);
5c5e4c24
IZ
553 if (PL_reg_curpm)
554 Safefree(PL_reg_curpm);
3280af22
NIS
555 Safefree(HeKEY_hek(&PL_hv_fetch_ent_mh));
556 Safefree(PL_op_mask);
6e72f9df 557 nuke_stacks();
3280af22 558 PL_hints = 0; /* Reset hints. Should hints be per-interpreter ? */
a0d0e21e
LW
559
560 DEBUG_P(debprofdump());
11343788 561#ifdef USE_THREADS
5f08fbcd 562 MUTEX_DESTROY(&PL_strtab_mutex);
533c011a
NIS
563 MUTEX_DESTROY(&PL_sv_mutex);
564 MUTEX_DESTROY(&PL_eval_mutex);
5ff3f7a4 565 MUTEX_DESTROY(&PL_cred_mutex);
533c011a 566 COND_DESTROY(&PL_eval_cond);
fc36a67e 567
8023c3ce 568 /* As the penultimate thing, free the non-arena SV for thrsv */
533c011a
NIS
569 Safefree(SvPVX(PL_thrsv));
570 Safefree(SvANY(PL_thrsv));
571 Safefree(PL_thrsv);
572 PL_thrsv = Nullsv;
8023c3ce
MB
573#endif /* USE_THREADS */
574
fc36a67e
PP
575 /* As the absolutely last thing, free the non-arena SV for mess() */
576
3280af22 577 if (PL_mess_sv) {
9c63abab
GS
578 /* it could have accumulated taint magic */
579 if (SvTYPE(PL_mess_sv) >= SVt_PVMG) {
580 MAGIC* mg;
581 MAGIC* moremagic;
582 for (mg = SvMAGIC(PL_mess_sv); mg; mg = moremagic) {
583 moremagic = mg->mg_moremagic;
584 if (mg->mg_ptr && mg->mg_type != 'g' && mg->mg_len >= 0)
585 Safefree(mg->mg_ptr);
586 Safefree(mg);
587 }
588 }
fc36a67e 589 /* we know that type >= SVt_PV */
3280af22
NIS
590 SvOOK_off(PL_mess_sv);
591 Safefree(SvPVX(PL_mess_sv));
592 Safefree(SvANY(PL_mess_sv));
593 Safefree(PL_mess_sv);
594 PL_mess_sv = Nullsv;
fc36a67e 595 }
79072805
LW
596}
597
598void
76e3520e 599#ifdef PERL_OBJECT
22c35a8c 600perl_free(void)
76e3520e 601#else
8ac85365 602perl_free(PerlInterpreter *sv_interp)
76e3520e 603#endif
79072805 604{
76e3520e 605#ifdef PERL_OBJECT
565764a8 606 Safefree(this);
76e3520e 607#else
3280af22 608 if (!(PL_curinterp = sv_interp))
79072805
LW
609 return;
610 Safefree(sv_interp);
76e3520e 611#endif
79072805
LW
612}
613
4b556e6c 614void
873ef191 615#ifdef PERL_OBJECT
22c35a8c 616perl_atexit(void (*fn) (CPerlObj*,void *), void *ptr)
873ef191 617#else
4b556e6c 618perl_atexit(void (*fn) (void *), void *ptr)
873ef191 619#endif
4b556e6c 620{
3280af22
NIS
621 Renew(PL_exitlist, PL_exitlistlen+1, PerlExitListEntry);
622 PL_exitlist[PL_exitlistlen].fn = fn;
623 PL_exitlist[PL_exitlistlen].ptr = ptr;
624 ++PL_exitlistlen;
4b556e6c
JD
625}
626
79072805 627int
76e3520e 628#ifdef PERL_OBJECT
22c35a8c 629perl_parse(void (*xsinit) (CPerlObj*), int argc, char **argv, char **env)
76e3520e 630#else
8ac85365 631perl_parse(PerlInterpreter *sv_interp, void (*xsinit) (void), int argc, char **argv, char **env)
76e3520e 632#endif
8d063cd8 633{
11343788 634 dTHR;
6224f72b
GS
635 register SV *sv;
636 register char *s;
637 char *scriptname = NULL;
638 VOL bool dosearch = FALSE;
639 char *validarg = "";
640 I32 oldscope;
641 AV* comppadlist;
642 dJMPENV;
643 int ret;
644 int fdscript = -1;
8d063cd8 645
a687059c
LW
646#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
647#ifdef IAMSUID
648#undef IAMSUID
463ee0b2 649 croak("suidperl is no longer needed since the kernel can now execute\n\
a687059c
LW
650setuid perl scripts securely.\n");
651#endif
652#endif
653
76e3520e 654#ifndef PERL_OBJECT
3280af22 655 if (!(PL_curinterp = sv_interp))
79072805 656 return 255;
76e3520e 657#endif
79072805 658
6e72f9df
PP
659#if defined(NeXT) && defined(__DYNAMIC__)
660 _dyld_lookup_and_bind
661 ("__environ", (unsigned long *) &environ_pointer, NULL);
662#endif /* environ */
663
3280af22
NIS
664 PL_origargv = argv;
665 PL_origargc = argc;
a0d0e21e 666#ifndef VMS /* VMS doesn't have environ array */
3280af22 667 PL_origenviron = environ;
a0d0e21e
LW
668#endif
669
3280af22 670 if (PL_do_undump) {
a0d0e21e
LW
671
672 /* Come here if running an undumped a.out. */
673
3280af22
NIS
674 PL_origfilename = savepv(argv[0]);
675 PL_do_undump = FALSE;
a0d0e21e 676 cxstack_ix = -1; /* start label stack again */
748a9306 677 init_ids();
a0d0e21e
LW
678 init_postdump_symbols(argc,argv,env);
679 return 0;
680 }
681
3280af22
NIS
682 if (PL_main_root) {
683 PL_curpad = AvARRAY(PL_comppad);
684 op_free(PL_main_root);
685 PL_main_root = Nullop;
ff0cee69 686 }
3280af22
NIS
687 PL_main_start = Nullop;
688 SvREFCNT_dec(PL_main_cv);
689 PL_main_cv = Nullcv;
79072805 690
3280af22
NIS
691 time(&PL_basetime);
692 oldscope = PL_scopestack_ix;
599cee73 693 PL_dowarn = G_WARN_OFF;
f86702cc 694
6224f72b
GS
695 JMPENV_PUSH(ret);
696 switch (ret) {
697 case 1:
698 STATUS_ALL_FAILURE;
699 /* FALL THROUGH */
700 case 2:
701 /* my_exit() was called */
3280af22 702 while (PL_scopestack_ix > oldscope)
6224f72b
GS
703 LEAVE;
704 FREETMPS;
3280af22
NIS
705 PL_curstash = PL_defstash;
706 if (PL_endav)
707 call_list(oldscope, PL_endav);
6224f72b
GS
708 JMPENV_POP;
709 return STATUS_NATIVE_EXPORT;
710 case 3:
711 JMPENV_POP;
712 PerlIO_printf(PerlIO_stderr(), "panic: top_env\n");
713 return 1;
714 }
79072805 715
3280af22 716 sv_setpvn(PL_linestr,"",0);
6224f72b
GS
717 sv = newSVpv("",0); /* first used for -I flags */
718 SAVEFREESV(sv);
719 init_main_stash();
54310121 720
6224f72b
GS
721 for (argc--,argv++; argc > 0; argc--,argv++) {
722 if (argv[0][0] != '-' || !argv[0][1])
723 break;
724#ifdef DOSUID
725 if (*validarg)
726 validarg = " PHOOEY ";
727 else
728 validarg = argv[0];
13281fa4 729#endif
6224f72b
GS
730 s = argv[0]+1;
731 reswitch:
732 switch (*s) {
733 case ' ':
734 case '0':
735 case 'F':
736 case 'a':
737 case 'c':
738 case 'd':
739 case 'D':
740 case 'h':
741 case 'i':
742 case 'l':
743 case 'M':
744 case 'm':
745 case 'n':
746 case 'p':
747 case 's':
748 case 'u':
749 case 'U':
750 case 'v':
599cee73
PM
751 case 'W':
752 case 'X':
6224f72b
GS
753 case 'w':
754 if (s = moreswitches(s))
755 goto reswitch;
756 break;
33b78306 757
6224f72b 758 case 'T':
3280af22 759 PL_tainting = TRUE;
6224f72b
GS
760 s++;
761 goto reswitch;
f86702cc 762
6224f72b 763 case 'e':
3280af22 764 if (PL_euid != PL_uid || PL_egid != PL_gid)
6224f72b 765 croak("No -e allowed in setuid scripts");
3280af22
NIS
766 if (!PL_e_script) {
767 PL_e_script = newSVpv("",0);
6224f72b
GS
768 filter_add(read_e_script, NULL);
769 }
770 if (*++s)
3280af22 771 sv_catpv(PL_e_script, s);
6224f72b 772 else if (argv[1]) {
3280af22 773 sv_catpv(PL_e_script, argv[1]);
6224f72b
GS
774 argc--,argv++;
775 }
776 else
777 croak("No code specified for -e");
3280af22 778 sv_catpv(PL_e_script, "\n");
6224f72b 779 break;
afe37c7d 780
6224f72b
GS
781 case 'I': /* -I handled both here and in moreswitches() */
782 forbid_setid("-I");
783 if (!*++s && (s=argv[1]) != Nullch) {
784 argc--,argv++;
785 }
786 while (s && isSPACE(*s))
787 ++s;
788 if (s && *s) {
789 char *e, *p;
790 for (e = s; *e && !isSPACE(*e); e++) ;
791 p = savepvn(s, e-s);
792 incpush(p, TRUE);
793 sv_catpv(sv,"-I");
794 sv_catpv(sv,p);
795 sv_catpv(sv," ");
796 Safefree(p);
797 } /* XXX else croak? */
798 break;
799 case 'P':
800 forbid_setid("-P");
3280af22 801 PL_preprocess = TRUE;
6224f72b
GS
802 s++;
803 goto reswitch;
804 case 'S':
805 forbid_setid("-S");
806 dosearch = TRUE;
807 s++;
808 goto reswitch;
809 case 'V':
3280af22
NIS
810 if (!PL_preambleav)
811 PL_preambleav = newAV();
812 av_push(PL_preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
6224f72b 813 if (*++s != ':') {
3280af22 814 PL_Sv = newSVpv("print myconfig();",0);
6224f72b 815#ifdef VMS
6b88bc9c 816 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
6224f72b 817#else
3280af22 818 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
6224f72b 819#endif
22c35a8c 820#if defined(DEBUGGING) || defined(MULTIPLICITY)
3280af22 821 sv_catpv(PL_Sv,"\" Compile-time options:");
6224f72b 822# ifdef DEBUGGING
3280af22 823 sv_catpv(PL_Sv," DEBUGGING");
6224f72b 824# endif
6224f72b 825# ifdef MULTIPLICITY
8f872242 826 sv_catpv(PL_Sv," MULTIPLICITY");
6224f72b 827# endif
3280af22 828 sv_catpv(PL_Sv,"\\n\",");
6224f72b
GS
829#endif
830#if defined(LOCAL_PATCH_COUNT)
831 if (LOCAL_PATCH_COUNT > 0) {
832 int i;
3280af22 833 sv_catpv(PL_Sv,"\" Locally applied patches:\\n\",");
6224f72b 834 for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
3280af22 835 if (PL_localpatches[i])
642653c7 836 sv_catpvf(PL_Sv,"q\" \t%s\n\",",PL_localpatches[i]);
6224f72b
GS
837 }
838 }
839#endif
3280af22 840 sv_catpvf(PL_Sv,"\" Built under %s\\n\"",OSNAME);
6224f72b
GS
841#ifdef __DATE__
842# ifdef __TIME__
3280af22 843 sv_catpvf(PL_Sv,",\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
6224f72b 844# else
6b88bc9c 845 sv_catpvf(PL_Sv,",\" Compiled on %s\\n\"",__DATE__);
6224f72b
GS
846# endif
847#endif
3280af22 848 sv_catpv(PL_Sv, "; \
6224f72b
GS
849$\"=\"\\n \"; \
850@env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; \
851print \" \\%ENV:\\n @env\\n\" if @env; \
852print \" \\@INC:\\n @INC\\n\";");
853 }
854 else {
3280af22
NIS
855 PL_Sv = newSVpv("config_vars(qw(",0);
856 sv_catpv(PL_Sv, ++s);
857 sv_catpv(PL_Sv, "))");
6224f72b
GS
858 s += strlen(s);
859 }
3280af22 860 av_push(PL_preambleav, PL_Sv);
6224f72b
GS
861 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
862 goto reswitch;
863 case 'x':
3280af22 864 PL_doextract = TRUE;
6224f72b
GS
865 s++;
866 if (*s)
3280af22 867 PL_cddir = savepv(s);
6224f72b
GS
868 break;
869 case 0:
870 break;
871 case '-':
872 if (!*++s || isSPACE(*s)) {
873 argc--,argv++;
874 goto switch_end;
875 }
876 /* catch use of gnu style long options */
877 if (strEQ(s, "version")) {
878 s = "v";
879 goto reswitch;
880 }
881 if (strEQ(s, "help")) {
882 s = "h";
883 goto reswitch;
884 }
885 s--;
886 /* FALL THROUGH */
887 default:
888 croak("Unrecognized switch: -%s (-h will show valid options)",s);
8d063cd8
LW
889 }
890 }
6224f72b 891 switch_end:
54310121 892
3280af22 893 if (!PL_tainting && (s = PerlEnv_getenv("PERL5OPT"))) {
74288ac8
GS
894 while (isSPACE(*s))
895 s++;
896 if (*s == '-' && *(s+1) == 'T')
897 PL_tainting = TRUE;
898 else {
899 while (s && *s) {
900 while (isSPACE(*s))
901 s++;
902 if (*s == '-') {
903 s++;
904 if (isSPACE(*s))
905 continue;
906 }
907 if (!*s)
908 break;
909 if (!strchr("DIMUdmw", *s))
910 croak("Illegal switch in PERL5OPT: -%c", *s);
911 s = moreswitches(s);
6224f72b 912 }
6224f72b
GS
913 }
914 }
a0d0e21e 915
6224f72b
GS
916 if (!scriptname)
917 scriptname = argv[0];
3280af22 918 if (PL_e_script) {
6224f72b
GS
919 argc++,argv--;
920 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
921 }
922 else if (scriptname == Nullch) {
923#ifdef MSDOS
924 if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
925 moreswitches("h");
926#endif
927 scriptname = "-";
928 }
929
930 init_perllib();
931
932 open_script(scriptname,dosearch,sv,&fdscript);
933
934 validate_suid(validarg, scriptname,fdscript);
935
3280af22 936 if (PL_doextract)
6224f72b
GS
937 find_beginning();
938
3280af22
NIS
939 PL_main_cv = PL_compcv = (CV*)NEWSV(1104,0);
940 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
941 CvUNIQUE_on(PL_compcv);
942
943 PL_comppad = newAV();
944 av_push(PL_comppad, Nullsv);
945 PL_curpad = AvARRAY(PL_comppad);
946 PL_comppad_name = newAV();
947 PL_comppad_name_fill = 0;
948 PL_min_intro_pending = 0;
949 PL_padix = 0;
6224f72b 950#ifdef USE_THREADS
533c011a
NIS
951 av_store(PL_comppad_name, 0, newSVpv("@_", 2));
952 PL_curpad[0] = (SV*)newAV();
953 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
954 CvOWNER(PL_compcv) = 0;
955 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
956 MUTEX_INIT(CvMUTEXP(PL_compcv));
6224f72b
GS
957#endif /* USE_THREADS */
958
959 comppadlist = newAV();
960 AvREAL_off(comppadlist);
3280af22
NIS
961 av_store(comppadlist, 0, (SV*)PL_comppad_name);
962 av_store(comppadlist, 1, (SV*)PL_comppad);
963 CvPADLIST(PL_compcv) = comppadlist;
6224f72b
GS
964
965 boot_core_UNIVERSAL();
966
967 if (xsinit)
968 (*xsinit)(PERL_OBJECT_THIS); /* in case linked C routines want magical variables */
969#if defined(VMS) || defined(WIN32) || defined(DJGPP)
970 init_os_extras();
971#endif
972
973 init_predump_symbols();
974 /* init_postdump_symbols not currently designed to be called */
975 /* more than once (ENV isn't cleared first, for example) */
976 /* But running with -u leaves %ENV & @ARGV undefined! XXX */
3280af22 977 if (!PL_do_undump)
6224f72b
GS
978 init_postdump_symbols(argc,argv,env);
979
980 init_lexer();
981
982 /* now parse the script */
983
984 SETERRNO(0,SS$_NORMAL);
3280af22
NIS
985 PL_error_count = 0;
986 if (yyparse() || PL_error_count) {
987 if (PL_minus_c)
988 croak("%s had compilation errors.\n", PL_origfilename);
6224f72b
GS
989 else {
990 croak("Execution of %s aborted due to compilation errors.\n",
3280af22 991 PL_origfilename);
6224f72b
GS
992 }
993 }
3280af22
NIS
994 PL_curcop->cop_line = 0;
995 PL_curstash = PL_defstash;
996 PL_preprocess = FALSE;
997 if (PL_e_script) {
998 SvREFCNT_dec(PL_e_script);
999 PL_e_script = Nullsv;
6224f72b
GS
1000 }
1001
1002 /* now that script is parsed, we can modify record separator */
3280af22
NIS
1003 SvREFCNT_dec(PL_rs);
1004 PL_rs = SvREFCNT_inc(PL_nrs);
1005 sv_setsv(perl_get_sv("/", TRUE), PL_rs);
1006 if (PL_do_undump)
6224f72b
GS
1007 my_unexec();
1008
599cee73 1009 if (ckWARN(WARN_ONCE))
3280af22 1010 gv_check(PL_defstash);
6224f72b
GS
1011
1012 LEAVE;
1013 FREETMPS;
1014
1015#ifdef MYMALLOC
1016 if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
1017 dump_mstats("after compilation:");
1018#endif
1019
1020 ENTER;
3280af22 1021 PL_restartop = 0;
6224f72b
GS
1022 JMPENV_POP;
1023 return 0;
1024}
1025
1026int
1027#ifdef PERL_OBJECT
22c35a8c 1028perl_run(void)
6224f72b
GS
1029#else
1030perl_run(PerlInterpreter *sv_interp)
1031#endif
1032{
de616352 1033 dTHR;
6224f72b
GS
1034 I32 oldscope;
1035 dJMPENV;
1036 int ret;
1037
1038#ifndef PERL_OBJECT
3280af22 1039 if (!(PL_curinterp = sv_interp))
6224f72b
GS
1040 return 255;
1041#endif
1042
3280af22 1043 oldscope = PL_scopestack_ix;
6224f72b
GS
1044
1045 JMPENV_PUSH(ret);
1046 switch (ret) {
1047 case 1:
1048 cxstack_ix = -1; /* start context stack again */
1049 break;
1050 case 2:
1051 /* my_exit() was called */
3280af22 1052 while (PL_scopestack_ix > oldscope)
6224f72b
GS
1053 LEAVE;
1054 FREETMPS;
3280af22
NIS
1055 PL_curstash = PL_defstash;
1056 if (PL_endav)
1057 call_list(oldscope, PL_endav);
6224f72b
GS
1058#ifdef MYMALLOC
1059 if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
1060 dump_mstats("after execution: ");
1061#endif
1062 JMPENV_POP;
1063 return STATUS_NATIVE_EXPORT;
1064 case 3:
3280af22 1065 if (!PL_restartop) {
6224f72b
GS
1066 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
1067 FREETMPS;
1068 JMPENV_POP;
1069 return 1;
1070 }
3280af22 1071 POPSTACK_TO(PL_mainstack);
6224f72b
GS
1072 break;
1073 }
1074
1075 DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
3280af22 1076 PL_sawampersand ? "Enabling" : "Omitting"));
6224f72b 1077
3280af22 1078 if (!PL_restartop) {
6224f72b
GS
1079 DEBUG_x(dump_all());
1080 DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
8b73bbec 1081 DEBUG_S(PerlIO_printf(Perl_debug_log, "main thread is 0x%lx\n",
6224f72b 1082 (unsigned long) thr));
6224f72b 1083
3280af22
NIS
1084 if (PL_minus_c) {
1085 PerlIO_printf(PerlIO_stderr(), "%s syntax OK\n", PL_origfilename);
6224f72b
GS
1086 my_exit(0);
1087 }
3280af22
NIS
1088 if (PERLDB_SINGLE && PL_DBsingle)
1089 sv_setiv(PL_DBsingle, 1);
1090 if (PL_initav)
1091 call_list(oldscope, PL_initav);
6224f72b
GS
1092 }
1093
1094 /* do it */
1095
3280af22 1096 if (PL_restartop) {
533c011a 1097 PL_op = PL_restartop;
3280af22 1098 PL_restartop = 0;
6224f72b
GS
1099 CALLRUNOPS();
1100 }
3280af22
NIS
1101 else if (PL_main_start) {
1102 CvDEPTH(PL_main_cv) = 1;
533c011a 1103 PL_op = PL_main_start;
6224f72b
GS
1104 CALLRUNOPS();
1105 }
1106
1107 my_exit(0);
1108 /* NOTREACHED */
1109 return 0;
1110}
1111
1112SV*
08105a92 1113perl_get_sv(const char *name, I32 create)
6224f72b
GS
1114{
1115 GV *gv;
1116#ifdef USE_THREADS
1117 if (name[1] == '\0' && !isALPHA(name[0])) {
1118 PADOFFSET tmp = find_threadsv(name);
1119 if (tmp != NOT_IN_PAD) {
1120 dTHR;
1121 return THREADSV(tmp);
1122 }
1123 }
1124#endif /* USE_THREADS */
1125 gv = gv_fetchpv(name, create, SVt_PV);
1126 if (gv)
1127 return GvSV(gv);
1128 return Nullsv;
1129}
1130
1131AV*
08105a92 1132perl_get_av(const char *name, I32 create)
6224f72b
GS
1133{
1134 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
1135 if (create)
1136 return GvAVn(gv);
1137 if (gv)
1138 return GvAV(gv);
1139 return Nullav;
1140}
1141
1142HV*
08105a92 1143perl_get_hv(const char *name, I32 create)
6224f72b 1144{
a0d0e21e
LW
1145 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
1146 if (create)
1147 return GvHVn(gv);
1148 if (gv)
1149 return GvHV(gv);
1150 return Nullhv;
1151}
1152
1153CV*
08105a92 1154perl_get_cv(const char *name, I32 create)
a0d0e21e
LW
1155{
1156 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
b099ddc0 1157 /* XXX unsafe for threads if eval_owner isn't held */
8ebc5c01 1158 if (create && !GvCVu(gv))
774d564b 1159 return newSUB(start_subparse(FALSE, 0),
a0d0e21e 1160 newSVOP(OP_CONST, 0, newSVpv(name,0)),
4633a7c4 1161 Nullop,
a0d0e21e
LW
1162 Nullop);
1163 if (gv)
8ebc5c01 1164 return GvCVu(gv);
a0d0e21e
LW
1165 return Nullcv;
1166}
1167
79072805
LW
1168/* Be sure to refetch the stack pointer after calling these routines. */
1169
a0d0e21e 1170I32
08105a92 1171perl_call_argv(const char *sub_name, I32 flags, register char **argv)
8ac85365
NIS
1172
1173 /* See G_* flags in cop.h */
1174 /* null terminated arg list */
8990e307 1175{
a0d0e21e 1176 dSP;
8990e307 1177
924508f0 1178 PUSHMARK(SP);
a0d0e21e 1179 if (argv) {
8990e307 1180 while (*argv) {
a0d0e21e 1181 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
8990e307
LW
1182 argv++;
1183 }
a0d0e21e 1184 PUTBACK;
8990e307 1185 }
22239a37 1186 return perl_call_pv(sub_name, flags);
8990e307
LW
1187}
1188
a0d0e21e 1189I32
08105a92 1190perl_call_pv(const char *sub_name, I32 flags)
8ac85365
NIS
1191 /* name of the subroutine */
1192 /* See G_* flags in cop.h */
a0d0e21e 1193{
22239a37 1194 return perl_call_sv((SV*)perl_get_cv(sub_name, TRUE), flags);
a0d0e21e
LW
1195}
1196
1197I32
08105a92 1198perl_call_method(const char *methname, I32 flags)
8ac85365
NIS
1199 /* name of the subroutine */
1200 /* See G_* flags in cop.h */
a0d0e21e
LW
1201{
1202 dSP;
1203 OP myop;
533c011a
NIS
1204 if (!PL_op)
1205 PL_op = &myop;
a0d0e21e
LW
1206 XPUSHs(sv_2mortal(newSVpv(methname,0)));
1207 PUTBACK;
11343788 1208 pp_method(ARGS);
533c011a
NIS
1209 if(PL_op == &myop)
1210 PL_op = Nullop;
3280af22 1211 return perl_call_sv(*PL_stack_sp--, flags);
a0d0e21e
LW
1212}
1213
1214/* May be called with any of a CV, a GV, or an SV containing the name. */
1215I32
8ac85365
NIS
1216perl_call_sv(SV *sv, I32 flags)
1217
1218 /* See G_* flags in cop.h */
a0d0e21e 1219{
924508f0 1220 dSP;
a0d0e21e 1221 LOGOP myop; /* fake syntax tree node */
aa689395 1222 I32 oldmark;
a0d0e21e 1223 I32 retval;
a0d0e21e 1224 I32 oldscope;
54310121
PP
1225 bool oldcatch = CATCH_GET;
1226 dJMPENV;
6224f72b 1227 int ret;
533c011a 1228 OP* oldop = PL_op;
1e422769 1229
a0d0e21e
LW
1230 if (flags & G_DISCARD) {
1231 ENTER;
1232 SAVETMPS;
1233 }
1234
aa689395 1235 Zero(&myop, 1, LOGOP);
54310121 1236 myop.op_next = Nullop;
f51d4af5 1237 if (!(flags & G_NOARGS))
aa689395 1238 myop.op_flags |= OPf_STACKED;
54310121
PP
1239 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1240 (flags & G_ARRAY) ? OPf_WANT_LIST :
1241 OPf_WANT_SCALAR);
462e5cf6 1242 SAVEOP();
533c011a 1243 PL_op = (OP*)&myop;
aa689395 1244
3280af22
NIS
1245 EXTEND(PL_stack_sp, 1);
1246 *++PL_stack_sp = sv;
aa689395 1247 oldmark = TOPMARK;
3280af22 1248 oldscope = PL_scopestack_ix;
a0d0e21e 1249
3280af22 1250 if (PERLDB_SUB && PL_curstash != PL_debstash
36477c24 1251 /* Handle first BEGIN of -d. */
3280af22 1252 && (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub)))
36477c24
PP
1253 /* Try harder, since this may have been a sighandler, thus
1254 * curstash may be meaningless. */
3280af22 1255 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != PL_debstash)
491527d0 1256 && !(flags & G_NODEBUG))
533c011a 1257 PL_op->op_private |= OPpENTERSUB_DB;
a0d0e21e
LW
1258
1259 if (flags & G_EVAL) {
533c011a 1260 cLOGOP->op_other = PL_op;
3280af22 1261 PL_markstack_ptr--;
4633a7c4
LW
1262 /* we're trying to emulate pp_entertry() here */
1263 {
c09156bb 1264 register PERL_CONTEXT *cx;
54310121 1265 I32 gimme = GIMME_V;
4633a7c4
LW
1266
1267 ENTER;
1268 SAVETMPS;
1269
533c011a 1270 push_return(PL_op->op_next);
3280af22 1271 PUSHBLOCK(cx, CXt_EVAL, PL_stack_sp);
4633a7c4 1272 PUSHEVAL(cx, 0, 0);
533c011a 1273 PL_eval_root = PL_op; /* Only needed so that goto works right. */
4633a7c4 1274
3280af22 1275 PL_in_eval = 1;
4633a7c4 1276 if (flags & G_KEEPERR)
3280af22 1277 PL_in_eval |= 4;
4633a7c4 1278 else
38a03e6e 1279 sv_setpv(ERRSV,"");
4633a7c4 1280 }
3280af22 1281 PL_markstack_ptr++;
a0d0e21e 1282
6224f72b
GS
1283 JMPENV_PUSH(ret);
1284 switch (ret) {
1285 case 0:
a0d0e21e 1286 break;
6224f72b 1287 case 1:
f86702cc 1288 STATUS_ALL_FAILURE;
a0d0e21e 1289 /* FALL THROUGH */
6224f72b 1290 case 2:
a0d0e21e 1291 /* my_exit() was called */
3280af22 1292 PL_curstash = PL_defstash;
a0d0e21e 1293 FREETMPS;
54310121 1294 JMPENV_POP;
3280af22 1295 if (PL_statusvalue)
a0d0e21e 1296 croak("Callback called exit");
f86702cc 1297 my_exit_jump();
a0d0e21e 1298 /* NOTREACHED */
6224f72b 1299 case 3:
3280af22 1300 if (PL_restartop) {
533c011a 1301 PL_op = PL_restartop;
3280af22 1302 PL_restartop = 0;
54310121 1303 break;
a0d0e21e 1304 }
3280af22 1305 PL_stack_sp = PL_stack_base + oldmark;
a0d0e21e
LW
1306 if (flags & G_ARRAY)
1307 retval = 0;
1308 else {
1309 retval = 1;
3280af22 1310 *++PL_stack_sp = &PL_sv_undef;
a0d0e21e
LW
1311 }
1312 goto cleanup;
1313 }
1314 }
1e422769 1315 else
54310121 1316 CATCH_SET(TRUE);
a0d0e21e 1317
533c011a
NIS
1318 if (PL_op == (OP*)&myop)
1319 PL_op = pp_entersub(ARGS);
1320 if (PL_op)
76e3520e 1321 CALLRUNOPS();
3280af22 1322 retval = PL_stack_sp - (PL_stack_base + oldmark);
4633a7c4 1323 if ((flags & G_EVAL) && !(flags & G_KEEPERR))
38a03e6e 1324 sv_setpv(ERRSV,"");
a0d0e21e
LW
1325
1326 cleanup:
1327 if (flags & G_EVAL) {
3280af22 1328 if (PL_scopestack_ix > oldscope) {
a0a2876f
LW
1329 SV **newsp;
1330 PMOP *newpm;
1331 I32 gimme;
c09156bb 1332 register PERL_CONTEXT *cx;
a0a2876f
LW
1333 I32 optype;
1334
1335 POPBLOCK(cx,newpm);
1336 POPEVAL(cx);
1337 pop_return();
3280af22 1338 PL_curpm = newpm;
a0a2876f 1339 LEAVE;
a0d0e21e 1340 }
54310121 1341 JMPENV_POP;
a0d0e21e 1342 }
1e422769 1343 else
54310121 1344 CATCH_SET(oldcatch);
1e422769 1345
a0d0e21e 1346 if (flags & G_DISCARD) {
3280af22 1347 PL_stack_sp = PL_stack_base + oldmark;
a0d0e21e
LW
1348 retval = 0;
1349 FREETMPS;
1350 LEAVE;
1351 }
533c011a 1352 PL_op = oldop;
a0d0e21e
LW
1353 return retval;
1354}
1355
6e72f9df 1356/* Eval a string. The G_EVAL flag is always assumed. */
8990e307 1357
a0d0e21e 1358I32
8ac85365
NIS
1359perl_eval_sv(SV *sv, I32 flags)
1360
1361 /* See G_* flags in cop.h */
a0d0e21e 1362{
924508f0 1363 dSP;
a0d0e21e 1364 UNOP myop; /* fake syntax tree node */
3280af22 1365 I32 oldmark = SP - PL_stack_base;
4633a7c4 1366 I32 retval;
4633a7c4 1367 I32 oldscope;
54310121 1368 dJMPENV;
6224f72b 1369 int ret;
533c011a 1370 OP* oldop = PL_op;
84902520 1371
4633a7c4
LW
1372 if (flags & G_DISCARD) {
1373 ENTER;
1374 SAVETMPS;
1375 }
1376
462e5cf6 1377 SAVEOP();
533c011a
NIS
1378 PL_op = (OP*)&myop;
1379 Zero(PL_op, 1, UNOP);
3280af22
NIS
1380 EXTEND(PL_stack_sp, 1);
1381 *++PL_stack_sp = sv;
1382 oldscope = PL_scopestack_ix;
79072805 1383
4633a7c4
LW
1384 if (!(flags & G_NOARGS))
1385 myop.op_flags = OPf_STACKED;
79072805 1386 myop.op_next = Nullop;
6e72f9df 1387 myop.op_type = OP_ENTEREVAL;
54310121
PP
1388 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1389 (flags & G_ARRAY) ? OPf_WANT_LIST :
1390 OPf_WANT_SCALAR);
6e72f9df
PP
1391 if (flags & G_KEEPERR)
1392 myop.op_flags |= OPf_SPECIAL;
4633a7c4 1393
6224f72b
GS
1394 JMPENV_PUSH(ret);
1395 switch (ret) {
1396 case 0:
4633a7c4 1397 break;
6224f72b 1398 case 1:
f86702cc 1399 STATUS_ALL_FAILURE;
4633a7c4 1400 /* FALL THROUGH */
6224f72b 1401 case 2:
4633a7c4 1402 /* my_exit() was called */
3280af22 1403 PL_curstash = PL_defstash;
4633a7c4 1404 FREETMPS;
54310121 1405 JMPENV_POP;
3280af22 1406 if (PL_statusvalue)
4633a7c4 1407 croak("Callback called exit");
f86702cc 1408 my_exit_jump();
4633a7c4 1409 /* NOTREACHED */
6224f72b 1410 case 3:
3280af22 1411 if (PL_restartop) {
533c011a 1412 PL_op = PL_restartop;
3280af22 1413 PL_restartop = 0;
54310121 1414 break;
4633a7c4 1415 }
3280af22 1416 PL_stack_sp = PL_stack_base + oldmark;
4633a7c4
LW
1417 if (flags & G_ARRAY)
1418 retval = 0;
1419 else {
1420 retval = 1;
3280af22 1421 *++PL_stack_sp = &PL_sv_undef;
4633a7c4
LW
1422 }
1423 goto cleanup;
1424 }
1425
533c011a
NIS
1426 if (PL_op == (OP*)&myop)
1427 PL_op = pp_entereval(ARGS);
1428 if (PL_op)
76e3520e 1429 CALLRUNOPS();
3280af22 1430 retval = PL_stack_sp - (PL_stack_base + oldmark);
6e72f9df 1431 if (!(flags & G_KEEPERR))
38a03e6e 1432 sv_setpv(ERRSV,"");
4633a7c4
LW
1433
1434 cleanup:
54310121 1435 JMPENV_POP;
4633a7c4 1436 if (flags & G_DISCARD) {
3280af22 1437 PL_stack_sp = PL_stack_base + oldmark;
4633a7c4
LW
1438 retval = 0;
1439 FREETMPS;
1440 LEAVE;
1441 }
533c011a 1442 PL_op = oldop;
4633a7c4
LW
1443 return retval;
1444}
1445
137443ea 1446SV*
08105a92 1447perl_eval_pv(const char *p, I32 croak_on_error)
137443ea
PP
1448{
1449 dSP;
1450 SV* sv = newSVpv(p, 0);
1451
924508f0 1452 PUSHMARK(SP);
137443ea
PP
1453 perl_eval_sv(sv, G_SCALAR);
1454 SvREFCNT_dec(sv);
1455
1456 SPAGAIN;
1457 sv = POPs;
1458 PUTBACK;
1459
2d8e6c8d
GS
1460 if (croak_on_error && SvTRUE(ERRSV)) {
1461 STRLEN n_a;
1462 croak(SvPVx(ERRSV, n_a));
1463 }
137443ea
PP
1464
1465 return sv;
1466}
1467
4633a7c4
LW
1468/* Require a module. */
1469
1470void
08105a92 1471perl_require_pv(const char *pv)
4633a7c4 1472{
d3acc0f7
JP
1473 SV* sv;
1474 dSP;
e788e7d3 1475 PUSHSTACKi(PERLSI_REQUIRE);
d3acc0f7
JP
1476 PUTBACK;
1477 sv = sv_newmortal();
4633a7c4
LW
1478 sv_setpv(sv, "require '");
1479 sv_catpv(sv, pv);
1480 sv_catpv(sv, "'");
1481 perl_eval_sv(sv, G_DISCARD);
d3acc0f7
JP
1482 SPAGAIN;
1483 POPSTACK;
79072805
LW
1484}
1485
79072805 1486void
8ac85365 1487magicname(char *sym, char *name, I32 namlen)
79072805
LW
1488{
1489 register GV *gv;
1490
85e6fe83 1491 if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
79072805
LW
1492 sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
1493}
1494
76e3520e 1495STATIC void
8ac85365
NIS
1496usage(char *name) /* XXX move this out into a module ? */
1497
4633a7c4 1498{
ab821d7f
PP
1499 /* This message really ought to be max 23 lines.
1500 * Removed -h because the user already knows that opton. Others? */
fb73857a 1501
76e3520e 1502 static char *usage_msg[] = {
fb73857a
PP
1503"-0[octal] specify record separator (\\0, if no argument)",
1504"-a autosplit mode with -n or -p (splits $_ into @F)",
1505"-c check syntax only (runs BEGIN and END blocks)",
1506"-d[:debugger] run scripts under debugger",
1507"-D[number/list] set debugging flags (argument is a bit mask or flags)",
1508"-e 'command' one line of script. Several -e's allowed. Omit [programfile].",
1509"-F/pattern/ split() pattern for autosplit (-a). The //'s are optional.",
1510"-i[extension] edit <> files in place (make backup if extension supplied)",
1511"-Idirectory specify @INC/#include directory (may be used more than once)",
1512"-l[octal] enable line ending processing, specifies line terminator",
1513"-[mM][-]module.. executes `use/no module...' before executing your script.",
1514"-n assume 'while (<>) { ... }' loop around your script",
1515"-p assume loop like -n but print line also like sed",
1516"-P run script through C preprocessor before compilation",
1517"-s enable some switch parsing for switches after script name",
1518"-S look for the script using PATH environment variable",
1519"-T turn on tainting checks",
1520"-u dump core after parsing script",
1521"-U allow unsafe operations",
95103687 1522"-v print version number, patchlevel plus VERY IMPORTANT perl info",
fb73857a
PP
1523"-V[:variable] print perl configuration information",
1524"-w TURN WARNINGS ON FOR COMPILATION OF YOUR SCRIPT. Recommended.",
1525"-x[directory] strip off text before #!perl line and perhaps cd to directory",
1526"\n",
1527NULL
1528};
76e3520e 1529 char **p = usage_msg;
fb73857a 1530
ab821d7f 1531 printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
fb73857a
PP
1532 while (*p)
1533 printf("\n %s", *p++);
4633a7c4
LW
1534}
1535
79072805
LW
1536/* This routine handles any switches that can be given during run */
1537
1538char *
8ac85365 1539moreswitches(char *s)
79072805
LW
1540{
1541 I32 numlen;
c07a80fd 1542 U32 rschar;
79072805
LW
1543
1544 switch (*s) {
1545 case '0':
a863c7d1
MB
1546 {
1547 dTHR;
c07a80fd 1548 rschar = scan_oct(s, 4, &numlen);
3280af22 1549 SvREFCNT_dec(PL_nrs);
c07a80fd 1550 if (rschar & ~((U8)~0))
3280af22 1551 PL_nrs = &PL_sv_undef;
c07a80fd 1552 else if (!rschar && numlen >= 2)
3280af22 1553 PL_nrs = newSVpv("", 0);
c07a80fd
PP
1554 else {
1555 char ch = rschar;
3280af22 1556 PL_nrs = newSVpv(&ch, 1);
79072805
LW
1557 }
1558 return s + numlen;
a863c7d1 1559 }
2304df62 1560 case 'F':
3280af22
NIS
1561 PL_minus_F = TRUE;
1562 PL_splitstr = savepv(s + 1);
2304df62
AD
1563 s += strlen(s);
1564 return s;
79072805 1565 case 'a':
3280af22 1566 PL_minus_a = TRUE;
79072805
LW
1567 s++;
1568 return s;
1569 case 'c':
3280af22 1570 PL_minus_c = TRUE;
79072805
LW
1571 s++;
1572 return s;
1573 case 'd':
bbce6d69 1574 forbid_setid("-d");
4633a7c4 1575 s++;
c07a80fd 1576 if (*s == ':' || *s == '=') {
46fc3d4c 1577 my_setenv("PERL5DB", form("use Devel::%s;", ++s));
4633a7c4 1578 s += strlen(s);
4633a7c4 1579 }
3280af22
NIS
1580 if (!PL_perldb) {
1581 PL_perldb = PERLDB_ALL;
a0d0e21e
LW
1582 init_debugger();
1583 }
79072805
LW
1584 return s;
1585 case 'D':
1586#ifdef DEBUGGING
bbce6d69 1587 forbid_setid("-D");
79072805 1588 if (isALPHA(s[1])) {
8b73bbec 1589 static char debopts[] = "psltocPmfrxuLHXDS";
79072805
LW
1590 char *d;
1591
93a17b20 1592 for (s++; *s && (d = strchr(debopts,*s)); s++)
3280af22 1593 PL_debug |= 1 << (d - debopts);
79072805
LW
1594 }
1595 else {
3280af22 1596 PL_debug = atoi(s+1);
79072805
LW
1597 for (s++; isDIGIT(*s); s++) ;
1598 }
3280af22 1599 PL_debug |= 0x80000000;
79072805
LW
1600#else
1601 warn("Recompile perl with -DDEBUGGING to use -D switch\n");
a0d0e21e 1602 for (s++; isALNUM(*s); s++) ;
79072805
LW
1603#endif
1604 /*SUPPRESS 530*/
1605 return s;
4633a7c4 1606 case 'h':
3280af22 1607 usage(PL_origargv[0]);
6ad3d225 1608 PerlProc_exit(0);
79072805 1609 case 'i':
3280af22
NIS
1610 if (PL_inplace)
1611 Safefree(PL_inplace);
1612 PL_inplace = savepv(s+1);
79072805 1613 /*SUPPRESS 530*/
3280af22 1614 for (s = PL_inplace; *s && !isSPACE(*s); s++) ;
7b8d334a 1615 if (*s) {
fb73857a 1616 *s++ = '\0';
7b8d334a
GS
1617 if (*s == '-') /* Additional switches on #! line. */
1618 s++;
1619 }
fb73857a
PP
1620 return s;
1621 case 'I': /* -I handled both here and in parse_perl() */
bbce6d69 1622 forbid_setid("-I");
fb73857a
PP
1623 ++s;
1624 while (*s && isSPACE(*s))
1625 ++s;
1626 if (*s) {
774d564b 1627 char *e, *p;
748a9306 1628 for (e = s; *e && !isSPACE(*e); e++) ;
774d564b
PP
1629 p = savepvn(s, e-s);
1630 incpush(p, TRUE);
1631 Safefree(p);
fb73857a 1632 s = e;
79072805
LW
1633 }
1634 else
463ee0b2 1635 croak("No space allowed after -I");
fb73857a 1636 return s;
79072805 1637 case 'l':
3280af22 1638 PL_minus_l = TRUE;
79072805 1639 s++;
3280af22
NIS
1640 if (PL_ors)
1641 Safefree(PL_ors);
79072805 1642 if (isDIGIT(*s)) {
3280af22
NIS
1643 PL_ors = savepv("\n");
1644 PL_orslen = 1;
1645 *PL_ors = scan_oct(s, 3 + (*s == '0'), &numlen);
79072805
LW
1646 s += numlen;
1647 }
1648 else {
a863c7d1 1649 dTHR;
3280af22
NIS
1650 if (RsPARA(PL_nrs)) {
1651 PL_ors = "\n\n";
1652 PL_orslen = 2;
c07a80fd
PP
1653 }
1654 else
3280af22
NIS
1655 PL_ors = SvPV(PL_nrs, PL_orslen);
1656 PL_ors = savepvn(PL_ors, PL_orslen);
79072805
LW
1657 }
1658 return s;
1a30305b 1659 case 'M':
bbce6d69 1660 forbid_setid("-M"); /* XXX ? */
1a30305b
PP
1661 /* FALL THROUGH */
1662 case 'm':
bbce6d69 1663 forbid_setid("-m"); /* XXX ? */
1a30305b 1664 if (*++s) {
a5f75d66 1665 char *start;
11343788 1666 SV *sv;
a5f75d66
AD
1667 char *use = "use ";
1668 /* -M-foo == 'no foo' */
1669 if (*s == '-') { use = "no "; ++s; }
11343788 1670 sv = newSVpv(use,0);
a5f75d66 1671 start = s;
1a30305b 1672 /* We allow -M'Module qw(Foo Bar)' */
c07a80fd
PP
1673 while(isALNUM(*s) || *s==':') ++s;
1674 if (*s != '=') {
11343788 1675 sv_catpv(sv, start);
c07a80fd
PP
1676 if (*(start-1) == 'm') {
1677 if (*s != '\0')
1678 croak("Can't use '%c' after -mname", *s);
11343788 1679 sv_catpv( sv, " ()");
c07a80fd
PP
1680 }
1681 } else {
11343788
MB
1682 sv_catpvn(sv, start, s-start);
1683 sv_catpv(sv, " split(/,/,q{");
1684 sv_catpv(sv, ++s);
1685 sv_catpv(sv, "})");
c07a80fd 1686 }
1a30305b 1687 s += strlen(s);
3280af22
NIS
1688 if (PL_preambleav == NULL)
1689 PL_preambleav = newAV();
1690 av_push(PL_preambleav, sv);
1a30305b
PP
1691 }
1692 else
1693 croak("No space allowed after -%c", *(s-1));
1694 return s;
79072805 1695 case 'n':
3280af22 1696 PL_minus_n = TRUE;
79072805
LW
1697 s++;
1698 return s;
1699 case 'p':
3280af22 1700 PL_minus_p = TRUE;
79072805
LW
1701 s++;
1702 return s;
1703 case 's':
bbce6d69 1704 forbid_setid("-s");
3280af22 1705 PL_doswitches = TRUE;
79072805
LW
1706 s++;
1707 return s;
463ee0b2 1708 case 'T':
3280af22 1709 if (!PL_tainting)
9607fc9c 1710 croak("Too late for \"-T\" option");
463ee0b2
LW
1711 s++;
1712 return s;
79072805 1713 case 'u':
3280af22 1714 PL_do_undump = TRUE;
79072805
LW
1715 s++;
1716 return s;
1717 case 'U':
3280af22 1718 PL_unsafe = TRUE;
79072805
LW
1719 s++;
1720 return s;
1721 case 'v':
a5f75d66 1722#if defined(SUBVERSION) && SUBVERSION > 0
fb73857a
PP
1723 printf("\nThis is perl, version 5.%03d_%02d built for %s",
1724 PATCHLEVEL, SUBVERSION, ARCHNAME);
a5f75d66 1725#else
fb73857a 1726 printf("\nThis is perl, version %s built for %s",
6b88bc9c 1727 PL_patchlevel, ARCHNAME);
fb73857a
PP
1728#endif
1729#if defined(LOCAL_PATCH_COUNT)
1730 if (LOCAL_PATCH_COUNT > 0)
1731 printf("\n(with %d registered patch%s, see perl -V for more detail)",
1732 LOCAL_PATCH_COUNT, (LOCAL_PATCH_COUNT!=1) ? "es" : "");
a5f75d66 1733#endif
1a30305b 1734
a411490c 1735 printf("\n\nCopyright 1987-1998, Larry Wall\n");
79072805 1736#ifdef MSDOS
fb73857a 1737 printf("\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
55497cff
PP
1738#endif
1739#ifdef DJGPP
1740 printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
9731c6ca 1741 printf("djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1998\n");
4633a7c4 1742#endif
79072805 1743#ifdef OS2
5dd60ef7 1744 printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
a411490c 1745 "Version 5 port Copyright (c) 1994-1998, Andreas Kaiser, Ilya Zakharevich\n");
79072805 1746#endif
79072805 1747#ifdef atarist
760ac839 1748 printf("atariST series port, ++jrb bammi@cadence.com\n");
79072805 1749#endif
a3f9223b
GS
1750#ifdef __BEOS__
1751 printf("BeOS port Copyright Tom Spindler, 1997-1998\n");
1752#endif
1d84e8df
JH
1753#ifdef MPE
1754 printf("MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-1998\n");
1755#endif
9d116dd7
JH
1756#ifdef OEMVS
1757 printf("MVS (OS390) port by Mortice Kern Systems, 1997-1998\n");
1758#endif
495c5fdc
GP
1759#ifdef __VOS__
1760 printf("Stratus VOS port by Paul_Green@stratus.com, 1997-1998\n");
1761#endif
092bebab
JH
1762#ifdef __OPEN_VM
1763 printf("VM/ESA port by Neale Ferguson, 1998\n");
1764#endif
a1a0e61e
TD
1765#ifdef POSIX_BC
1766 printf("BS2000 (POSIX) port by Start Amadeus GmbH, 1998\n");
1767#endif
61ae2fbf
JH
1768#ifdef __MINT__
1769 printf("MiNT port by Guido Flohr, 1997\n");
1770#endif
baed7233
DL
1771#ifdef BINARY_BUILD_NOTICE
1772 BINARY_BUILD_NOTICE;
1773#endif
760ac839 1774 printf("\n\
79072805 1775Perl may be copied only under the terms of either the Artistic License or the\n\
95103687
GS
1776GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n\
1777Complete documentation for Perl, including FAQ lists, should be found on\n\
1778this system using `man perl' or `perldoc perl'. If you have access to the\n\
1779Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n");
6ad3d225 1780 PerlProc_exit(0);
79072805 1781 case 'w':
599cee73
PM
1782 if (! (PL_dowarn & G_WARN_ALL_MASK))
1783 PL_dowarn |= G_WARN_ON;
1784 s++;
1785 return s;
1786 case 'W':
1787 PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
e24b16f9 1788 PL_compiling.cop_warnings = WARN_ALL ;
599cee73
PM
1789 s++;
1790 return s;
1791 case 'X':
1792 PL_dowarn = G_WARN_ALL_OFF;
e24b16f9 1793 PL_compiling.cop_warnings = WARN_NONE ;
79072805
LW
1794 s++;
1795 return s;
a0d0e21e 1796 case '*':
79072805
LW
1797 case ' ':
1798 if (s[1] == '-') /* Additional switches on #! line. */
1799 return s+2;
1800 break;
a0d0e21e 1801 case '-':
79072805 1802 case 0:
51882d45 1803#if defined(WIN32) || !defined(PERL_STRICT_CR)
a868473f
NIS
1804 case '\r':
1805#endif
79072805
LW
1806 case '\n':
1807 case '\t':
1808 break;
aa689395
PP
1809#ifdef ALTERNATE_SHEBANG
1810 case 'S': /* OS/2 needs -S on "extproc" line. */
1811 break;
1812#endif
a0d0e21e 1813 case 'P':
3280af22 1814 if (PL_preprocess)
a0d0e21e
LW
1815 return s+1;
1816 /* FALL THROUGH */
79072805 1817 default:
a0d0e21e 1818 croak("Can't emulate -%.1s on #! line",s);
79072805
LW
1819 }
1820 return Nullch;
1821}
1822
1823/* compliments of Tom Christiansen */
1824
1825/* unexec() can be found in the Gnu emacs distribution */
ee580363 1826/* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
79072805
LW
1827
1828void
8ac85365 1829my_unexec(void)
79072805
LW
1830{
1831#ifdef UNEXEC
46fc3d4c
PP
1832 SV* prog;
1833 SV* file;
ee580363 1834 int status = 1;
79072805
LW
1835 extern int etext;
1836
ee580363 1837 prog = newSVpv(BIN_EXP, 0);
46fc3d4c 1838 sv_catpv(prog, "/perl");
6b88bc9c 1839 file = newSVpv(PL_origfilename, 0);
46fc3d4c 1840 sv_catpv(file, ".perldump");
79072805 1841
ee580363
GS
1842 unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
1843 /* unexec prints msg to stderr in case of failure */
6ad3d225 1844 PerlProc_exit(status);
79072805 1845#else
a5f75d66
AD
1846# ifdef VMS
1847# include <lib$routines.h>
1848 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
aa689395 1849# else
79072805 1850 ABORT(); /* for use with undump */
aa689395 1851# endif
a5f75d66 1852#endif
79072805
LW
1853}
1854
cb68f92d
GS
1855/* initialize curinterp */
1856STATIC void
1857init_interp(void)
1858{
1859
066ef5b5 1860#ifdef PERL_OBJECT /* XXX kludge */
cb68f92d 1861#define I_REINIT \
6b88bc9c
GS
1862 STMT_START { \
1863 PL_chopset = " \n-"; \
1864 PL_copline = NOLINE; \
1865 PL_curcop = &PL_compiling;\
1866 PL_curcopdb = NULL; \
1867 PL_dbargs = 0; \
1868 PL_dlmax = 128; \
3967c732 1869 PL_dumpindent = 4; \
6b88bc9c
GS
1870 PL_laststatval = -1; \
1871 PL_laststype = OP_STAT; \
1872 PL_maxscream = -1; \
1873 PL_maxsysfd = MAXSYSFD; \
1874 PL_statname = Nullsv; \
1875 PL_tmps_floor = -1; \
1876 PL_tmps_ix = -1; \
1877 PL_op_mask = NULL; \
1878 PL_dlmax = 128; \
1879 PL_laststatval = -1; \
1880 PL_laststype = OP_STAT; \
1881 PL_mess_sv = Nullsv; \
1882 PL_splitstr = " "; \
1883 PL_generation = 100; \
1884 PL_exitlist = NULL; \
1885 PL_exitlistlen = 0; \
1886 PL_regindent = 0; \
1887 PL_in_clean_objs = FALSE; \
1888 PL_in_clean_all = FALSE; \
1889 PL_profiledata = NULL; \
1890 PL_rsfp = Nullfp; \
1891 PL_rsfp_filters = Nullav; \
24d3c518 1892 PL_dirty = FALSE; \
cb68f92d 1893 } STMT_END
9666903d 1894 I_REINIT;
066ef5b5
GS
1895#else
1896# ifdef MULTIPLICITY
1897# define PERLVAR(var,type)
8f872242
NIS
1898# define PERLVARI(var,type,init) PL_curinterp->var = init;
1899# define PERLVARIC(var,type,init) PL_curinterp->var = init;
066ef5b5
GS
1900# include "intrpvar.h"
1901# ifndef USE_THREADS
1902# include "thrdvar.h"
1903# endif
1904# undef PERLVAR
1905# undef PERLVARI
1906# undef PERLVARIC
3967c732 1907# else
066ef5b5 1908# define PERLVAR(var,type)
533c011a
NIS
1909# define PERLVARI(var,type,init) PL_##var = init;
1910# define PERLVARIC(var,type,init) PL_##var = init;
066ef5b5
GS
1911# include "intrpvar.h"
1912# ifndef USE_THREADS
1913# include "thrdvar.h"
1914# endif
1915# undef PERLVAR
1916# undef PERLVARI
1917# undef PERLVARIC
1918# endif
cb68f92d
GS
1919#endif
1920
cb68f92d
GS
1921}
1922
76e3520e 1923STATIC void
8ac85365 1924init_main_stash(void)
79072805 1925{
11343788 1926 dTHR;
463ee0b2 1927 GV *gv;
6e72f9df
PP
1928
1929 /* Note that strtab is a rather special HV. Assumptions are made
1930 about not iterating on it, and not adding tie magic to it.
1931 It is properly deallocated in perl_destruct() */
3280af22 1932 PL_strtab = newHV();
5f08fbcd
GS
1933#ifdef USE_THREADS
1934 MUTEX_INIT(&PL_strtab_mutex);
1935#endif
3280af22
NIS
1936 HvSHAREKEYS_off(PL_strtab); /* mandatory */
1937 hv_ksplit(PL_strtab, 512);
6e72f9df 1938
3280af22
NIS
1939 PL_curstash = PL_defstash = newHV();
1940 PL_curstname = newSVpv("main",4);
adbc6bb1
LW
1941 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
1942 SvREFCNT_dec(GvHV(gv));
3280af22 1943 GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash);
463ee0b2 1944 SvREADONLY_on(gv);
3280af22
NIS
1945 HvNAME(PL_defstash) = savepv("main");
1946 PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
1947 GvMULTI_on(PL_incgv);
1948 PL_hintgv = gv_fetchpv("\010",TRUE, SVt_PV); /* ^H */
1949 GvMULTI_on(PL_hintgv);
1950 PL_defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
1951 PL_errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
1952 GvMULTI_on(PL_errgv);
1953 PL_replgv = gv_fetchpv("\022", TRUE, SVt_PV); /* ^R */
1954 GvMULTI_on(PL_replgv);
84902520 1955 (void)form("%240s",""); /* Preallocate temp - for immediate signals. */
38a03e6e
MB
1956 sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
1957 sv_setpvn(ERRSV, "", 0);
3280af22
NIS
1958 PL_curstash = PL_defstash;
1959 PL_compiling.cop_stash = PL_defstash;
1960 PL_debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
1961 PL_globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
4633a7c4 1962 /* We must init $/ before switches are processed. */
9d14cc18 1963 sv_setpvn(perl_get_sv("/", TRUE), "\n", 1);
79072805
LW
1964}
1965
76e3520e 1966STATIC void
01f988be 1967open_script(char *scriptname, bool dosearch, SV *sv, int *fdscript)
79072805 1968{
0f15f207 1969 dTHR;
79072805 1970 register char *s;
2a92aaa0 1971
6c4ab083 1972 *fdscript = -1;
79072805 1973
3280af22
NIS
1974 if (PL_e_script) {
1975 PL_origfilename = savepv("-e");
96436eeb 1976 }
6c4ab083
GS
1977 else {
1978 /* if find_script() returns, it returns a malloc()-ed value */
3280af22 1979 PL_origfilename = scriptname = find_script(scriptname, dosearch, NULL, 1);
6c4ab083
GS
1980
1981 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
1982 char *s = scriptname + 8;
1983 *fdscript = atoi(s);
1984 while (isDIGIT(*s))
1985 s++;
1986 if (*s) {
1987 scriptname = savepv(s + 1);
3280af22
NIS
1988 Safefree(PL_origfilename);
1989 PL_origfilename = scriptname;
6c4ab083
GS
1990 }
1991 }
1992 }
1993
3280af22
NIS
1994 PL_curcop->cop_filegv = gv_fetchfile(PL_origfilename);
1995 if (strEQ(PL_origfilename,"-"))
79072805 1996 scriptname = "";
01f988be 1997 if (*fdscript >= 0) {
3280af22 1998 PL_rsfp = PerlIO_fdopen(*fdscript,PERL_SCRIPT_MODE);
96436eeb 1999#if defined(HAS_FCNTL) && defined(F_SETFD)
3280af22
NIS
2000 if (PL_rsfp)
2001 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1); /* ensure close-on-exec */
96436eeb
PP
2002#endif
2003 }
3280af22 2004 else if (PL_preprocess) {
46fc3d4c 2005 char *cpp_cfg = CPPSTDIN;
63bfd3db 2006 SV *cpp = newSVpv("",0);
46fc3d4c
PP
2007 SV *cmd = NEWSV(0,0);
2008
2009 if (strEQ(cpp_cfg, "cppstdin"))
2010 sv_catpvf(cpp, "%s/", BIN_EXP);
2011 sv_catpv(cpp, cpp_cfg);
79072805 2012
79072805 2013 sv_catpv(sv,"-I");
fed7345c 2014 sv_catpv(sv,PRIVLIB_EXP);
46fc3d4c 2015
79072805 2016#ifdef MSDOS
46fc3d4c 2017 sv_setpvf(cmd, "\
79072805
LW
2018sed %s -e \"/^[^#]/b\" \
2019 -e \"/^#[ ]*include[ ]/b\" \
2020 -e \"/^#[ ]*define[ ]/b\" \
2021 -e \"/^#[ ]*if[ ]/b\" \
2022 -e \"/^#[ ]*ifdef[ ]/b\" \
2023 -e \"/^#[ ]*ifndef[ ]/b\" \
2024 -e \"/^#[ ]*else/b\" \
2025 -e \"/^#[ ]*elif[ ]/b\" \
2026 -e \"/^#[ ]*undef[ ]/b\" \
2027 -e \"/^#[ ]*endif/b\" \
2028 -e \"s/^#.*//\" \
fc36a67e 2029 %s | %_ -C %_ %s",
6b88bc9c 2030 (PL_doextract ? "-e \"1,/^#/d\n\"" : ""),
79072805 2031#else
092bebab
JH
2032# ifdef __OPEN_VM
2033 sv_setpvf(cmd, "\
2034%s %s -e '/^[^#]/b' \
2035 -e '/^#[ ]*include[ ]/b' \
2036 -e '/^#[ ]*define[ ]/b' \
2037 -e '/^#[ ]*if[ ]/b' \
2038 -e '/^#[ ]*ifdef[ ]/b' \
2039 -e '/^#[ ]*ifndef[ ]/b' \
2040 -e '/^#[ ]*else/b' \
2041 -e '/^#[ ]*elif[ ]/b' \
2042 -e '/^#[ ]*undef[ ]/b' \
2043 -e '/^#[ ]*endif/b' \
2044 -e 's/^[ ]*#.*//' \
2045 %s | %_ %_ %s",
2046# else
46fc3d4c 2047 sv_setpvf(cmd, "\
79072805
LW
2048%s %s -e '/^[^#]/b' \
2049 -e '/^#[ ]*include[ ]/b' \
2050 -e '/^#[ ]*define[ ]/b' \
2051 -e '/^#[ ]*if[ ]/b' \
2052 -e '/^#[ ]*ifdef[ ]/b' \
2053 -e '/^#[ ]*ifndef[ ]/b' \
2054 -e '/^#[ ]*else/b' \
2055 -e '/^#[ ]*elif[ ]/b' \
2056 -e '/^#[ ]*undef[ ]/b' \
2057 -e '/^#[ ]*endif/b' \
2058 -e 's/^[ ]*#.*//' \
fc36a67e 2059 %s | %_ -C %_ %s",
092bebab 2060# endif
79072805
LW
2061#ifdef LOC_SED
2062 LOC_SED,
2063#else
2064 "sed",
2065#endif
3280af22 2066 (PL_doextract ? "-e '1,/^#/d\n'" : ""),
79072805 2067#endif
46fc3d4c 2068 scriptname, cpp, sv, CPPMINUS);
3280af22 2069 PL_doextract = FALSE;
79072805 2070#ifdef IAMSUID /* actually, this is caught earlier */
b28d0864 2071 if (PL_euid != PL_uid && !PL_euid) { /* if running suidperl */
79072805 2072#ifdef HAS_SETEUID
b28d0864 2073 (void)seteuid(PL_uid); /* musn't stay setuid root */
79072805
LW
2074#else
2075#ifdef HAS_SETREUID
b28d0864 2076 (void)setreuid((Uid_t)-1, PL_uid);
85e6fe83
LW
2077#else
2078#ifdef HAS_SETRESUID
b28d0864 2079 (void)setresuid((Uid_t)-1, PL_uid, (Uid_t)-1);
79072805 2080#else
b28d0864 2081 PerlProc_setuid(PL_uid);
79072805
LW
2082#endif
2083#endif
85e6fe83 2084#endif
b28d0864 2085 if (PerlProc_geteuid() != PL_uid)
463ee0b2 2086 croak("Can't do seteuid!\n");
79072805
LW
2087 }
2088#endif /* IAMSUID */
3280af22 2089 PL_rsfp = PerlProc_popen(SvPVX(cmd), "r");
46fc3d4c
PP
2090 SvREFCNT_dec(cmd);
2091 SvREFCNT_dec(cpp);
79072805
LW
2092 }
2093 else if (!*scriptname) {
bbce6d69 2094 forbid_setid("program input from stdin");
3280af22 2095 PL_rsfp = PerlIO_stdin();
79072805 2096 }
96436eeb 2097 else {
3280af22 2098 PL_rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
96436eeb 2099#if defined(HAS_FCNTL) && defined(F_SETFD)
3280af22
NIS
2100 if (PL_rsfp)
2101 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1); /* ensure close-on-exec */
96436eeb
PP
2102#endif
2103 }
3280af22 2104 if (!PL_rsfp) {
13281fa4 2105#ifdef DOSUID
a687059c 2106#ifndef IAMSUID /* in case script is not readable before setuid */
6b88bc9c
GS
2107 if (PL_euid &&
2108 PerlLIO_stat(SvPVX(GvSV(PL_curcop->cop_filegv)),&PL_statbuf) >= 0 &&
2109 PL_statbuf.st_mode & (S_ISUID|S_ISGID))
2110 {
46fc3d4c 2111 /* try again */
6b88bc9c 2112 PerlProc_execv(form("%s/sperl%s", BIN_EXP, PL_patchlevel), PL_origargv);
463ee0b2 2113 croak("Can't do setuid\n");
13281fa4
LW
2114 }
2115#endif
2116#endif
463ee0b2 2117 croak("Can't open perl script \"%s\": %s\n",
3280af22 2118 SvPVX(GvSV(PL_curcop->cop_filegv)), Strerror(errno));
13281fa4 2119 }
79072805 2120}
8d063cd8 2121
104d25b7
JH
2122#ifdef IAMSUID
2123static int
2124fd_on_nosuid_fs(int fd)
2125{
2126 int on_nosuid = 0;
2127 int check_okay = 0;
2128/*
2129 * Preferred order: fstatvfs(), fstatfs(), getmntent().
2130 * fstatvfs() is UNIX98.
2131 * fstatfs() is BSD.
2132 * getmntent() is O(number-of-mounted-filesystems) and can hang.
2133 */
2134
2135# ifdef HAS_FSTATVFS
2136 struct statvfs stfs;
2137 check_okay = fstatvfs(fd, &stfs) == 0;
2138 on_nosuid = check_okay && (stfs.f_flag & ST_NOSUID);
2139# else
2140# if defined(HAS_FSTATFS) && defined(HAS_STRUCT_STATFS_FLAGS)
2141 struct statfs stfs;
2142 check_okay = fstatfs(fd, &stfs) == 0;
2143# undef PERL_MOUNT_NOSUID
2144# if !defined(PERL_MOUNT_NOSUID) && defined(MNT_NOSUID)
2145# define PERL_MOUNT_NOSUID MNT_NOSUID
2146# endif
2147# if !defined(PERL_MOUNT_NOSUID) && defined(MS_NOSUID)
2148# define PERL_MOUNT_NOSUID MS_NOSUID
2149# endif
2150# if !defined(PERL_MOUNT_NOSUID) && defined(M_NOSUID)
2151# define PERL_MOUNT_NOSUID M_NOSUID
2152# endif
2153# ifdef PERL_MOUNT_NOSUID
2154 on_nosuid = check_okay && (stfs.f_flags & PERL_MOUNT_NOSUID);
2155# endif
2156# else
32b3cf08 2157# if defined(HAS_GETMNTENT) && defined(HAS_HASMNTOPT) && defined(MNTOPT_NOSUID)
104d25b7
JH
2158 FILE *mtab = fopen("/etc/mtab", "r");
2159 struct mntent *entry;
2160 struct stat stb, fsb;
2161
2162 if (mtab && (fstat(fd, &stb) == 0)) {
2163 while (entry = getmntent(mtab)) {
2164 if (stat(entry->mnt_dir, &fsb) == 0
2165 && fsb.st_dev == stb.st_dev)
2166 {
2167 /* found the filesystem */
2168 check_okay = 1;
2169 if (hasmntopt(entry, MNTOPT_NOSUID))
2170 on_nosuid = 1;
2171 break;
2172 } /* A single fs may well fail its stat(). */
2173 }
2174 }
2175 if (mtab)
2176 fclose(mtab);
2177# endif /* mntent */
2178# endif /* statfs */
2179# endif /* statvfs */
2180 if (!check_okay)
2181 croak("Can't check filesystem of script \"%s\"", PL_origfilename);
2182 return on_nosuid;
2183}
2184#endif /* IAMSUID */
2185
76e3520e 2186STATIC void
01f988be 2187validate_suid(char *validarg, char *scriptname, int fdscript)
79072805 2188{
96436eeb
PP
2189 int which;
2190
13281fa4
LW
2191 /* do we need to emulate setuid on scripts? */
2192
2193 /* This code is for those BSD systems that have setuid #! scripts disabled
2194 * in the kernel because of a security problem. Merely defining DOSUID
2195 * in perl will not fix that problem, but if you have disabled setuid
2196 * scripts in the kernel, this will attempt to emulate setuid and setgid
2197 * on scripts that have those now-otherwise-useless bits set. The setuid
27e2fb84
LW
2198 * root version must be called suidperl or sperlN.NNN. If regular perl
2199 * discovers that it has opened a setuid script, it calls suidperl with
2200 * the same argv that it had. If suidperl finds that the script it has
2201 * just opened is NOT setuid root, it sets the effective uid back to the
2202 * uid. We don't just make perl setuid root because that loses the
2203 * effective uid we had before invoking perl, if it was different from the
2204 * uid.
13281fa4
LW
2205 *
2206 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
2207 * be defined in suidperl only. suidperl must be setuid root. The
2208 * Configure script will set this up for you if you want it.
2209 */
a687059c 2210
13281fa4 2211#ifdef DOSUID
ea0efc06 2212 dTHR;
6e72f9df 2213 char *s, *s2;
a0d0e21e 2214
b28d0864 2215 if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0) /* normal stat is insecure */
6b88bc9c 2216 croak("Can't stat script \"%s\"",PL_origfilename);
b28d0864 2217 if (fdscript < 0 && PL_statbuf.st_mode & (S_ISUID|S_ISGID)) {
79072805 2218 I32 len;
2d8e6c8d 2219 STRLEN n_a;
13281fa4 2220
a687059c 2221#ifdef IAMSUID
fe14fcc3 2222#ifndef HAS_SETREUID
a687059c
LW
2223 /* On this access check to make sure the directories are readable,
2224 * there is actually a small window that the user could use to make
2225 * filename point to an accessible directory. So there is a faint
2226 * chance that someone could execute a setuid script down in a
2227 * non-accessible directory. I don't know what to do about that.
2228 * But I don't think it's too important. The manual lies when
2229 * it says access() is useful in setuid programs.
2230 */
6b88bc9c 2231 if (PerlLIO_access(SvPVX(GvSV(PL_curcop->cop_filegv)),1)) /*double check*/
463ee0b2 2232 croak("Permission denied");
a687059c
LW
2233#else
2234 /* If we can swap euid and uid, then we can determine access rights
2235 * with a simple stat of the file, and then compare device and
2236 * inode to make sure we did stat() on the same file we opened.
2237 * Then we just have to make sure he or she can execute it.
2238 */
2239 {
2240 struct stat tmpstatbuf;
2241
85e6fe83
LW
2242 if (
2243#ifdef HAS_SETREUID
b28d0864 2244 setreuid(PL_euid,PL_uid) < 0
a0d0e21e
LW
2245#else
2246# if HAS_SETRESUID
b28d0864 2247 setresuid(PL_euid,PL_uid,(Uid_t)-1) < 0
a0d0e21e 2248# endif
85e6fe83 2249#endif
b28d0864 2250 || PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid)
463ee0b2 2251 croak("Can't swap uid and euid"); /* really paranoid */
6b88bc9c 2252 if (PerlLIO_stat(SvPVX(GvSV(PL_curcop->cop_filegv)),&tmpstatbuf) < 0)
463ee0b2 2253 croak("Permission denied"); /* testing full pathname here */
2bb3463c 2254#if defined(IAMSUID) && !defined(NO_NOSUID_CHECK)
104d25b7
JH
2255 if (fd_on_nosuid_fs(PerlIO_fileno(PL_rsfp)))
2256 croak("Permission denied");
2257#endif
b28d0864
NIS
2258 if (tmpstatbuf.st_dev != PL_statbuf.st_dev ||
2259 tmpstatbuf.st_ino != PL_statbuf.st_ino) {
2260 (void)PerlIO_close(PL_rsfp);
2261 if (PL_rsfp = PerlProc_popen("/bin/mail root","w")) { /* heh, heh */
2262 PerlIO_printf(PL_rsfp,
ff0cee69
PP
2263"User %ld tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
2264(Filename of set-id script was %s, uid %ld gid %ld.)\n\nSincerely,\nperl\n",
b28d0864
NIS
2265 (long)PL_uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
2266 (long)PL_statbuf.st_dev, (long)PL_statbuf.st_ino,
6b88bc9c 2267 SvPVX(GvSV(PL_curcop->cop_filegv)),
b28d0864
NIS
2268 (long)PL_statbuf.st_uid, (long)PL_statbuf.st_gid);
2269 (void)PerlProc_pclose(PL_rsfp);
a687059c 2270 }
463ee0b2 2271 croak("Permission denied\n");
a687059c 2272 }
85e6fe83
LW
2273 if (
2274#ifdef HAS_SETREUID
b28d0864 2275 setreuid(PL_uid,PL_euid) < 0
a0d0e21e
LW
2276#else
2277# if defined(HAS_SETRESUID)
b28d0864 2278 setresuid(PL_uid,PL_euid,(Uid_t)-1) < 0
a0d0e21e 2279# endif
85e6fe83 2280#endif
b28d0864 2281 || PerlProc_getuid() != PL_uid || PerlProc_geteuid() != PL_euid)
463ee0b2 2282 croak("Can't reswap uid and euid");
b28d0864 2283 if (!cando(S_IXUSR,FALSE,&PL_statbuf)) /* can real uid exec? */
463ee0b2 2284 croak("Permission denied\n");
a687059c 2285 }
fe14fcc3 2286#endif /* HAS_SETREUID */
a687059c
LW
2287#endif /* IAMSUID */
2288
b28d0864 2289 if (!S_ISREG(PL_statbuf.st_mode))
463ee0b2 2290 croak("Permission denied");
b28d0864 2291 if (PL_statbuf.st_mode & S_IWOTH)
463ee0b2 2292 croak("Setuid/gid script is writable by world");
6b88bc9c
GS
2293 PL_doswitches = FALSE; /* -s is insecure in suid */
2294 PL_curcop->cop_line++;
2295 if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch ||
2d8e6c8d 2296 strnNE(SvPV(PL_linestr,n_a),"#!",2) ) /* required even on Sys V */
463ee0b2 2297 croak("No #! line");
2d8e6c8d 2298 s = SvPV(PL_linestr,n_a)+2;
663a0e37 2299 if (*s == ' ') s++;
45d8adaa 2300 while (!isSPACE(*s)) s++;
2d8e6c8d 2301 for (s2 = s; (s2 > SvPV(PL_linestr,n_a)+2 &&
6e72f9df
PP
2302 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
2303 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
463ee0b2 2304 croak("Not a perl script");
a687059c 2305 while (*s == ' ' || *s == '\t') s++;
13281fa4
LW
2306 /*
2307 * #! arg must be what we saw above. They can invoke it by
2308 * mentioning suidperl explicitly, but they may not add any strange
2309 * arguments beyond what #! says if they do invoke suidperl that way.
2310 */
2311 len = strlen(validarg);
2312 if (strEQ(validarg," PHOOEY ") ||
45d8adaa 2313 strnNE(s,validarg,len) || !isSPACE(s[len]))
463ee0b2 2314 croak("Args must match #! line");
a687059c
LW
2315
2316#ifndef IAMSUID
b28d0864
NIS
2317 if (PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) &&
2318 PL_euid == PL_statbuf.st_uid)
2319 if (!PL_do_undump)
463ee0b2 2320 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
a687059c
LW
2321FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2322#endif /* IAMSUID */
13281fa4 2323
b28d0864
NIS
2324 if (PL_euid) { /* oops, we're not the setuid root perl */
2325 (void)PerlIO_close(PL_rsfp);
13281fa4 2326#ifndef IAMSUID
46fc3d4c 2327 /* try again */
6b88bc9c 2328 PerlProc_execv(form("%s/sperl%s", BIN_EXP, PL_patchlevel), PL_origargv);
13281fa4 2329#endif
463ee0b2 2330 croak("Can't do setuid\n");
13281fa4
LW
2331 }
2332
b28d0864 2333 if (PL_statbuf.st_mode & S_ISGID && PL_statbuf.st_gid != PL_egid) {
fe14fcc3 2334#ifdef HAS_SETEGID
b28d0864 2335 (void)setegid(PL_statbuf.st_gid);
a687059c 2336#else
fe14fcc3 2337#ifdef HAS_SETREGID
b28d0864 2338 (void)setregid((Gid_t)-1,PL_statbuf.st_gid);
85e6fe83
LW
2339#else
2340#ifdef HAS_SETRESGID
b28d0864 2341 (void)setresgid((Gid_t)-1,PL_statbuf.st_gid,(Gid_t)-1);
a687059c 2342#else
b28d0864 2343 PerlProc_setgid(PL_statbuf.st_gid);
a687059c
LW
2344#endif
2345#endif
85e6fe83 2346#endif
b28d0864 2347 if (PerlProc_getegid() != PL_statbuf.st_gid)
463ee0b2 2348 croak("Can't do setegid!\n");
83025b21 2349 }
b28d0864
NIS
2350 if (PL_statbuf.st_mode & S_ISUID) {
2351 if (PL_statbuf.st_uid != PL_euid)
fe14fcc3 2352#ifdef HAS_SETEUID
b28d0864 2353 (void)seteuid(PL_statbuf.st_uid); /* all that for this */
a687059c 2354#else
fe14fcc3 2355#ifdef HAS_SETREUID
b28d0864 2356 (void)setreuid((Uid_t)-1,PL_statbuf.st_uid);
85e6fe83
LW
2357#else
2358#ifdef HAS_SETRESUID
b28d0864 2359 (void)setresuid((Uid_t)-1,PL_statbuf.st_uid,(Uid_t)-1);
a687059c 2360#else
b28d0864 2361 PerlProc_setuid(PL_statbuf.st_uid);
a687059c
LW
2362#endif
2363#endif
85e6fe83 2364#endif
b28d0864 2365 if (PerlProc_geteuid() != PL_statbuf.st_uid)
463ee0b2 2366 croak("Can't do seteuid!\n");
a687059c 2367 }
b28d0864 2368 else if (PL_uid) { /* oops, mustn't run as root */
fe14fcc3 2369#ifdef HAS_SETEUID
b28d0864 2370 (void)seteuid((Uid_t)PL_uid);
a687059c 2371#else
fe14fcc3 2372#ifdef HAS_SETREUID
b28d0864 2373 (void)setreuid((Uid_t)-1,(Uid_t)PL_uid);
a687059c 2374#else
85e6fe83 2375#ifdef HAS_SETRESUID
b28d0864 2376 (void)setresuid((Uid_t)-1,(Uid_t)PL_uid,(Uid_t)-1);
85e6fe83 2377#else
b28d0864 2378 PerlProc_setuid((Uid_t)PL_uid);
85e6fe83 2379#endif
a687059c
LW
2380#endif
2381#endif
b28d0864 2382 if (PerlProc_geteuid() != PL_uid)
463ee0b2 2383 croak("Can't do seteuid!\n");
83025b21 2384 }
748a9306 2385 init_ids();
b28d0864 2386 if (!cando(S_IXUSR,TRUE,&PL_statbuf))
463ee0b2 2387 croak("Permission denied\n"); /* they can't do this */
13281fa4
LW
2388 }
2389#ifdef IAMSUID
6b88bc9c 2390 else if (PL_preprocess)
463ee0b2 2391 croak("-P not allowed for setuid/setgid script\n");
96436eeb
PP
2392 else if (fdscript >= 0)
2393 croak("fd script not allowed in suidperl\n");
13281fa4 2394 else
463ee0b2 2395 croak("Script is not setuid/setgid in suidperl\n");
96436eeb
PP
2396
2397 /* We absolutely must clear out any saved ids here, so we */
2398 /* exec the real perl, substituting fd script for scriptname. */
2399 /* (We pass script name as "subdir" of fd, which perl will grok.) */
b28d0864
NIS
2400 PerlIO_rewind(PL_rsfp);
2401 PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0); /* just in case rewind didn't */
6b88bc9c
GS
2402 for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ;
2403 if (!PL_origargv[which])
96436eeb 2404 croak("Permission denied");
6b88bc9c
GS
2405 PL_origargv[which] = savepv(form("/dev/fd/%d/%s",
2406 PerlIO_fileno(PL_rsfp), PL_origargv[which]));
96436eeb 2407#if defined(HAS_FCNTL) && defined(F_SETFD)
b28d0864 2408 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0); /* ensure no close-on-exec */
96436eeb 2409#endif
6b88bc9c 2410 PerlProc_execv(form("%s/perl%s", BIN_EXP, PL_patchlevel), PL_origargv);/* try again */
96436eeb 2411 croak("Can't do setuid\n");
13281fa4 2412#endif /* IAMSUID */
a687059c 2413#else /* !DOSUID */
3280af22 2414 if (PL_euid != PL_uid || PL_egid != PL_gid) { /* (suidperl doesn't exist, in fact) */
a687059c 2415#ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
96827780 2416 dTHR;
b28d0864
NIS
2417 PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf); /* may be either wrapped or real suid */
2418 if ((PL_euid != PL_uid && PL_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
a687059c 2419 ||
b28d0864 2420 (PL_egid != PL_gid && PL_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
a687059c 2421 )
b28d0864 2422 if (!PL_do_undump)
463ee0b2 2423 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
a687059c
LW
2424FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2425#endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
2426 /* not set-id, must be wrapped */
a687059c 2427 }
13281fa4 2428#endif /* DOSUID */
79072805 2429}
13281fa4 2430
76e3520e 2431STATIC void
8ac85365 2432find_beginning(void)
79072805 2433{
6e72f9df 2434 register char *s, *s2;
33b78306
LW
2435
2436 /* skip forward in input to the real script? */
2437
bbce6d69 2438 forbid_setid("-x");
3280af22
NIS
2439 while (PL_doextract) {
2440 if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch)
463ee0b2 2441 croak("No Perl script found in input\n");
6e72f9df 2442 if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
3280af22
NIS
2443 PerlIO_ungetc(PL_rsfp, '\n'); /* to keep line count right */
2444 PL_doextract = FALSE;
6e72f9df
PP
2445 while (*s && !(isSPACE (*s) || *s == '#')) s++;
2446 s2 = s;
2447 while (*s == ' ' || *s == '\t') s++;
2448 if (*s++ == '-') {
2449 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
2450 if (strnEQ(s2-4,"perl",4))
2451 /*SUPPRESS 530*/
2452 while (s = moreswitches(s)) ;
33b78306 2453 }
3280af22
NIS
2454 if (PL_cddir && PerlDir_chdir(PL_cddir) < 0)
2455 croak("Can't chdir to %s",PL_cddir);
83025b21
LW
2456 }
2457 }
2458}
2459
afe37c7d 2460
76e3520e 2461STATIC void
8ac85365 2462init_ids(void)
352d5a3a 2463{
3280af22
NIS
2464 PL_uid = (int)PerlProc_getuid();
2465 PL_euid = (int)PerlProc_geteuid();
2466 PL_gid = (int)PerlProc_getgid();
2467 PL_egid = (int)PerlProc_getegid();
748a9306 2468#ifdef VMS
b28d0864
NIS
2469 PL_uid |= PL_gid << 16;
2470 PL_euid |= PL_egid << 16;
748a9306 2471#endif
3280af22 2472 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
748a9306 2473}
79072805 2474
76e3520e 2475STATIC void
8ac85365 2476forbid_setid(char *s)
bbce6d69 2477{
3280af22 2478 if (PL_euid != PL_uid)
bbce6d69 2479 croak("No %s allowed while running setuid", s);
3280af22 2480 if (PL_egid != PL_gid)
bbce6d69
PP
2481 croak("No %s allowed while running setgid", s);
2482}
2483
76e3520e 2484STATIC void
8ac85365 2485init_debugger(void)
748a9306 2486{
11343788 2487 dTHR;
3280af22
NIS
2488 PL_curstash = PL_debstash;
2489 PL_dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
2490 AvREAL_off(PL_dbargs);
2491 PL_DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2492 PL_DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
2493 PL_DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
2494 PL_DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
2495 sv_setiv(PL_DBsingle, 0);
2496 PL_DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
2497 sv_setiv(PL_DBtrace, 0);
2498 PL_DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
2499 sv_setiv(PL_DBsignal, 0);
2500 PL_curstash = PL_defstash;
352d5a3a
LW
2501}
2502
2ce36478
SM
2503#ifndef STRESS_REALLOC
2504#define REASONABLE(size) (size)
2505#else
2506#define REASONABLE(size) (1) /* unreasonable */
2507#endif
2508
11343788 2509void
8ac85365 2510init_stacks(ARGSproto)
79072805 2511{
e336de0d 2512 /* start with 128-item stack and 8K cxstack */
3280af22 2513 PL_curstackinfo = new_stackinfo(REASONABLE(128),
e336de0d 2514 REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
3280af22
NIS
2515 PL_curstackinfo->si_type = PERLSI_MAIN;
2516 PL_curstack = PL_curstackinfo->si_stack;
2517 PL_mainstack = PL_curstack; /* remember in case we switch stacks */
79072805 2518
3280af22
NIS
2519 PL_stack_base = AvARRAY(PL_curstack);
2520 PL_stack_sp = PL_stack_base;
2521 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
8990e307 2522
3280af22
NIS
2523 New(50,PL_tmps_stack,REASONABLE(128),SV*);
2524 PL_tmps_floor = -1;
2525 PL_tmps_ix = -1;
2526 PL_tmps_max = REASONABLE(128);
8990e307 2527
3280af22
NIS
2528 New(54,PL_markstack,REASONABLE(32),I32);
2529 PL_markstack_ptr = PL_markstack;
2530 PL_markstack_max = PL_markstack + REASONABLE(32);
79072805 2531
e336de0d
GS
2532 SET_MARKBASE;
2533
3280af22
NIS
2534 New(54,PL_scopestack,REASONABLE(32),I32);
2535 PL_scopestack_ix = 0;
2536 PL_scopestack_max = REASONABLE(32);
79072805 2537
3280af22
NIS
2538 New(54,PL_savestack,REASONABLE(128),ANY);
2539 PL_savestack_ix = 0;
2540 PL_savestack_max = REASONABLE(128);
79072805 2541
3280af22
NIS
2542 New(54,PL_retstack,REASONABLE(16),OP*);
2543 PL_retstack_ix = 0;
2544 PL_retstack_max = REASONABLE(16);
378cc40b 2545}
33b78306 2546
2ce36478
SM
2547#undef REASONABLE
2548
76e3520e 2549STATIC void
8ac85365 2550nuke_stacks(void)
6e72f9df 2551{
e858de61 2552 dTHR;
3280af22
NIS
2553 while (PL_curstackinfo->si_next)
2554 PL_curstackinfo = PL_curstackinfo->si_next;
2555 while (PL_curstackinfo) {
2556 PERL_SI *p = PL_curstackinfo->si_prev;
bac4b2ad 2557 /* curstackinfo->si_stack got nuked by sv_free_arenas() */
3280af22
NIS
2558 Safefree(PL_curstackinfo->si_cxstack);
2559 Safefree(PL_curstackinfo);
2560 PL_curstackinfo = p;
e336de0d 2561 }
3280af22
NIS
2562 Safefree(PL_tmps_stack);
2563 Safefree(PL_markstack);
2564 Safefree(PL_scopestack);
2565 Safefree(PL_savestack);
2566 Safefree(PL_retstack);
5f05dabc 2567 DEBUG( {
3280af22
NIS
2568 Safefree(PL_debname);
2569 Safefree(PL_debdelim);
5f05dabc 2570 } )
378cc40b 2571}
33b78306 2572
76e3520e 2573#ifndef PERL_OBJECT
760ac839 2574static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
76e3520e 2575#endif
7aa04957 2576
76e3520e 2577STATIC void
8ac85365 2578init_lexer(void)
8990e307 2579{
76e3520e
GS
2580#ifdef PERL_OBJECT
2581 PerlIO *tmpfp;
2582#endif
3280af22
NIS
2583 tmpfp = PL_rsfp;
2584 PL_rsfp = Nullfp;
2585 lex_start(PL_linestr);
2586 PL_rsfp = tmpfp;
2587 PL_subname = newSVpv("main",4);
8990e307
LW
2588}
2589
76e3520e 2590STATIC void
8ac85365 2591init_predump_symbols(void)
45d8adaa 2592{
11343788 2593 dTHR;
93a17b20 2594 GV *tmpgv;
a0d0e21e 2595 GV *othergv;
79072805 2596
e1c148c2 2597 sv_setpvn(perl_get_sv("\"", TRUE), " ", 1);
3280af22
NIS
2598 PL_stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2599 GvMULTI_on(PL_stdingv);
2600 IoIFP(GvIOp(PL_stdingv)) = PerlIO_stdin();
adbc6bb1 2601 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
a5f75d66 2602 GvMULTI_on(tmpgv);
3280af22 2603 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(PL_stdingv));
79072805 2604
85e6fe83 2605 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
a5f75d66 2606 GvMULTI_on(tmpgv);
760ac839 2607 IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = PerlIO_stdout();
4633a7c4 2608 setdefout(tmpgv);
adbc6bb1 2609 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
a5f75d66 2610 GvMULTI_on(tmpgv);
3280af22 2611 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(PL_defoutgv));
79072805 2612
a0d0e21e 2613 othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
a5f75d66 2614 GvMULTI_on(othergv);
760ac839 2615 IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = PerlIO_stderr();
adbc6bb1 2616 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
a5f75d66 2617 GvMULTI_on(tmpgv);
a0d0e21e 2618 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv));
79072805 2619
3280af22 2620 PL_statname = NEWSV(66,0); /* last filename we did stat on */
ab821d7f 2621
3280af22
NIS
2622 if (!PL_osname)
2623 PL_osname = savepv(OSNAME);
79072805 2624}
33b78306 2625
76e3520e 2626STATIC void
8ac85365 2627init_postdump_symbols(register int argc, register char **argv, register char **env)
33b78306 2628{
a863c7d1 2629 dTHR;
79072805
LW
2630 char *s;
2631 SV *sv;
2632 GV* tmpgv;
fe14fcc3 2633
79072805 2634 argc--,argv++; /* skip name of script */
3280af22 2635 if (PL_doswitches) {
79072805
LW
2636 for (; argc > 0 && **argv == '-'; argc--,argv++) {
2637 if (!argv[0][1])
2638 break;
2639 if (argv[0][1] == '-') {
2640 argc--,argv++;
2641 break;
2642 }
93a17b20 2643 if (s = strchr(argv[0], '=')) {
79072805 2644 *s++ = '\0';
85e6fe83 2645 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
79072805
LW
2646 }
2647 else
85e6fe83 2648 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
fe14fcc3 2649 }
79072805 2650 }
3280af22
NIS
2651 PL_toptarget = NEWSV(0,0);
2652 sv_upgrade(PL_toptarget, SVt_PVFM);
2653 sv_setpvn(PL_toptarget, "", 0);
2654 PL_bodytarget = NEWSV(0,0);
2655 sv_upgrade(PL_bodytarget, SVt_PVFM);
2656 sv_setpvn(PL_bodytarget, "", 0);
2657 PL_formtarget = PL_bodytarget;
79072805 2658
bbce6d69 2659 TAINT;
85e6fe83 2660 if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
3280af22 2661 sv_setpv(GvSV(tmpgv),PL_origfilename);
79072805
LW
2662 magicname("0", "0", 1);
2663 }
85e6fe83 2664 if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
3280af22
NIS
2665 sv_setpv(GvSV(tmpgv),PL_origargv[0]);
2666 if (PL_argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
2667 GvMULTI_on(PL_argvgv);
2668 (void)gv_AVadd(PL_argvgv);
2669 av_clear(GvAVn(PL_argvgv));
79072805 2670 for (; argc > 0; argc--,argv++) {
3280af22 2671 av_push(GvAVn(PL_argvgv),newSVpv(argv[0],0));
79072805
LW
2672 }
2673 }
3280af22 2674 if (PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
79072805 2675 HV *hv;
3280af22
NIS
2676 GvMULTI_on(PL_envgv);
2677 hv = GvHVn(PL_envgv);
2678 hv_magic(hv, PL_envgv, 'E');
a0d0e21e 2679#ifndef VMS /* VMS doesn't have environ array */
4633a7c4
LW
2680 /* Note that if the supplied env parameter is actually a copy
2681 of the global environ then it may now point to free'd memory
2682 if the environment has been modified since. To avoid this
2683 problem we treat env==NULL as meaning 'use the default'
2684 */
2685 if (!env)
2686 env = environ;
5aabfad6 2687 if (env != environ)
79072805
LW
2688 environ[0] = Nullch;
2689 for (; *env; env++) {
93a17b20 2690 if (!(s = strchr(*env,'=')))
79072805
LW
2691 continue;
2692 *s++ = '\0';
60ce6247 2693#if defined(MSDOS)
137443ea
PP
2694 (void)strupr(*env);
2695#endif
79072805
LW
2696 sv = newSVpv(s--,0);
2697 (void)hv_store(hv, *env, s - *env, sv, 0);
2698 *s = '=';
3e3baf6d
TB
2699#if defined(__BORLANDC__) && defined(USE_WIN32_RTL_ENV)
2700 /* Sins of the RTL. See note in my_setenv(). */
76e3520e 2701 (void)PerlEnv_putenv(savepv(*env));
3e3baf6d 2702#endif
fe14fcc3 2703 }
4550b24a
PP
2704#endif
2705#ifdef DYNAMIC_ENV_FETCH
2706 HvNAME(hv) = savepv(ENV_HV_NAME);
2707#endif
79072805 2708 }
bbce6d69 2709 TAINT_NOT;
85e6fe83 2710 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
1e422769 2711 sv_setiv(GvSV(tmpgv), (IV)getpid());
33b78306 2712}
34de22dd 2713
76e3520e 2714STATIC void
8ac85365 2715init_perllib(void)
34de22dd 2716{
85e6fe83 2717 char *s;
3280af22 2718 if (!PL_tainting) {
552a7a9b 2719#ifndef VMS
76e3520e 2720 s = PerlEnv_getenv("PERL5LIB");
85e6fe83 2721 if (s)
774d564b 2722 incpush(s, TRUE);
85e6fe83 2723 else
76e3520e 2724 incpush(PerlEnv_getenv("PERLLIB"), FALSE);
552a7a9b
PP
2725#else /* VMS */
2726 /* Treat PERL5?LIB as a possible search list logical name -- the
2727 * "natural" VMS idiom for a Unix path string. We allow each
2728 * element to be a set of |-separated directories for compatibility.
2729 */
2730 char buf[256];
2731 int idx = 0;
2732 if (my_trnlnm("PERL5LIB",buf,0))
774d564b 2733 do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
552a7a9b 2734 else
774d564b 2735 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
552a7a9b 2736#endif /* VMS */
85e6fe83 2737 }
34de22dd 2738
c90c0ff4 2739/* Use the ~-expanded versions of APPLLIB (undocumented),
dfe9444c 2740 ARCHLIB PRIVLIB SITEARCH and SITELIB
df5cef82 2741*/
4633a7c4 2742#ifdef APPLLIB_EXP
43051805 2743 incpush(APPLLIB_EXP, TRUE);
16d20bd9 2744#endif
4633a7c4 2745
fed7345c 2746#ifdef ARCHLIB_EXP
774d564b 2747 incpush(ARCHLIB_EXP, FALSE);
a0d0e21e 2748#endif
fed7345c
AD
2749#ifndef PRIVLIB_EXP
2750#define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
34de22dd 2751#endif
00dc2f4f
GS
2752#if defined(WIN32)
2753 incpush(PRIVLIB_EXP, TRUE);
2754#else
774d564b 2755 incpush(PRIVLIB_EXP, FALSE);
00dc2f4f 2756#endif
4633a7c4
LW
2757
2758#ifdef SITEARCH_EXP
774d564b 2759 incpush(SITEARCH_EXP, FALSE);
4633a7c4
LW
2760#endif
2761#ifdef SITELIB_EXP
00dc2f4f
GS
2762#if defined(WIN32)
2763 incpush(SITELIB_EXP, TRUE);
2764#else
774d564b 2765 incpush(SITELIB_EXP, FALSE);
4633a7c4 2766#endif
00dc2f4f 2767#endif
3280af22 2768 if (!PL_tainting)
774d564b
PP
2769 incpush(".", FALSE);
2770}
2771
2772#if defined(DOSISH)
2773# define PERLLIB_SEP ';'
2774#else
2775# if defined(VMS)
2776# define PERLLIB_SEP '|'
2777# else
2778# define PERLLIB_SEP ':'
2779# endif
2780#endif
2781#ifndef PERLLIB_MANGLE
2782# define PERLLIB_MANGLE(s,n) (s)
2783#endif
2784
76e3520e 2785STATIC void
8ac85365 2786incpush(char *p, int addsubdirs)
774d564b
PP
2787{
2788 SV *subdir = Nullsv;
774d564b
PP
2789
2790 if (!p)
2791 return;
2792
2793 if (addsubdirs) {
00db4c45 2794 subdir = sv_newmortal();
3280af22
NIS
2795 if (!PL_archpat_auto) {
2796 STRLEN len = (sizeof(ARCHNAME) + strlen(PL_patchlevel)
774d564b 2797 + sizeof("//auto"));
3280af22
NIS
2798 New(55, PL_archpat_auto, len, char);
2799 sprintf(PL_archpat_auto, "/%s/%s/auto", ARCHNAME, PL_patchlevel);
aa689395
PP
2800#ifdef VMS
2801 for (len = sizeof(ARCHNAME) + 2;
6b88bc9c
GS
2802 PL_archpat_auto[len] != '\0' && PL_archpat_auto[len] != '/'; len++)
2803 if (PL_archpat_auto[len] == '.') PL_archpat_auto[len] = '_';
aa689395 2804#endif
774d564b
PP
2805 }
2806 }
2807
2808 /* Break at all separators */
2809 while (p && *p) {
8c52afec 2810 SV *libdir = NEWSV(55,0);
774d564b
PP
2811 char *s;
2812
2813 /* skip any consecutive separators */
2814 while ( *p == PERLLIB_SEP ) {
2815 /* Uncomment the next line for PATH semantics */
6b88bc9c 2816 /* av_push(GvAVn(PL_incgv), newSVpv(".", 1)); */
774d564b
PP
2817 p++;
2818 }
2819
2820 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
2821 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
2822 (STRLEN)(s - p));
2823 p = s + 1;
2824 }
2825 else {
2826 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
2827 p = Nullch; /* break out */
2828 }
2829
2830 /*
2831 * BEFORE pushing libdir onto @INC we may first push version- and
2832 * archname-specific sub-directories.
2833 */
2834 if (addsubdirs) {
2835 struct stat tmpstatbuf;
aa689395
PP
2836#ifdef VMS
2837 char *unix;
2838 STRLEN len;
774d564b 2839
2d8e6c8d 2840 if ((unix = tounixspec_ts(SvPV(libdir,len),Nullch)) != Nullch) {
aa689395
PP
2841 len = strlen(unix);
2842 while (unix[len-1] == '/') len--; /* Cosmetic */
2843 sv_usepvn(libdir,unix,len);
2844 }
2845 else
2846 PerlIO_printf(PerlIO_stderr(),
2847 "Failed to unixify @INC element \"%s\"\n",
2d8e6c8d 2848 SvPV(libdir,len));
aa689395 2849#endif
4fdae800 2850 /* .../archname/version if -d .../archname/version/auto */
774d564b 2851 sv_setsv(subdir, libdir);
3280af22 2852 sv_catpv(subdir, PL_archpat_auto);
76e3520e 2853 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
774d564b 2854 S_ISDIR(tmpstatbuf.st_mode))
3280af22 2855 av_push(GvAVn(PL_incgv),
774d564b
PP
2856 newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2857
4fdae800 2858 /* .../archname if -d .../archname/auto */
774d564b 2859 sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME),
3280af22 2860 strlen(PL_patchlevel) + 1, "", 0);
76e3520e 2861 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
774d564b 2862 S_ISDIR(tmpstatbuf.st_mode))
3280af22 2863 av_push(GvAVn(PL_incgv),
774d564b
PP
2864 newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2865 }
2866
2867 /* finally push this lib directory on the end of @INC */
3280af22 2868 av_push(GvAVn(PL_incgv), libdir);
774d564b 2869 }
34de22dd 2870}
93a17b20 2871
199100c8 2872#ifdef USE_THREADS
76e3520e 2873STATIC struct perl_thread *
199100c8
MB
2874init_main_thread()
2875{
52e1cb5e 2876 struct perl_thread *thr;
199100c8
MB
2877 XPV *xpv;
2878
52e1cb5e 2879 Newz(53, thr, 1, struct perl_thread);
533c011a 2880 PL_curcop = &PL_compiling;
199100c8 2881 thr->cvcache = newHV();
54b9620d 2882 thr->threadsv = newAV();
940cb80d 2883 /* thr->threadsvp is set when find_threadsv is called */
199100c8 2884 thr->specific = newAV();
38a03e6e 2885 thr->errhv = newHV();
199100c8
MB
2886 thr->flags = THRf_R_JOINABLE;
2887 MUTEX_INIT(&thr->mutex);
2888 /* Handcraft thrsv similarly to mess_sv */
533c011a 2889 New(53, PL_thrsv, 1, SV);
199100c8 2890 Newz(53, xpv, 1, XPV);
533c011a
NIS
2891 SvFLAGS(PL_thrsv) = SVt_PV;
2892 SvANY(PL_thrsv) = (void*)xpv;
2893 SvREFCNT(PL_thrsv) = 1 << 30; /* practically infinite */
2894 SvPVX(PL_thrsv) = (char*)thr;
2895 SvCUR_set(PL_thrsv, sizeof(thr));
2896 SvLEN_set(PL_thrsv, sizeof(thr));
2897 *SvEND(PL_thrsv) = '\0'; /* in the trailing_nul field */
2898 thr->oursv = PL_thrsv;
2899 PL_chopset = " \n-";
3967c732 2900 PL_dumpindent = 4;
533c011a
NIS
2901
2902 MUTEX_LOCK(&PL_threads_mutex);
2903 PL_nthreads++;
199100c8
MB
2904 thr->tid = 0;
2905 thr->next = thr;
2906 thr->prev = thr;
533c011a 2907 MUTEX_UNLOCK(&PL_threads_mutex);
199100c8 2908
4b026b9e
GS
2909#ifdef HAVE_THREAD_INTERN
2910 init_thread_intern(thr);
235db74f
GS
2911#endif
2912
2913#ifdef SET_THREAD_SELF
2914 SET_THREAD_SELF(thr);
199100c8
MB
2915#else
2916 thr->self = pthread_self();
235db74f 2917#endif /* SET_THREAD_SELF */
199100c8
MB
2918 SET_THR(thr);
2919
2920 /*
2921 * These must come after the SET_THR because sv_setpvn does
2922 * SvTAINT and the taint fields require dTHR.
2923 */
533c011a
NIS
2924 PL_toptarget = NEWSV(0,0);
2925 sv_upgrade(PL_toptarget, SVt_PVFM);
2926 sv_setpvn(PL_toptarget, "", 0);
2927 PL_bodytarget = NEWSV(0,0);
2928 sv_upgrade(PL_bodytarget, SVt_PVFM);
2929 sv_setpvn(PL_bodytarget, "", 0);
2930 PL_formtarget = PL_bodytarget;
2faa37cc 2931 thr->errsv = newSVpv("", 0);
78857c3c 2932 (void) find_threadsv("@"); /* Ensure $@ is initialised early */
5c0ca799 2933
533c011a
NIS
2934 PL_maxscream = -1;
2935 PL_regcompp = FUNC_NAME_TO_PTR(pregcomp);
2936 PL_regexecp = FUNC_NAME_TO_PTR(regexec_flags);
2937 PL_regindent = 0;
2938 PL_reginterp_cnt = 0;
5c0ca799 2939
199100c8
MB
2940 return thr;
2941}
2942#endif /* USE_THREADS */
2943
93a17b20 2944void
76e3520e 2945call_list(I32 oldscope, AV *paramList)
93a17b20 2946{
11343788 2947 dTHR;
3280af22 2948 line_t oldline = PL_curcop->cop_line;
22921e25
CS
2949 STRLEN len;
2950 dJMPENV;
6224f72b 2951 int ret;
93a17b20 2952
76e3520e
GS
2953 while (AvFILL(paramList) >= 0) {
2954 CV *cv = (CV*)av_shift(paramList);
93a17b20 2955
8990e307 2956 SAVEFREESV(cv);
a0d0e21e 2957
6224f72b
GS
2958 JMPENV_PUSH(ret);
2959 switch (ret) {
2960 case 0: {
38a03e6e 2961 SV* atsv = ERRSV;
3280af22 2962 PUSHMARK(PL_stack_sp);
748a9306 2963 perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
12f917ad 2964 (void)SvPV(atsv, len);
748a9306 2965 if (len) {
54310121 2966 JMPENV_POP;
3280af22
NIS
2967 PL_curcop = &PL_compiling;
2968 PL_curcop->cop_line = oldline;
2969 if (paramList == PL_beginav)
12f917ad 2970 sv_catpv(atsv, "BEGIN failed--compilation aborted");
748a9306 2971 else
12f917ad 2972 sv_catpv(atsv, "END failed--cleanup aborted");
3280af22 2973 while (PL_scopestack_ix > oldscope)
2ae324a7 2974 LEAVE;
12f917ad 2975 croak("%s", SvPVX(atsv));
748a9306 2976 }
a0d0e21e 2977 }
85e6fe83 2978 break;
6224f72b 2979 case 1:
f86702cc 2980 STATUS_ALL_FAILURE;
85e6fe83 2981 /* FALL THROUGH */
6224f72b 2982 case 2:
85e6fe83 2983 /* my_exit() was called */
3280af22 2984 while (PL_scopestack_ix > oldscope)
2ae324a7 2985 LEAVE;
84902520 2986 FREETMPS;
3280af22
NIS
2987 PL_curstash = PL_defstash;
2988 if (PL_endav)
2989 call_list(oldscope, PL_endav);
54310121 2990 JMPENV_POP;
3280af22
NIS
2991 PL_curcop = &PL_compiling;
2992 PL_curcop->cop_line = oldline;
2993 if (PL_statusvalue) {
2994 if (paramList == PL_beginav)
a0d0e21e 2995 croak("BEGIN failed--compilation aborted");
85e6fe83 2996 else
a0d0e21e 2997 croak("END failed--cleanup aborted");
85e6fe83 2998 }
f86702cc 2999 my_exit_jump();
85e6fe83 3000 /* NOTREACHED */
6224f72b 3001 case 3:
3280af22 3002 if (!PL_restartop) {
760ac839 3003 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
a0d0e21e 3004 FREETMPS;
85e6fe83
LW
3005 break;
3006 }
54310121 3007 JMPENV_POP;
3280af22
NIS
3008 PL_curcop = &PL_compiling;
3009 PL_curcop->cop_line = oldline;
6224f72b 3010 JMPENV_JUMP(3);
8990e307 3011 }
54310121 3012 JMPENV_POP;
93a17b20 3013 }
93a17b20 3014}
93a17b20 3015
f86702cc 3016void
8ac85365 3017my_exit(U32 status)
f86702cc 3018{
5dc0d613
MB
3019 dTHR;
3020
8b73bbec 3021 DEBUG_S(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
a863c7d1 3022 thr, (unsigned long) status));
f86702cc
PP
3023 switch (status) {
3024 case 0:
3025 STATUS_ALL_SUCCESS;
3026 break;
3027 case 1:
3028 STATUS_ALL_FAILURE;
3029 break;
3030 default:
3031 STATUS_NATIVE_SET(status);
3032 break;
3033 }
3034 my_exit_jump();
3035}
3036
3037void
8ac85365 3038my_failure_exit(void)
f86702cc
PP
3039{
3040#ifdef VMS
3041 if (vaxc$errno & 1) {
4fdae800
PP
3042 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
3043 STATUS_NATIVE_SET(44);
f86702cc
PP
3044 }
3045 else {
ff0cee69 3046 if (!vaxc$errno && errno) /* unlikely */
4fdae800 3047 STATUS_NATIVE_SET(44);
f86702cc 3048 else
4fdae800 3049 STATUS_NATIVE_SET(vaxc$errno);
f86702cc
PP
3050 }
3051#else
9b599b2a 3052 int exitstatus;
f86702cc
PP
3053 if (errno & 255)
3054 STATUS_POSIX_SET(errno);
9b599b2a
GS
3055 else {
3056 exitstatus = STATUS_POSIX >> 8;
3057 if (exitstatus & 255)
3058 STATUS_POSIX_SET(exitstatus);
3059 else
3060 STATUS_POSIX_SET(255);
3061 }
f86702cc
PP
3062#endif
3063 my_exit_jump();
93a17b20
LW
3064}
3065
76e3520e 3066STATIC void
8ac85365 3067my_exit_jump(void)
f86702cc 3068{
de616352 3069 dTHR;
c09156bb 3070 register PERL_CONTEXT *cx;
f86702cc
PP
3071 I32 gimme;
3072 SV **newsp;
3073
3280af22
NIS
3074 if (PL_e_script) {
3075 SvREFCNT_dec(PL_e_script);
3076 PL_e_script = Nullsv;
f86702cc
PP
3077 }
3078
3280af22 3079 POPSTACK_TO(PL_mainstack);
f86702cc
PP
3080 if (cxstack_ix >= 0) {
3081 if (cxstack_ix > 0)
3082 dounwind(0);
3280af22 3083 POPBLOCK(cx,PL_curpm);
f86702cc
PP
3084 LEAVE;
3085 }
ff0cee69 3086
6224f72b 3087 JMPENV_JUMP(2);
f86702cc 3088}
873ef191 3089
7a5f8e82
DL
3090#ifdef PERL_OBJECT
3091#define NO_XSLOCKS
3092#endif /* PERL_OBJECT */
873ef191
GS
3093
3094#include "XSUB.h"
3095
3096static I32
6224f72b
GS
3097#ifdef PERL_OBJECT
3098read_e_script(CPerlObj *pPerl, int idx, SV *buf_sv, int maxlen)
3099#else
3100read_e_script(int idx, SV *buf_sv, int maxlen)
3101#endif
873ef191
GS
3102{
3103 char *p, *nl;
3280af22 3104 p = SvPVX(PL_e_script);
873ef191 3105 nl = strchr(p, '\n');
3280af22 3106 nl = (nl) ? nl+1 : SvEND(PL_e_script);
7dfe3f66
PM
3107 if (nl-p == 0) {
3108 filter_del(read_e_script);
873ef191 3109 return 0;
7dfe3f66 3110 }
873ef191 3111 sv_catpvn(buf_sv, p, nl-p);
3280af22 3112 sv_chop(PL_e_script, nl);
873ef191
GS
3113 return 1;
3114}
3115
1163b5c4 3116