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