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