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