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