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