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