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