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