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