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