This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Mention /usr/share/locale.
[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
2d8e6c8d
GS
1451 if (croak_on_error && SvTRUE(ERRSV)) {
1452 STRLEN n_a;
1453 croak(SvPVx(ERRSV, n_a));
1454 }
137443ea
PP
1455
1456 return sv;
1457}
1458
4633a7c4
LW
1459/* Require a module. */
1460
1461void
8ac85365 1462perl_require_pv(char *pv)
4633a7c4 1463{
d3acc0f7
JP
1464 SV* sv;
1465 dSP;
e788e7d3 1466 PUSHSTACKi(PERLSI_REQUIRE);
d3acc0f7
JP
1467 PUTBACK;
1468 sv = sv_newmortal();
4633a7c4
LW
1469 sv_setpv(sv, "require '");
1470 sv_catpv(sv, pv);
1471 sv_catpv(sv, "'");
1472 perl_eval_sv(sv, G_DISCARD);
d3acc0f7
JP
1473 SPAGAIN;
1474 POPSTACK;
79072805
LW
1475}
1476
79072805 1477void
8ac85365 1478magicname(char *sym, char *name, I32 namlen)
79072805
LW
1479{
1480 register GV *gv;
1481
85e6fe83 1482 if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
79072805
LW
1483 sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
1484}
1485
76e3520e 1486STATIC void
8ac85365
NIS
1487usage(char *name) /* XXX move this out into a module ? */
1488
4633a7c4 1489{
ab821d7f
PP
1490 /* This message really ought to be max 23 lines.
1491 * Removed -h because the user already knows that opton. Others? */
fb73857a 1492
76e3520e 1493 static char *usage_msg[] = {
fb73857a
PP
1494"-0[octal] specify record separator (\\0, if no argument)",
1495"-a autosplit mode with -n or -p (splits $_ into @F)",
1496"-c check syntax only (runs BEGIN and END blocks)",
1497"-d[:debugger] run scripts under debugger",
1498"-D[number/list] set debugging flags (argument is a bit mask or flags)",
1499"-e 'command' one line of script. Several -e's allowed. Omit [programfile].",
1500"-F/pattern/ split() pattern for autosplit (-a). The //'s are optional.",
1501"-i[extension] edit <> files in place (make backup if extension supplied)",
1502"-Idirectory specify @INC/#include directory (may be used more than once)",
1503"-l[octal] enable line ending processing, specifies line terminator",
1504"-[mM][-]module.. executes `use/no module...' before executing your script.",
1505"-n assume 'while (<>) { ... }' loop around your script",
1506"-p assume loop like -n but print line also like sed",
1507"-P run script through C preprocessor before compilation",
1508"-s enable some switch parsing for switches after script name",
1509"-S look for the script using PATH environment variable",
1510"-T turn on tainting checks",
1511"-u dump core after parsing script",
1512"-U allow unsafe operations",
95103687 1513"-v print version number, patchlevel plus VERY IMPORTANT perl info",
fb73857a
PP
1514"-V[:variable] print perl configuration information",
1515"-w TURN WARNINGS ON FOR COMPILATION OF YOUR SCRIPT. Recommended.",
1516"-x[directory] strip off text before #!perl line and perhaps cd to directory",
1517"\n",
1518NULL
1519};
76e3520e 1520 char **p = usage_msg;
fb73857a 1521
ab821d7f 1522 printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
fb73857a
PP
1523 while (*p)
1524 printf("\n %s", *p++);
4633a7c4
LW
1525}
1526
79072805
LW
1527/* This routine handles any switches that can be given during run */
1528
1529char *
8ac85365 1530moreswitches(char *s)
79072805
LW
1531{
1532 I32 numlen;
c07a80fd 1533 U32 rschar;
79072805
LW
1534
1535 switch (*s) {
1536 case '0':
a863c7d1
MB
1537 {
1538 dTHR;
c07a80fd 1539 rschar = scan_oct(s, 4, &numlen);
3280af22 1540 SvREFCNT_dec(PL_nrs);
c07a80fd 1541 if (rschar & ~((U8)~0))
3280af22 1542 PL_nrs = &PL_sv_undef;
c07a80fd 1543 else if (!rschar && numlen >= 2)
3280af22 1544 PL_nrs = newSVpv("", 0);
c07a80fd
PP
1545 else {
1546 char ch = rschar;
3280af22 1547 PL_nrs = newSVpv(&ch, 1);
79072805
LW
1548 }
1549 return s + numlen;
a863c7d1 1550 }
2304df62 1551 case 'F':
3280af22
NIS
1552 PL_minus_F = TRUE;
1553 PL_splitstr = savepv(s + 1);
2304df62
AD
1554 s += strlen(s);
1555 return s;
79072805 1556 case 'a':
3280af22 1557 PL_minus_a = TRUE;
79072805
LW
1558 s++;
1559 return s;
1560 case 'c':
3280af22 1561 PL_minus_c = TRUE;
79072805
LW
1562 s++;
1563 return s;
1564 case 'd':
bbce6d69 1565 forbid_setid("-d");
4633a7c4 1566 s++;
c07a80fd 1567 if (*s == ':' || *s == '=') {
46fc3d4c 1568 my_setenv("PERL5DB", form("use Devel::%s;", ++s));
4633a7c4 1569 s += strlen(s);
4633a7c4 1570 }
3280af22
NIS
1571 if (!PL_perldb) {
1572 PL_perldb = PERLDB_ALL;
a0d0e21e
LW
1573 init_debugger();
1574 }
79072805
LW
1575 return s;
1576 case 'D':
1577#ifdef DEBUGGING
bbce6d69 1578 forbid_setid("-D");
79072805 1579 if (isALPHA(s[1])) {
8b73bbec 1580 static char debopts[] = "psltocPmfrxuLHXDS";
79072805
LW
1581 char *d;
1582
93a17b20 1583 for (s++; *s && (d = strchr(debopts,*s)); s++)
3280af22 1584 PL_debug |= 1 << (d - debopts);
79072805
LW
1585 }
1586 else {
3280af22 1587 PL_debug = atoi(s+1);
79072805
LW
1588 for (s++; isDIGIT(*s); s++) ;
1589 }
3280af22 1590 PL_debug |= 0x80000000;
79072805
LW
1591#else
1592 warn("Recompile perl with -DDEBUGGING to use -D switch\n");
a0d0e21e 1593 for (s++; isALNUM(*s); s++) ;
79072805
LW
1594#endif
1595 /*SUPPRESS 530*/
1596 return s;
4633a7c4 1597 case 'h':
3280af22 1598 usage(PL_origargv[0]);
6ad3d225 1599 PerlProc_exit(0);
79072805 1600 case 'i':
3280af22
NIS
1601 if (PL_inplace)
1602 Safefree(PL_inplace);
1603 PL_inplace = savepv(s+1);
79072805 1604 /*SUPPRESS 530*/
3280af22 1605 for (s = PL_inplace; *s && !isSPACE(*s); s++) ;
7b8d334a 1606 if (*s) {
fb73857a 1607 *s++ = '\0';
7b8d334a
GS
1608 if (*s == '-') /* Additional switches on #! line. */
1609 s++;
1610 }
fb73857a
PP
1611 return s;
1612 case 'I': /* -I handled both here and in parse_perl() */
bbce6d69 1613 forbid_setid("-I");
fb73857a
PP
1614 ++s;
1615 while (*s && isSPACE(*s))
1616 ++s;
1617 if (*s) {
774d564b 1618 char *e, *p;
748a9306 1619 for (e = s; *e && !isSPACE(*e); e++) ;
774d564b
PP
1620 p = savepvn(s, e-s);
1621 incpush(p, TRUE);
1622 Safefree(p);
fb73857a 1623 s = e;
79072805
LW
1624 }
1625 else
463ee0b2 1626 croak("No space allowed after -I");
fb73857a 1627 return s;
79072805 1628 case 'l':
3280af22 1629 PL_minus_l = TRUE;
79072805 1630 s++;
3280af22
NIS
1631 if (PL_ors)
1632 Safefree(PL_ors);
79072805 1633 if (isDIGIT(*s)) {
3280af22
NIS
1634 PL_ors = savepv("\n");
1635 PL_orslen = 1;
1636 *PL_ors = scan_oct(s, 3 + (*s == '0'), &numlen);
79072805
LW
1637 s += numlen;
1638 }
1639 else {
a863c7d1 1640 dTHR;
3280af22
NIS
1641 if (RsPARA(PL_nrs)) {
1642 PL_ors = "\n\n";
1643 PL_orslen = 2;
c07a80fd
PP
1644 }
1645 else
3280af22
NIS
1646 PL_ors = SvPV(PL_nrs, PL_orslen);
1647 PL_ors = savepvn(PL_ors, PL_orslen);
79072805
LW
1648 }
1649 return s;
1a30305b 1650 case 'M':
bbce6d69 1651 forbid_setid("-M"); /* XXX ? */
1a30305b
PP
1652 /* FALL THROUGH */
1653 case 'm':
bbce6d69 1654 forbid_setid("-m"); /* XXX ? */
1a30305b 1655 if (*++s) {
a5f75d66 1656 char *start;
11343788 1657 SV *sv;
a5f75d66
AD
1658 char *use = "use ";
1659 /* -M-foo == 'no foo' */
1660 if (*s == '-') { use = "no "; ++s; }
11343788 1661 sv = newSVpv(use,0);
a5f75d66 1662 start = s;
1a30305b 1663 /* We allow -M'Module qw(Foo Bar)' */
c07a80fd
PP
1664 while(isALNUM(*s) || *s==':') ++s;
1665 if (*s != '=') {
11343788 1666 sv_catpv(sv, start);
c07a80fd
PP
1667 if (*(start-1) == 'm') {
1668 if (*s != '\0')
1669 croak("Can't use '%c' after -mname", *s);
11343788 1670 sv_catpv( sv, " ()");
c07a80fd
PP
1671 }
1672 } else {
11343788
MB
1673 sv_catpvn(sv, start, s-start);
1674 sv_catpv(sv, " split(/,/,q{");
1675 sv_catpv(sv, ++s);
1676 sv_catpv(sv, "})");
c07a80fd 1677 }
1a30305b 1678 s += strlen(s);
3280af22
NIS
1679 if (PL_preambleav == NULL)
1680 PL_preambleav = newAV();
1681 av_push(PL_preambleav, sv);
1a30305b
PP
1682 }
1683 else
1684 croak("No space allowed after -%c", *(s-1));
1685 return s;
79072805 1686 case 'n':
3280af22 1687 PL_minus_n = TRUE;
79072805
LW
1688 s++;
1689 return s;
1690 case 'p':
3280af22 1691 PL_minus_p = TRUE;
79072805
LW
1692 s++;
1693 return s;
1694 case 's':
bbce6d69 1695 forbid_setid("-s");
3280af22 1696 PL_doswitches = TRUE;
79072805
LW
1697 s++;
1698 return s;
463ee0b2 1699 case 'T':
3280af22 1700 if (!PL_tainting)
9607fc9c 1701 croak("Too late for \"-T\" option");
463ee0b2
LW
1702 s++;
1703 return s;
79072805 1704 case 'u':
3280af22 1705 PL_do_undump = TRUE;
79072805
LW
1706 s++;
1707 return s;
1708 case 'U':
3280af22 1709 PL_unsafe = TRUE;
79072805
LW
1710 s++;
1711 return s;
1712 case 'v':
a5f75d66 1713#if defined(SUBVERSION) && SUBVERSION > 0
fb73857a
PP
1714 printf("\nThis is perl, version 5.%03d_%02d built for %s",
1715 PATCHLEVEL, SUBVERSION, ARCHNAME);
a5f75d66 1716#else
fb73857a 1717 printf("\nThis is perl, version %s built for %s",
6b88bc9c 1718 PL_patchlevel, ARCHNAME);
fb73857a
PP
1719#endif
1720#if defined(LOCAL_PATCH_COUNT)
1721 if (LOCAL_PATCH_COUNT > 0)
1722 printf("\n(with %d registered patch%s, see perl -V for more detail)",
1723 LOCAL_PATCH_COUNT, (LOCAL_PATCH_COUNT!=1) ? "es" : "");
a5f75d66 1724#endif
1a30305b 1725
a411490c 1726 printf("\n\nCopyright 1987-1998, Larry Wall\n");
79072805 1727#ifdef MSDOS
fb73857a 1728 printf("\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
55497cff
PP
1729#endif
1730#ifdef DJGPP
1731 printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
9731c6ca 1732 printf("djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1998\n");
4633a7c4 1733#endif
79072805 1734#ifdef OS2
5dd60ef7 1735 printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
a411490c 1736 "Version 5 port Copyright (c) 1994-1998, Andreas Kaiser, Ilya Zakharevich\n");
79072805 1737#endif
79072805 1738#ifdef atarist
760ac839 1739 printf("atariST series port, ++jrb bammi@cadence.com\n");
79072805 1740#endif
a3f9223b
GS
1741#ifdef __BEOS__
1742 printf("BeOS port Copyright Tom Spindler, 1997-1998\n");
1743#endif
1d84e8df
JH
1744#ifdef MPE
1745 printf("MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-1998\n");
1746#endif
9d116dd7
JH
1747#ifdef OEMVS
1748 printf("MVS (OS390) port by Mortice Kern Systems, 1997-1998\n");
1749#endif
495c5fdc
GP
1750#ifdef __VOS__
1751 printf("Stratus VOS port by Paul_Green@stratus.com, 1997-1998\n");
1752#endif
092bebab
JH
1753#ifdef __OPEN_VM
1754 printf("VM/ESA port by Neale Ferguson, 1998\n");
1755#endif
a1a0e61e
TD
1756#ifdef POSIX_BC
1757 printf("BS2000 (POSIX) port by Start Amadeus GmbH, 1998\n");
1758#endif
61ae2fbf
JH
1759#ifdef __MINT__
1760 printf("MiNT port by Guido Flohr, 1997\n");
1761#endif
baed7233
DL
1762#ifdef BINARY_BUILD_NOTICE
1763 BINARY_BUILD_NOTICE;
1764#endif
760ac839 1765 printf("\n\
79072805 1766Perl may be copied only under the terms of either the Artistic License or the\n\
95103687
GS
1767GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n\
1768Complete documentation for Perl, including FAQ lists, should be found on\n\
1769this system using `man perl' or `perldoc perl'. If you have access to the\n\
1770Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n");
6ad3d225 1771 PerlProc_exit(0);
79072805 1772 case 'w':
599cee73
PM
1773 if (! (PL_dowarn & G_WARN_ALL_MASK))
1774 PL_dowarn |= G_WARN_ON;
1775 s++;
1776 return s;
1777 case 'W':
1778 PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
e24b16f9 1779 PL_compiling.cop_warnings = WARN_ALL ;
599cee73
PM
1780 s++;
1781 return s;
1782 case 'X':
1783 PL_dowarn = G_WARN_ALL_OFF;
e24b16f9 1784 PL_compiling.cop_warnings = WARN_NONE ;
79072805
LW
1785 s++;
1786 return s;
a0d0e21e 1787 case '*':
79072805
LW
1788 case ' ':
1789 if (s[1] == '-') /* Additional switches on #! line. */
1790 return s+2;
1791 break;
a0d0e21e 1792 case '-':
79072805 1793 case 0:
51882d45 1794#if defined(WIN32) || !defined(PERL_STRICT_CR)
a868473f
NIS
1795 case '\r':
1796#endif
79072805
LW
1797 case '\n':
1798 case '\t':
1799 break;
aa689395
PP
1800#ifdef ALTERNATE_SHEBANG
1801 case 'S': /* OS/2 needs -S on "extproc" line. */
1802 break;
1803#endif
a0d0e21e 1804 case 'P':
3280af22 1805 if (PL_preprocess)
a0d0e21e
LW
1806 return s+1;
1807 /* FALL THROUGH */
79072805 1808 default:
a0d0e21e 1809 croak("Can't emulate -%.1s on #! line",s);
79072805
LW
1810 }
1811 return Nullch;
1812}
1813
1814/* compliments of Tom Christiansen */
1815
1816/* unexec() can be found in the Gnu emacs distribution */
ee580363 1817/* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
79072805
LW
1818
1819void
8ac85365 1820my_unexec(void)
79072805
LW
1821{
1822#ifdef UNEXEC
46fc3d4c
PP
1823 SV* prog;
1824 SV* file;
ee580363 1825 int status = 1;
79072805
LW
1826 extern int etext;
1827
ee580363 1828 prog = newSVpv(BIN_EXP, 0);
46fc3d4c 1829 sv_catpv(prog, "/perl");
6b88bc9c 1830 file = newSVpv(PL_origfilename, 0);
46fc3d4c 1831 sv_catpv(file, ".perldump");
79072805 1832
ee580363
GS
1833 unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
1834 /* unexec prints msg to stderr in case of failure */
6ad3d225 1835 PerlProc_exit(status);
79072805 1836#else
a5f75d66
AD
1837# ifdef VMS
1838# include <lib$routines.h>
1839 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
aa689395 1840# else
79072805 1841 ABORT(); /* for use with undump */
aa689395 1842# endif
a5f75d66 1843#endif
79072805
LW
1844}
1845
cb68f92d
GS
1846/* initialize curinterp */
1847STATIC void
1848init_interp(void)
1849{
1850
066ef5b5 1851#ifdef PERL_OBJECT /* XXX kludge */
cb68f92d 1852#define I_REINIT \
6b88bc9c
GS
1853 STMT_START { \
1854 PL_chopset = " \n-"; \
1855 PL_copline = NOLINE; \
1856 PL_curcop = &PL_compiling;\
1857 PL_curcopdb = NULL; \
1858 PL_dbargs = 0; \
1859 PL_dlmax = 128; \
3967c732 1860 PL_dumpindent = 4; \
6b88bc9c
GS
1861 PL_laststatval = -1; \
1862 PL_laststype = OP_STAT; \
1863 PL_maxscream = -1; \
1864 PL_maxsysfd = MAXSYSFD; \
1865 PL_statname = Nullsv; \
1866 PL_tmps_floor = -1; \
1867 PL_tmps_ix = -1; \
1868 PL_op_mask = NULL; \
1869 PL_dlmax = 128; \
1870 PL_laststatval = -1; \
1871 PL_laststype = OP_STAT; \
1872 PL_mess_sv = Nullsv; \
1873 PL_splitstr = " "; \
1874 PL_generation = 100; \
1875 PL_exitlist = NULL; \
1876 PL_exitlistlen = 0; \
1877 PL_regindent = 0; \
1878 PL_in_clean_objs = FALSE; \
1879 PL_in_clean_all = FALSE; \
1880 PL_profiledata = NULL; \
1881 PL_rsfp = Nullfp; \
1882 PL_rsfp_filters = Nullav; \
24d3c518 1883 PL_dirty = FALSE; \
cb68f92d 1884 } STMT_END
9666903d 1885 I_REINIT;
066ef5b5
GS
1886#else
1887# ifdef MULTIPLICITY
1888# define PERLVAR(var,type)
8f872242
NIS
1889# define PERLVARI(var,type,init) PL_curinterp->var = init;
1890# define PERLVARIC(var,type,init) PL_curinterp->var = init;
066ef5b5
GS
1891# include "intrpvar.h"
1892# ifndef USE_THREADS
1893# include "thrdvar.h"
1894# endif
1895# undef PERLVAR
1896# undef PERLVARI
1897# undef PERLVARIC
3967c732 1898# else
066ef5b5 1899# define PERLVAR(var,type)
533c011a
NIS
1900# define PERLVARI(var,type,init) PL_##var = init;
1901# define PERLVARIC(var,type,init) PL_##var = init;
066ef5b5
GS
1902# include "intrpvar.h"
1903# ifndef USE_THREADS
1904# include "thrdvar.h"
1905# endif
1906# undef PERLVAR
1907# undef PERLVARI
1908# undef PERLVARIC
1909# endif
cb68f92d
GS
1910#endif
1911
cb68f92d
GS
1912}
1913
76e3520e 1914STATIC void
8ac85365 1915init_main_stash(void)
79072805 1916{
11343788 1917 dTHR;
463ee0b2 1918 GV *gv;
6e72f9df
PP
1919
1920 /* Note that strtab is a rather special HV. Assumptions are made
1921 about not iterating on it, and not adding tie magic to it.
1922 It is properly deallocated in perl_destruct() */
3280af22 1923 PL_strtab = newHV();
5f08fbcd
GS
1924#ifdef USE_THREADS
1925 MUTEX_INIT(&PL_strtab_mutex);
1926#endif
3280af22
NIS
1927 HvSHAREKEYS_off(PL_strtab); /* mandatory */
1928 hv_ksplit(PL_strtab, 512);
6e72f9df 1929
3280af22
NIS
1930 PL_curstash = PL_defstash = newHV();
1931 PL_curstname = newSVpv("main",4);
adbc6bb1
LW
1932 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
1933 SvREFCNT_dec(GvHV(gv));
3280af22 1934 GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash);
463ee0b2 1935 SvREADONLY_on(gv);
3280af22
NIS
1936 HvNAME(PL_defstash) = savepv("main");
1937 PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
1938 GvMULTI_on(PL_incgv);
1939 PL_hintgv = gv_fetchpv("\010",TRUE, SVt_PV); /* ^H */
1940 GvMULTI_on(PL_hintgv);
1941 PL_defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
1942 PL_errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
1943 GvMULTI_on(PL_errgv);
1944 PL_replgv = gv_fetchpv("\022", TRUE, SVt_PV); /* ^R */
1945 GvMULTI_on(PL_replgv);
84902520 1946 (void)form("%240s",""); /* Preallocate temp - for immediate signals. */
38a03e6e
MB
1947 sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
1948 sv_setpvn(ERRSV, "", 0);
3280af22
NIS
1949 PL_curstash = PL_defstash;
1950 PL_compiling.cop_stash = PL_defstash;
1951 PL_debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
1952 PL_globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
4633a7c4 1953 /* We must init $/ before switches are processed. */
9d14cc18 1954 sv_setpvn(perl_get_sv("/", TRUE), "\n", 1);
79072805
LW
1955}
1956
76e3520e 1957STATIC void
01f988be 1958open_script(char *scriptname, bool dosearch, SV *sv, int *fdscript)
79072805 1959{
0f15f207 1960 dTHR;
79072805 1961 register char *s;
2a92aaa0 1962
6c4ab083 1963 *fdscript = -1;
79072805 1964
3280af22
NIS
1965 if (PL_e_script) {
1966 PL_origfilename = savepv("-e");
96436eeb 1967 }
6c4ab083
GS
1968 else {
1969 /* if find_script() returns, it returns a malloc()-ed value */
3280af22 1970 PL_origfilename = scriptname = find_script(scriptname, dosearch, NULL, 1);
6c4ab083
GS
1971
1972 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
1973 char *s = scriptname + 8;
1974 *fdscript = atoi(s);
1975 while (isDIGIT(*s))
1976 s++;
1977 if (*s) {
1978 scriptname = savepv(s + 1);
3280af22
NIS
1979 Safefree(PL_origfilename);
1980 PL_origfilename = scriptname;
6c4ab083
GS
1981 }
1982 }
1983 }
1984
3280af22
NIS
1985 PL_curcop->cop_filegv = gv_fetchfile(PL_origfilename);
1986 if (strEQ(PL_origfilename,"-"))
79072805 1987 scriptname = "";
01f988be 1988 if (*fdscript >= 0) {
3280af22 1989 PL_rsfp = PerlIO_fdopen(*fdscript,PERL_SCRIPT_MODE);
96436eeb 1990#if defined(HAS_FCNTL) && defined(F_SETFD)
3280af22
NIS
1991 if (PL_rsfp)
1992 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1); /* ensure close-on-exec */
96436eeb
PP
1993#endif
1994 }
3280af22 1995 else if (PL_preprocess) {
46fc3d4c 1996 char *cpp_cfg = CPPSTDIN;
63bfd3db 1997 SV *cpp = newSVpv("",0);
46fc3d4c
PP
1998 SV *cmd = NEWSV(0,0);
1999
2000 if (strEQ(cpp_cfg, "cppstdin"))
2001 sv_catpvf(cpp, "%s/", BIN_EXP);
2002 sv_catpv(cpp, cpp_cfg);
79072805 2003
79072805 2004 sv_catpv(sv,"-I");
fed7345c 2005 sv_catpv(sv,PRIVLIB_EXP);
46fc3d4c 2006
79072805 2007#ifdef MSDOS
46fc3d4c 2008 sv_setpvf(cmd, "\
79072805
LW
2009sed %s -e \"/^[^#]/b\" \
2010 -e \"/^#[ ]*include[ ]/b\" \
2011 -e \"/^#[ ]*define[ ]/b\" \
2012 -e \"/^#[ ]*if[ ]/b\" \
2013 -e \"/^#[ ]*ifdef[ ]/b\" \
2014 -e \"/^#[ ]*ifndef[ ]/b\" \
2015 -e \"/^#[ ]*else/b\" \
2016 -e \"/^#[ ]*elif[ ]/b\" \
2017 -e \"/^#[ ]*undef[ ]/b\" \
2018 -e \"/^#[ ]*endif/b\" \
2019 -e \"s/^#.*//\" \
fc36a67e 2020 %s | %_ -C %_ %s",
6b88bc9c 2021 (PL_doextract ? "-e \"1,/^#/d\n\"" : ""),
79072805 2022#else
092bebab
JH
2023# ifdef __OPEN_VM
2024 sv_setpvf(cmd, "\
2025%s %s -e '/^[^#]/b' \
2026 -e '/^#[ ]*include[ ]/b' \
2027 -e '/^#[ ]*define[ ]/b' \
2028 -e '/^#[ ]*if[ ]/b' \
2029 -e '/^#[ ]*ifdef[ ]/b' \
2030 -e '/^#[ ]*ifndef[ ]/b' \
2031 -e '/^#[ ]*else/b' \
2032 -e '/^#[ ]*elif[ ]/b' \
2033 -e '/^#[ ]*undef[ ]/b' \
2034 -e '/^#[ ]*endif/b' \
2035 -e 's/^[ ]*#.*//' \
2036 %s | %_ %_ %s",
2037# else
46fc3d4c 2038 sv_setpvf(cmd, "\
79072805
LW
2039%s %s -e '/^[^#]/b' \
2040 -e '/^#[ ]*include[ ]/b' \
2041 -e '/^#[ ]*define[ ]/b' \
2042 -e '/^#[ ]*if[ ]/b' \
2043 -e '/^#[ ]*ifdef[ ]/b' \
2044 -e '/^#[ ]*ifndef[ ]/b' \
2045 -e '/^#[ ]*else/b' \
2046 -e '/^#[ ]*elif[ ]/b' \
2047 -e '/^#[ ]*undef[ ]/b' \
2048 -e '/^#[ ]*endif/b' \
2049 -e 's/^[ ]*#.*//' \
fc36a67e 2050 %s | %_ -C %_ %s",
092bebab 2051# endif
79072805
LW
2052#ifdef LOC_SED
2053 LOC_SED,
2054#else
2055 "sed",
2056#endif
3280af22 2057 (PL_doextract ? "-e '1,/^#/d\n'" : ""),
79072805 2058#endif
46fc3d4c 2059 scriptname, cpp, sv, CPPMINUS);
3280af22 2060 PL_doextract = FALSE;
79072805 2061#ifdef IAMSUID /* actually, this is caught earlier */
b28d0864 2062 if (PL_euid != PL_uid && !PL_euid) { /* if running suidperl */
79072805 2063#ifdef HAS_SETEUID
b28d0864 2064 (void)seteuid(PL_uid); /* musn't stay setuid root */
79072805
LW
2065#else
2066#ifdef HAS_SETREUID
b28d0864 2067 (void)setreuid((Uid_t)-1, PL_uid);
85e6fe83
LW
2068#else
2069#ifdef HAS_SETRESUID
b28d0864 2070 (void)setresuid((Uid_t)-1, PL_uid, (Uid_t)-1);
79072805 2071#else
b28d0864 2072 PerlProc_setuid(PL_uid);
79072805
LW
2073#endif
2074#endif
85e6fe83 2075#endif
b28d0864 2076 if (PerlProc_geteuid() != PL_uid)
463ee0b2 2077 croak("Can't do seteuid!\n");
79072805
LW
2078 }
2079#endif /* IAMSUID */
3280af22 2080 PL_rsfp = PerlProc_popen(SvPVX(cmd), "r");
46fc3d4c
PP
2081 SvREFCNT_dec(cmd);
2082 SvREFCNT_dec(cpp);
79072805
LW
2083 }
2084 else if (!*scriptname) {
bbce6d69 2085 forbid_setid("program input from stdin");
3280af22 2086 PL_rsfp = PerlIO_stdin();
79072805 2087 }
96436eeb 2088 else {
3280af22 2089 PL_rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
96436eeb 2090#if defined(HAS_FCNTL) && defined(F_SETFD)
3280af22
NIS
2091 if (PL_rsfp)
2092 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1); /* ensure close-on-exec */
96436eeb
PP
2093#endif
2094 }
3280af22 2095 if (!PL_rsfp) {
13281fa4 2096#ifdef DOSUID
a687059c 2097#ifndef IAMSUID /* in case script is not readable before setuid */
6b88bc9c
GS
2098 if (PL_euid &&
2099 PerlLIO_stat(SvPVX(GvSV(PL_curcop->cop_filegv)),&PL_statbuf) >= 0 &&
2100 PL_statbuf.st_mode & (S_ISUID|S_ISGID))
2101 {
46fc3d4c 2102 /* try again */
6b88bc9c 2103 PerlProc_execv(form("%s/sperl%s", BIN_EXP, PL_patchlevel), PL_origargv);
463ee0b2 2104 croak("Can't do setuid\n");
13281fa4
LW
2105 }
2106#endif
2107#endif
463ee0b2 2108 croak("Can't open perl script \"%s\": %s\n",
3280af22 2109 SvPVX(GvSV(PL_curcop->cop_filegv)), Strerror(errno));
13281fa4 2110 }
79072805 2111}
8d063cd8 2112
76e3520e 2113STATIC void
01f988be 2114validate_suid(char *validarg, char *scriptname, int fdscript)
79072805 2115{
96436eeb
PP
2116 int which;
2117
13281fa4
LW
2118 /* do we need to emulate setuid on scripts? */
2119
2120 /* This code is for those BSD systems that have setuid #! scripts disabled
2121 * in the kernel because of a security problem. Merely defining DOSUID
2122 * in perl will not fix that problem, but if you have disabled setuid
2123 * scripts in the kernel, this will attempt to emulate setuid and setgid
2124 * on scripts that have those now-otherwise-useless bits set. The setuid
27e2fb84
LW
2125 * root version must be called suidperl or sperlN.NNN. If regular perl
2126 * discovers that it has opened a setuid script, it calls suidperl with
2127 * the same argv that it had. If suidperl finds that the script it has
2128 * just opened is NOT setuid root, it sets the effective uid back to the
2129 * uid. We don't just make perl setuid root because that loses the
2130 * effective uid we had before invoking perl, if it was different from the
2131 * uid.
13281fa4
LW
2132 *
2133 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
2134 * be defined in suidperl only. suidperl must be setuid root. The
2135 * Configure script will set this up for you if you want it.
2136 */
a687059c 2137
13281fa4 2138#ifdef DOSUID
ea0efc06 2139 dTHR;
6e72f9df 2140 char *s, *s2;
a0d0e21e 2141
b28d0864 2142 if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0) /* normal stat is insecure */
6b88bc9c 2143 croak("Can't stat script \"%s\"",PL_origfilename);
b28d0864 2144 if (fdscript < 0 && PL_statbuf.st_mode & (S_ISUID|S_ISGID)) {
79072805 2145 I32 len;
2d8e6c8d 2146 STRLEN n_a;
13281fa4 2147
a687059c 2148#ifdef IAMSUID
fe14fcc3 2149#ifndef HAS_SETREUID
a687059c
LW
2150 /* On this access check to make sure the directories are readable,
2151 * there is actually a small window that the user could use to make
2152 * filename point to an accessible directory. So there is a faint
2153 * chance that someone could execute a setuid script down in a
2154 * non-accessible directory. I don't know what to do about that.
2155 * But I don't think it's too important. The manual lies when
2156 * it says access() is useful in setuid programs.
2157 */
6b88bc9c 2158 if (PerlLIO_access(SvPVX(GvSV(PL_curcop->cop_filegv)),1)) /*double check*/
463ee0b2 2159 croak("Permission denied");
a687059c
LW
2160#else
2161 /* If we can swap euid and uid, then we can determine access rights
2162 * with a simple stat of the file, and then compare device and
2163 * inode to make sure we did stat() on the same file we opened.
2164 * Then we just have to make sure he or she can execute it.
2165 */
2166 {
2167 struct stat tmpstatbuf;
2168
85e6fe83
LW
2169 if (
2170#ifdef HAS_SETREUID
b28d0864 2171 setreuid(PL_euid,PL_uid) < 0
a0d0e21e
LW
2172#else
2173# if HAS_SETRESUID
b28d0864 2174 setresuid(PL_euid,PL_uid,(Uid_t)-1) < 0
a0d0e21e 2175# endif
85e6fe83 2176#endif
b28d0864 2177 || PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid)
463ee0b2 2178 croak("Can't swap uid and euid"); /* really paranoid */
6b88bc9c 2179 if (PerlLIO_stat(SvPVX(GvSV(PL_curcop->cop_filegv)),&tmpstatbuf) < 0)
463ee0b2 2180 croak("Permission denied"); /* testing full pathname here */
b28d0864
NIS
2181 if (tmpstatbuf.st_dev != PL_statbuf.st_dev ||
2182 tmpstatbuf.st_ino != PL_statbuf.st_ino) {
2183 (void)PerlIO_close(PL_rsfp);
2184 if (PL_rsfp = PerlProc_popen("/bin/mail root","w")) { /* heh, heh */
2185 PerlIO_printf(PL_rsfp,
ff0cee69
PP
2186"User %ld tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
2187(Filename of set-id script was %s, uid %ld gid %ld.)\n\nSincerely,\nperl\n",
b28d0864
NIS
2188 (long)PL_uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
2189 (long)PL_statbuf.st_dev, (long)PL_statbuf.st_ino,
6b88bc9c 2190 SvPVX(GvSV(PL_curcop->cop_filegv)),
b28d0864
NIS
2191 (long)PL_statbuf.st_uid, (long)PL_statbuf.st_gid);
2192 (void)PerlProc_pclose(PL_rsfp);
a687059c 2193 }
463ee0b2 2194 croak("Permission denied\n");
a687059c 2195 }
85e6fe83
LW
2196 if (
2197#ifdef HAS_SETREUID
b28d0864 2198 setreuid(PL_uid,PL_euid) < 0
a0d0e21e
LW
2199#else
2200# if defined(HAS_SETRESUID)
b28d0864 2201 setresuid(PL_uid,PL_euid,(Uid_t)-1) < 0
a0d0e21e 2202# endif
85e6fe83 2203#endif
b28d0864 2204 || PerlProc_getuid() != PL_uid || PerlProc_geteuid() != PL_euid)
463ee0b2 2205 croak("Can't reswap uid and euid");
b28d0864 2206 if (!cando(S_IXUSR,FALSE,&PL_statbuf)) /* can real uid exec? */
463ee0b2 2207 croak("Permission denied\n");
a687059c 2208 }
fe14fcc3 2209#endif /* HAS_SETREUID */
a687059c
LW
2210#endif /* IAMSUID */
2211
b28d0864 2212 if (!S_ISREG(PL_statbuf.st_mode))
463ee0b2 2213 croak("Permission denied");
b28d0864 2214 if (PL_statbuf.st_mode & S_IWOTH)
463ee0b2 2215 croak("Setuid/gid script is writable by world");
6b88bc9c
GS
2216 PL_doswitches = FALSE; /* -s is insecure in suid */
2217 PL_curcop->cop_line++;
2218 if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch ||
2d8e6c8d 2219 strnNE(SvPV(PL_linestr,n_a),"#!",2) ) /* required even on Sys V */
463ee0b2 2220 croak("No #! line");
2d8e6c8d 2221 s = SvPV(PL_linestr,n_a)+2;
663a0e37 2222 if (*s == ' ') s++;
45d8adaa 2223 while (!isSPACE(*s)) s++;
2d8e6c8d 2224 for (s2 = s; (s2 > SvPV(PL_linestr,n_a)+2 &&
6e72f9df
PP
2225 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
2226 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
463ee0b2 2227 croak("Not a perl script");
a687059c 2228 while (*s == ' ' || *s == '\t') s++;
13281fa4
LW
2229 /*
2230 * #! arg must be what we saw above. They can invoke it by
2231 * mentioning suidperl explicitly, but they may not add any strange
2232 * arguments beyond what #! says if they do invoke suidperl that way.
2233 */
2234 len = strlen(validarg);
2235 if (strEQ(validarg," PHOOEY ") ||
45d8adaa 2236 strnNE(s,validarg,len) || !isSPACE(s[len]))
463ee0b2 2237 croak("Args must match #! line");
a687059c
LW
2238
2239#ifndef IAMSUID
b28d0864
NIS
2240 if (PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) &&
2241 PL_euid == PL_statbuf.st_uid)
2242 if (!PL_do_undump)
463ee0b2 2243 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
a687059c
LW
2244FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2245#endif /* IAMSUID */
13281fa4 2246
b28d0864
NIS
2247 if (PL_euid) { /* oops, we're not the setuid root perl */
2248 (void)PerlIO_close(PL_rsfp);
13281fa4 2249#ifndef IAMSUID
46fc3d4c 2250 /* try again */
6b88bc9c 2251 PerlProc_execv(form("%s/sperl%s", BIN_EXP, PL_patchlevel), PL_origargv);
13281fa4 2252#endif
463ee0b2 2253 croak("Can't do setuid\n");
13281fa4
LW
2254 }
2255
b28d0864 2256 if (PL_statbuf.st_mode & S_ISGID && PL_statbuf.st_gid != PL_egid) {
fe14fcc3 2257#ifdef HAS_SETEGID
b28d0864 2258 (void)setegid(PL_statbuf.st_gid);
a687059c 2259#else
fe14fcc3 2260#ifdef HAS_SETREGID
b28d0864 2261 (void)setregid((Gid_t)-1,PL_statbuf.st_gid);
85e6fe83
LW
2262#else
2263#ifdef HAS_SETRESGID
b28d0864 2264 (void)setresgid((Gid_t)-1,PL_statbuf.st_gid,(Gid_t)-1);
a687059c 2265#else
b28d0864 2266 PerlProc_setgid(PL_statbuf.st_gid);
a687059c
LW
2267#endif
2268#endif
85e6fe83 2269#endif
b28d0864 2270 if (PerlProc_getegid() != PL_statbuf.st_gid)
463ee0b2 2271 croak("Can't do setegid!\n");
83025b21 2272 }
b28d0864
NIS
2273 if (PL_statbuf.st_mode & S_ISUID) {
2274 if (PL_statbuf.st_uid != PL_euid)
fe14fcc3 2275#ifdef HAS_SETEUID
b28d0864 2276 (void)seteuid(PL_statbuf.st_uid); /* all that for this */
a687059c 2277#else
fe14fcc3 2278#ifdef HAS_SETREUID
b28d0864 2279 (void)setreuid((Uid_t)-1,PL_statbuf.st_uid);
85e6fe83
LW
2280#else
2281#ifdef HAS_SETRESUID
b28d0864 2282 (void)setresuid((Uid_t)-1,PL_statbuf.st_uid,(Uid_t)-1);
a687059c 2283#else
b28d0864 2284 PerlProc_setuid(PL_statbuf.st_uid);
a687059c
LW
2285#endif
2286#endif
85e6fe83 2287#endif
b28d0864 2288 if (PerlProc_geteuid() != PL_statbuf.st_uid)
463ee0b2 2289 croak("Can't do seteuid!\n");
a687059c 2290 }
b28d0864 2291 else if (PL_uid) { /* oops, mustn't run as root */
fe14fcc3 2292#ifdef HAS_SETEUID
b28d0864 2293 (void)seteuid((Uid_t)PL_uid);
a687059c 2294#else
fe14fcc3 2295#ifdef HAS_SETREUID
b28d0864 2296 (void)setreuid((Uid_t)-1,(Uid_t)PL_uid);
a687059c 2297#else
85e6fe83 2298#ifdef HAS_SETRESUID
b28d0864 2299 (void)setresuid((Uid_t)-1,(Uid_t)PL_uid,(Uid_t)-1);
85e6fe83 2300#else
b28d0864 2301 PerlProc_setuid((Uid_t)PL_uid);
85e6fe83 2302#endif
a687059c
LW
2303#endif
2304#endif
b28d0864 2305 if (PerlProc_geteuid() != PL_uid)
463ee0b2 2306 croak("Can't do seteuid!\n");
83025b21 2307 }
748a9306 2308 init_ids();
b28d0864 2309 if (!cando(S_IXUSR,TRUE,&PL_statbuf))
463ee0b2 2310 croak("Permission denied\n"); /* they can't do this */
13281fa4
LW
2311 }
2312#ifdef IAMSUID
6b88bc9c 2313 else if (PL_preprocess)
463ee0b2 2314 croak("-P not allowed for setuid/setgid script\n");
96436eeb
PP
2315 else if (fdscript >= 0)
2316 croak("fd script not allowed in suidperl\n");
13281fa4 2317 else
463ee0b2 2318 croak("Script is not setuid/setgid in suidperl\n");
96436eeb
PP
2319
2320 /* We absolutely must clear out any saved ids here, so we */
2321 /* exec the real perl, substituting fd script for scriptname. */
2322 /* (We pass script name as "subdir" of fd, which perl will grok.) */
b28d0864
NIS
2323 PerlIO_rewind(PL_rsfp);
2324 PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0); /* just in case rewind didn't */
6b88bc9c
GS
2325 for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ;
2326 if (!PL_origargv[which])
96436eeb 2327 croak("Permission denied");
6b88bc9c
GS
2328 PL_origargv[which] = savepv(form("/dev/fd/%d/%s",
2329 PerlIO_fileno(PL_rsfp), PL_origargv[which]));
96436eeb 2330#if defined(HAS_FCNTL) && defined(F_SETFD)
b28d0864 2331 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0); /* ensure no close-on-exec */
96436eeb 2332#endif
6b88bc9c 2333 PerlProc_execv(form("%s/perl%s", BIN_EXP, PL_patchlevel), PL_origargv);/* try again */
96436eeb 2334 croak("Can't do setuid\n");
13281fa4 2335#endif /* IAMSUID */
a687059c 2336#else /* !DOSUID */
3280af22 2337 if (PL_euid != PL_uid || PL_egid != PL_gid) { /* (suidperl doesn't exist, in fact) */
a687059c 2338#ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
96827780 2339 dTHR;
b28d0864
NIS
2340 PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf); /* may be either wrapped or real suid */
2341 if ((PL_euid != PL_uid && PL_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
a687059c 2342 ||
b28d0864 2343 (PL_egid != PL_gid && PL_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
a687059c 2344 )
b28d0864 2345 if (!PL_do_undump)
463ee0b2 2346 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
a687059c
LW
2347FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2348#endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
2349 /* not set-id, must be wrapped */
a687059c 2350 }
13281fa4 2351#endif /* DOSUID */
79072805 2352}
13281fa4 2353
76e3520e 2354STATIC void
8ac85365 2355find_beginning(void)
79072805 2356{
6e72f9df 2357 register char *s, *s2;
33b78306
LW
2358
2359 /* skip forward in input to the real script? */
2360
bbce6d69 2361 forbid_setid("-x");
3280af22
NIS
2362 while (PL_doextract) {
2363 if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch)
463ee0b2 2364 croak("No Perl script found in input\n");
6e72f9df 2365 if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
3280af22
NIS
2366 PerlIO_ungetc(PL_rsfp, '\n'); /* to keep line count right */
2367 PL_doextract = FALSE;
6e72f9df
PP
2368 while (*s && !(isSPACE (*s) || *s == '#')) s++;
2369 s2 = s;
2370 while (*s == ' ' || *s == '\t') s++;
2371 if (*s++ == '-') {
2372 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
2373 if (strnEQ(s2-4,"perl",4))
2374 /*SUPPRESS 530*/
2375 while (s = moreswitches(s)) ;
33b78306 2376 }
3280af22
NIS
2377 if (PL_cddir && PerlDir_chdir(PL_cddir) < 0)
2378 croak("Can't chdir to %s",PL_cddir);
83025b21
LW
2379 }
2380 }
2381}
2382
afe37c7d 2383
76e3520e 2384STATIC void
8ac85365 2385init_ids(void)
352d5a3a 2386{
3280af22
NIS
2387 PL_uid = (int)PerlProc_getuid();
2388 PL_euid = (int)PerlProc_geteuid();
2389 PL_gid = (int)PerlProc_getgid();
2390 PL_egid = (int)PerlProc_getegid();
748a9306 2391#ifdef VMS
b28d0864
NIS
2392 PL_uid |= PL_gid << 16;
2393 PL_euid |= PL_egid << 16;
748a9306 2394#endif
3280af22 2395 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
748a9306 2396}
79072805 2397
76e3520e 2398STATIC void
8ac85365 2399forbid_setid(char *s)
bbce6d69 2400{
3280af22 2401 if (PL_euid != PL_uid)
bbce6d69 2402 croak("No %s allowed while running setuid", s);
3280af22 2403 if (PL_egid != PL_gid)
bbce6d69
PP
2404 croak("No %s allowed while running setgid", s);
2405}
2406
76e3520e 2407STATIC void
8ac85365 2408init_debugger(void)
748a9306 2409{
11343788 2410 dTHR;
3280af22
NIS
2411 PL_curstash = PL_debstash;
2412 PL_dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
2413 AvREAL_off(PL_dbargs);
2414 PL_DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2415 PL_DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
2416 PL_DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
2417 PL_DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
2418 sv_setiv(PL_DBsingle, 0);
2419 PL_DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
2420 sv_setiv(PL_DBtrace, 0);
2421 PL_DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
2422 sv_setiv(PL_DBsignal, 0);
2423 PL_curstash = PL_defstash;
352d5a3a
LW
2424}
2425
2ce36478
SM
2426#ifndef STRESS_REALLOC
2427#define REASONABLE(size) (size)
2428#else
2429#define REASONABLE(size) (1) /* unreasonable */
2430#endif
2431
11343788 2432void
8ac85365 2433init_stacks(ARGSproto)
79072805 2434{
e336de0d 2435 /* start with 128-item stack and 8K cxstack */
3280af22 2436 PL_curstackinfo = new_stackinfo(REASONABLE(128),
e336de0d 2437 REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
3280af22
NIS
2438 PL_curstackinfo->si_type = PERLSI_MAIN;
2439 PL_curstack = PL_curstackinfo->si_stack;
2440 PL_mainstack = PL_curstack; /* remember in case we switch stacks */
79072805 2441
3280af22
NIS
2442 PL_stack_base = AvARRAY(PL_curstack);
2443 PL_stack_sp = PL_stack_base;
2444 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
8990e307 2445
3280af22
NIS
2446 New(50,PL_tmps_stack,REASONABLE(128),SV*);
2447 PL_tmps_floor = -1;
2448 PL_tmps_ix = -1;
2449 PL_tmps_max = REASONABLE(128);
8990e307 2450
3280af22
NIS
2451 New(54,PL_markstack,REASONABLE(32),I32);
2452 PL_markstack_ptr = PL_markstack;
2453 PL_markstack_max = PL_markstack + REASONABLE(32);
79072805 2454
e336de0d
GS
2455 SET_MARKBASE;
2456
3280af22
NIS
2457 New(54,PL_scopestack,REASONABLE(32),I32);
2458 PL_scopestack_ix = 0;
2459 PL_scopestack_max = REASONABLE(32);
79072805 2460
3280af22
NIS
2461 New(54,PL_savestack,REASONABLE(128),ANY);
2462 PL_savestack_ix = 0;
2463 PL_savestack_max = REASONABLE(128);
79072805 2464
3280af22
NIS
2465 New(54,PL_retstack,REASONABLE(16),OP*);
2466 PL_retstack_ix = 0;
2467 PL_retstack_max = REASONABLE(16);
378cc40b 2468}
33b78306 2469
2ce36478
SM
2470#undef REASONABLE
2471
76e3520e 2472STATIC void
8ac85365 2473nuke_stacks(void)
6e72f9df 2474{
e858de61 2475 dTHR;
3280af22
NIS
2476 while (PL_curstackinfo->si_next)
2477 PL_curstackinfo = PL_curstackinfo->si_next;
2478 while (PL_curstackinfo) {
2479 PERL_SI *p = PL_curstackinfo->si_prev;
bac4b2ad 2480 /* curstackinfo->si_stack got nuked by sv_free_arenas() */
3280af22
NIS
2481 Safefree(PL_curstackinfo->si_cxstack);
2482 Safefree(PL_curstackinfo);
2483 PL_curstackinfo = p;
e336de0d 2484 }
3280af22
NIS
2485 Safefree(PL_tmps_stack);
2486 Safefree(PL_markstack);
2487 Safefree(PL_scopestack);
2488 Safefree(PL_savestack);
2489 Safefree(PL_retstack);
5f05dabc 2490 DEBUG( {
3280af22
NIS
2491 Safefree(PL_debname);
2492 Safefree(PL_debdelim);
5f05dabc 2493 } )
378cc40b 2494}
33b78306 2495
76e3520e 2496#ifndef PERL_OBJECT
760ac839 2497static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
76e3520e 2498#endif
7aa04957 2499
76e3520e 2500STATIC void
8ac85365 2501init_lexer(void)
8990e307 2502{
76e3520e
GS
2503#ifdef PERL_OBJECT
2504 PerlIO *tmpfp;
2505#endif
3280af22
NIS
2506 tmpfp = PL_rsfp;
2507 PL_rsfp = Nullfp;
2508 lex_start(PL_linestr);
2509 PL_rsfp = tmpfp;
2510 PL_subname = newSVpv("main",4);
8990e307
LW
2511}
2512
76e3520e 2513STATIC void
8ac85365 2514init_predump_symbols(void)
45d8adaa 2515{
11343788 2516 dTHR;
93a17b20 2517 GV *tmpgv;
a0d0e21e 2518 GV *othergv;
79072805 2519
e1c148c2 2520 sv_setpvn(perl_get_sv("\"", TRUE), " ", 1);
3280af22
NIS
2521 PL_stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2522 GvMULTI_on(PL_stdingv);
2523 IoIFP(GvIOp(PL_stdingv)) = PerlIO_stdin();
adbc6bb1 2524 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
a5f75d66 2525 GvMULTI_on(tmpgv);
3280af22 2526 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(PL_stdingv));
79072805 2527
85e6fe83 2528 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
a5f75d66 2529 GvMULTI_on(tmpgv);
760ac839 2530 IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = PerlIO_stdout();
4633a7c4 2531 setdefout(tmpgv);
adbc6bb1 2532 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
a5f75d66 2533 GvMULTI_on(tmpgv);
3280af22 2534 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(PL_defoutgv));
79072805 2535
a0d0e21e 2536 othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
a5f75d66 2537 GvMULTI_on(othergv);
760ac839 2538 IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = PerlIO_stderr();
adbc6bb1 2539 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
a5f75d66 2540 GvMULTI_on(tmpgv);
a0d0e21e 2541 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv));
79072805 2542
3280af22 2543 PL_statname = NEWSV(66,0); /* last filename we did stat on */
ab821d7f 2544
3280af22
NIS
2545 if (!PL_osname)
2546 PL_osname = savepv(OSNAME);
79072805 2547}
33b78306 2548
76e3520e 2549STATIC void
8ac85365 2550init_postdump_symbols(register int argc, register char **argv, register char **env)
33b78306 2551{
a863c7d1 2552 dTHR;
79072805
LW
2553 char *s;
2554 SV *sv;
2555 GV* tmpgv;
fe14fcc3 2556
79072805 2557 argc--,argv++; /* skip name of script */
3280af22 2558 if (PL_doswitches) {
79072805
LW
2559 for (; argc > 0 && **argv == '-'; argc--,argv++) {
2560 if (!argv[0][1])
2561 break;
2562 if (argv[0][1] == '-') {
2563 argc--,argv++;
2564 break;
2565 }
93a17b20 2566 if (s = strchr(argv[0], '=')) {
79072805 2567 *s++ = '\0';
85e6fe83 2568 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
79072805
LW
2569 }
2570 else
85e6fe83 2571 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
fe14fcc3 2572 }
79072805 2573 }
3280af22
NIS
2574 PL_toptarget = NEWSV(0,0);
2575 sv_upgrade(PL_toptarget, SVt_PVFM);
2576 sv_setpvn(PL_toptarget, "", 0);
2577 PL_bodytarget = NEWSV(0,0);
2578 sv_upgrade(PL_bodytarget, SVt_PVFM);
2579 sv_setpvn(PL_bodytarget, "", 0);
2580 PL_formtarget = PL_bodytarget;
79072805 2581
bbce6d69 2582 TAINT;
85e6fe83 2583 if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
3280af22 2584 sv_setpv(GvSV(tmpgv),PL_origfilename);
79072805
LW
2585 magicname("0", "0", 1);
2586 }
85e6fe83 2587 if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
3280af22
NIS
2588 sv_setpv(GvSV(tmpgv),PL_origargv[0]);
2589 if (PL_argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
2590 GvMULTI_on(PL_argvgv);
2591 (void)gv_AVadd(PL_argvgv);
2592 av_clear(GvAVn(PL_argvgv));
79072805 2593 for (; argc > 0; argc--,argv++) {
3280af22 2594 av_push(GvAVn(PL_argvgv),newSVpv(argv[0],0));
79072805
LW
2595 }
2596 }
3280af22 2597 if (PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
79072805 2598 HV *hv;
3280af22
NIS
2599 GvMULTI_on(PL_envgv);
2600 hv = GvHVn(PL_envgv);
2601 hv_magic(hv, PL_envgv, 'E');
a0d0e21e 2602#ifndef VMS /* VMS doesn't have environ array */
4633a7c4
LW
2603 /* Note that if the supplied env parameter is actually a copy
2604 of the global environ then it may now point to free'd memory
2605 if the environment has been modified since. To avoid this
2606 problem we treat env==NULL as meaning 'use the default'
2607 */
2608 if (!env)
2609 env = environ;
5aabfad6 2610 if (env != environ)
79072805
LW
2611 environ[0] = Nullch;
2612 for (; *env; env++) {
93a17b20 2613 if (!(s = strchr(*env,'=')))
79072805
LW
2614 continue;
2615 *s++ = '\0';
60ce6247 2616#if defined(MSDOS)
137443ea
PP
2617 (void)strupr(*env);
2618#endif
79072805
LW
2619 sv = newSVpv(s--,0);
2620 (void)hv_store(hv, *env, s - *env, sv, 0);
2621 *s = '=';
3e3baf6d
TB
2622#if defined(__BORLANDC__) && defined(USE_WIN32_RTL_ENV)
2623 /* Sins of the RTL. See note in my_setenv(). */
76e3520e 2624 (void)PerlEnv_putenv(savepv(*env));
3e3baf6d 2625#endif
fe14fcc3 2626 }
4550b24a
PP
2627#endif
2628#ifdef DYNAMIC_ENV_FETCH
2629 HvNAME(hv) = savepv(ENV_HV_NAME);
2630#endif
79072805 2631 }
bbce6d69 2632 TAINT_NOT;
85e6fe83 2633 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
1e422769 2634 sv_setiv(GvSV(tmpgv), (IV)getpid());
33b78306 2635}
34de22dd 2636
76e3520e 2637STATIC void
8ac85365 2638init_perllib(void)
34de22dd 2639{
85e6fe83 2640 char *s;
3280af22 2641 if (!PL_tainting) {
552a7a9b 2642#ifndef VMS
76e3520e 2643 s = PerlEnv_getenv("PERL5LIB");
85e6fe83 2644 if (s)
774d564b 2645 incpush(s, TRUE);
85e6fe83 2646 else
76e3520e 2647 incpush(PerlEnv_getenv("PERLLIB"), FALSE);
552a7a9b
PP
2648#else /* VMS */
2649 /* Treat PERL5?LIB as a possible search list logical name -- the
2650 * "natural" VMS idiom for a Unix path string. We allow each
2651 * element to be a set of |-separated directories for compatibility.
2652 */
2653 char buf[256];
2654 int idx = 0;
2655 if (my_trnlnm("PERL5LIB",buf,0))
774d564b 2656 do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
552a7a9b 2657 else
774d564b 2658 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
552a7a9b 2659#endif /* VMS */
85e6fe83 2660 }
34de22dd 2661
c90c0ff4 2662/* Use the ~-expanded versions of APPLLIB (undocumented),
dfe9444c 2663 ARCHLIB PRIVLIB SITEARCH and SITELIB
df5cef82 2664*/
4633a7c4 2665#ifdef APPLLIB_EXP
43051805 2666 incpush(APPLLIB_EXP, TRUE);
16d20bd9 2667#endif
4633a7c4 2668
fed7345c 2669#ifdef ARCHLIB_EXP
774d564b 2670 incpush(ARCHLIB_EXP, FALSE);
a0d0e21e 2671#endif
fed7345c
AD
2672#ifndef PRIVLIB_EXP
2673#define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
34de22dd 2674#endif
00dc2f4f
GS
2675#if defined(WIN32)
2676 incpush(PRIVLIB_EXP, TRUE);
2677#else
774d564b 2678 incpush(PRIVLIB_EXP, FALSE);
00dc2f4f 2679#endif
4633a7c4
LW
2680
2681#ifdef SITEARCH_EXP
774d564b 2682 incpush(SITEARCH_EXP, FALSE);
4633a7c4
LW
2683#endif
2684#ifdef SITELIB_EXP
00dc2f4f
GS
2685#if defined(WIN32)
2686 incpush(SITELIB_EXP, TRUE);
2687#else
774d564b 2688 incpush(SITELIB_EXP, FALSE);
4633a7c4 2689#endif
00dc2f4f 2690#endif
3280af22 2691 if (!PL_tainting)
774d564b
PP
2692 incpush(".", FALSE);
2693}
2694
2695#if defined(DOSISH)
2696# define PERLLIB_SEP ';'
2697#else
2698# if defined(VMS)
2699# define PERLLIB_SEP '|'
2700# else
2701# define PERLLIB_SEP ':'
2702# endif
2703#endif
2704#ifndef PERLLIB_MANGLE
2705# define PERLLIB_MANGLE(s,n) (s)
2706#endif
2707
76e3520e 2708STATIC void
8ac85365 2709incpush(char *p, int addsubdirs)
774d564b
PP
2710{
2711 SV *subdir = Nullsv;
774d564b
PP
2712
2713 if (!p)
2714 return;
2715
2716 if (addsubdirs) {
00db4c45 2717 subdir = sv_newmortal();
3280af22
NIS
2718 if (!PL_archpat_auto) {
2719 STRLEN len = (sizeof(ARCHNAME) + strlen(PL_patchlevel)
774d564b 2720 + sizeof("//auto"));
3280af22
NIS
2721 New(55, PL_archpat_auto, len, char);
2722 sprintf(PL_archpat_auto, "/%s/%s/auto", ARCHNAME, PL_patchlevel);
aa689395
PP
2723#ifdef VMS
2724 for (len = sizeof(ARCHNAME) + 2;
6b88bc9c
GS
2725 PL_archpat_auto[len] != '\0' && PL_archpat_auto[len] != '/'; len++)
2726 if (PL_archpat_auto[len] == '.') PL_archpat_auto[len] = '_';
aa689395 2727#endif
774d564b
PP
2728 }
2729 }
2730
2731 /* Break at all separators */
2732 while (p && *p) {
8c52afec 2733 SV *libdir = NEWSV(55,0);
774d564b
PP
2734 char *s;
2735
2736 /* skip any consecutive separators */
2737 while ( *p == PERLLIB_SEP ) {
2738 /* Uncomment the next line for PATH semantics */
6b88bc9c 2739 /* av_push(GvAVn(PL_incgv), newSVpv(".", 1)); */
774d564b
PP
2740 p++;
2741 }
2742
2743 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
2744 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
2745 (STRLEN)(s - p));
2746 p = s + 1;
2747 }
2748 else {
2749 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
2750 p = Nullch; /* break out */
2751 }
2752
2753 /*
2754 * BEFORE pushing libdir onto @INC we may first push version- and
2755 * archname-specific sub-directories.
2756 */
2757 if (addsubdirs) {
2758 struct stat tmpstatbuf;
aa689395
PP
2759#ifdef VMS
2760 char *unix;
2761 STRLEN len;
774d564b 2762
2d8e6c8d 2763 if ((unix = tounixspec_ts(SvPV(libdir,len),Nullch)) != Nullch) {
aa689395
PP
2764 len = strlen(unix);
2765 while (unix[len-1] == '/') len--; /* Cosmetic */
2766 sv_usepvn(libdir,unix,len);
2767 }
2768 else
2769 PerlIO_printf(PerlIO_stderr(),
2770 "Failed to unixify @INC element \"%s\"\n",
2d8e6c8d 2771 SvPV(libdir,len));
aa689395 2772#endif
4fdae800 2773 /* .../archname/version if -d .../archname/version/auto */
774d564b 2774 sv_setsv(subdir, libdir);
3280af22 2775 sv_catpv(subdir, PL_archpat_auto);
76e3520e 2776 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
774d564b 2777 S_ISDIR(tmpstatbuf.st_mode))
3280af22 2778 av_push(GvAVn(PL_incgv),
774d564b
PP
2779 newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2780
4fdae800 2781 /* .../archname if -d .../archname/auto */
774d564b 2782 sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME),
3280af22 2783 strlen(PL_patchlevel) + 1, "", 0);
76e3520e 2784 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
774d564b 2785 S_ISDIR(tmpstatbuf.st_mode))
3280af22 2786 av_push(GvAVn(PL_incgv),
774d564b
PP
2787 newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2788 }
2789
2790 /* finally push this lib directory on the end of @INC */
3280af22 2791 av_push(GvAVn(PL_incgv), libdir);
774d564b 2792 }
34de22dd 2793}
93a17b20 2794
199100c8 2795#ifdef USE_THREADS
76e3520e 2796STATIC struct perl_thread *
199100c8
MB
2797init_main_thread()
2798{
52e1cb5e 2799 struct perl_thread *thr;
199100c8
MB
2800 XPV *xpv;
2801
52e1cb5e 2802 Newz(53, thr, 1, struct perl_thread);
533c011a 2803 PL_curcop = &PL_compiling;
199100c8 2804 thr->cvcache = newHV();
54b9620d 2805 thr->threadsv = newAV();
940cb80d 2806 /* thr->threadsvp is set when find_threadsv is called */
199100c8 2807 thr->specific = newAV();
38a03e6e 2808 thr->errhv = newHV();
199100c8
MB
2809 thr->flags = THRf_R_JOINABLE;
2810 MUTEX_INIT(&thr->mutex);
2811 /* Handcraft thrsv similarly to mess_sv */
533c011a 2812 New(53, PL_thrsv, 1, SV);
199100c8 2813 Newz(53, xpv, 1, XPV);
533c011a
NIS
2814 SvFLAGS(PL_thrsv) = SVt_PV;
2815 SvANY(PL_thrsv) = (void*)xpv;
2816 SvREFCNT(PL_thrsv) = 1 << 30; /* practically infinite */
2817 SvPVX(PL_thrsv) = (char*)thr;
2818 SvCUR_set(PL_thrsv, sizeof(thr));
2819 SvLEN_set(PL_thrsv, sizeof(thr));
2820 *SvEND(PL_thrsv) = '\0'; /* in the trailing_nul field */
2821 thr->oursv = PL_thrsv;
2822 PL_chopset = " \n-";
3967c732 2823 PL_dumpindent = 4;
533c011a
NIS
2824
2825 MUTEX_LOCK(&PL_threads_mutex);
2826 PL_nthreads++;
199100c8
MB
2827 thr->tid = 0;
2828 thr->next = thr;
2829 thr->prev = thr;
533c011a 2830 MUTEX_UNLOCK(&PL_threads_mutex);
199100c8 2831
4b026b9e
GS
2832#ifdef HAVE_THREAD_INTERN
2833 init_thread_intern(thr);
235db74f
GS
2834#endif
2835
2836#ifdef SET_THREAD_SELF
2837 SET_THREAD_SELF(thr);
199100c8
MB
2838#else
2839 thr->self = pthread_self();
235db74f 2840#endif /* SET_THREAD_SELF */
199100c8
MB
2841 SET_THR(thr);
2842
2843 /*
2844 * These must come after the SET_THR because sv_setpvn does
2845 * SvTAINT and the taint fields require dTHR.
2846 */
533c011a
NIS
2847 PL_toptarget = NEWSV(0,0);
2848 sv_upgrade(PL_toptarget, SVt_PVFM);
2849 sv_setpvn(PL_toptarget, "", 0);
2850 PL_bodytarget = NEWSV(0,0);
2851 sv_upgrade(PL_bodytarget, SVt_PVFM);
2852 sv_setpvn(PL_bodytarget, "", 0);
2853 PL_formtarget = PL_bodytarget;
2faa37cc 2854 thr->errsv = newSVpv("", 0);
78857c3c 2855 (void) find_threadsv("@"); /* Ensure $@ is initialised early */
5c0ca799 2856
533c011a
NIS
2857 PL_maxscream = -1;
2858 PL_regcompp = FUNC_NAME_TO_PTR(pregcomp);
2859 PL_regexecp = FUNC_NAME_TO_PTR(regexec_flags);
2860 PL_regindent = 0;
2861 PL_reginterp_cnt = 0;
5c0ca799 2862
199100c8
MB
2863 return thr;
2864}
2865#endif /* USE_THREADS */
2866
93a17b20 2867void
76e3520e 2868call_list(I32 oldscope, AV *paramList)
93a17b20 2869{
11343788 2870 dTHR;
3280af22 2871 line_t oldline = PL_curcop->cop_line;
22921e25
CS
2872 STRLEN len;
2873 dJMPENV;
6224f72b 2874 int ret;
93a17b20 2875
76e3520e
GS
2876 while (AvFILL(paramList) >= 0) {
2877 CV *cv = (CV*)av_shift(paramList);
93a17b20 2878
8990e307 2879 SAVEFREESV(cv);
a0d0e21e 2880
6224f72b
GS
2881 JMPENV_PUSH(ret);
2882 switch (ret) {
2883 case 0: {
38a03e6e 2884 SV* atsv = ERRSV;
3280af22 2885 PUSHMARK(PL_stack_sp);
748a9306 2886 perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
12f917ad 2887 (void)SvPV(atsv, len);
748a9306 2888 if (len) {
54310121 2889 JMPENV_POP;
3280af22
NIS
2890 PL_curcop = &PL_compiling;
2891 PL_curcop->cop_line = oldline;
2892 if (paramList == PL_beginav)
12f917ad 2893 sv_catpv(atsv, "BEGIN failed--compilation aborted");
748a9306 2894 else
12f917ad 2895 sv_catpv(atsv, "END failed--cleanup aborted");
3280af22 2896 while (PL_scopestack_ix > oldscope)
2ae324a7 2897 LEAVE;
12f917ad 2898 croak("%s", SvPVX(atsv));
748a9306 2899 }
a0d0e21e 2900 }
85e6fe83 2901 break;
6224f72b 2902 case 1:
f86702cc 2903 STATUS_ALL_FAILURE;
85e6fe83 2904 /* FALL THROUGH */
6224f72b 2905 case 2:
85e6fe83 2906 /* my_exit() was called */
3280af22 2907 while (PL_scopestack_ix > oldscope)
2ae324a7 2908 LEAVE;
84902520 2909 FREETMPS;
3280af22
NIS
2910 PL_curstash = PL_defstash;
2911 if (PL_endav)
2912 call_list(oldscope, PL_endav);
54310121 2913 JMPENV_POP;
3280af22
NIS
2914 PL_curcop = &PL_compiling;
2915 PL_curcop->cop_line = oldline;
2916 if (PL_statusvalue) {
2917 if (paramList == PL_beginav)
a0d0e21e 2918 croak("BEGIN failed--compilation aborted");
85e6fe83 2919 else
a0d0e21e 2920 croak("END failed--cleanup aborted");
85e6fe83 2921 }
f86702cc 2922 my_exit_jump();
85e6fe83 2923 /* NOTREACHED */
6224f72b 2924 case 3:
3280af22 2925 if (!PL_restartop) {
760ac839 2926 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
a0d0e21e 2927 FREETMPS;
85e6fe83
LW
2928 break;
2929 }
54310121 2930 JMPENV_POP;
3280af22
NIS
2931 PL_curcop = &PL_compiling;
2932 PL_curcop->cop_line = oldline;
6224f72b 2933 JMPENV_JUMP(3);
8990e307 2934 }
54310121 2935 JMPENV_POP;
93a17b20 2936 }
93a17b20 2937}
93a17b20 2938
f86702cc 2939void
8ac85365 2940my_exit(U32 status)
f86702cc 2941{
5dc0d613
MB
2942 dTHR;
2943
8b73bbec 2944 DEBUG_S(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
a863c7d1 2945 thr, (unsigned long) status));
f86702cc
PP
2946 switch (status) {
2947 case 0:
2948 STATUS_ALL_SUCCESS;
2949 break;
2950 case 1:
2951 STATUS_ALL_FAILURE;
2952 break;
2953 default:
2954 STATUS_NATIVE_SET(status);
2955 break;
2956 }
2957 my_exit_jump();
2958}
2959
2960void
8ac85365 2961my_failure_exit(void)
f86702cc
PP
2962{
2963#ifdef VMS
2964 if (vaxc$errno & 1) {
4fdae800
PP
2965 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
2966 STATUS_NATIVE_SET(44);
f86702cc
PP
2967 }
2968 else {
ff0cee69 2969 if (!vaxc$errno && errno) /* unlikely */
4fdae800 2970 STATUS_NATIVE_SET(44);
f86702cc 2971 else
4fdae800 2972 STATUS_NATIVE_SET(vaxc$errno);
f86702cc
PP
2973 }
2974#else
9b599b2a 2975 int exitstatus;
f86702cc
PP
2976 if (errno & 255)
2977 STATUS_POSIX_SET(errno);
9b599b2a
GS
2978 else {
2979 exitstatus = STATUS_POSIX >> 8;
2980 if (exitstatus & 255)
2981 STATUS_POSIX_SET(exitstatus);
2982 else
2983 STATUS_POSIX_SET(255);
2984 }
f86702cc
PP
2985#endif
2986 my_exit_jump();
93a17b20
LW
2987}
2988
76e3520e 2989STATIC void
8ac85365 2990my_exit_jump(void)
f86702cc 2991{
de616352 2992 dTHR;
c09156bb 2993 register PERL_CONTEXT *cx;
f86702cc
PP
2994 I32 gimme;
2995 SV **newsp;
2996
3280af22
NIS
2997 if (PL_e_script) {
2998 SvREFCNT_dec(PL_e_script);
2999 PL_e_script = Nullsv;
f86702cc
PP
3000 }
3001
3280af22 3002 POPSTACK_TO(PL_mainstack);
f86702cc
PP
3003 if (cxstack_ix >= 0) {
3004 if (cxstack_ix > 0)
3005 dounwind(0);
3280af22 3006 POPBLOCK(cx,PL_curpm);
f86702cc
PP
3007 LEAVE;
3008 }
ff0cee69 3009
6224f72b 3010 JMPENV_JUMP(2);
f86702cc 3011}
873ef191 3012
7a5f8e82
DL
3013#ifdef PERL_OBJECT
3014#define NO_XSLOCKS
3015#endif /* PERL_OBJECT */
873ef191
GS
3016
3017#include "XSUB.h"
3018
3019static I32
6224f72b
GS
3020#ifdef PERL_OBJECT
3021read_e_script(CPerlObj *pPerl, int idx, SV *buf_sv, int maxlen)
3022#else
3023read_e_script(int idx, SV *buf_sv, int maxlen)
3024#endif
873ef191
GS
3025{
3026 char *p, *nl;
3280af22 3027 p = SvPVX(PL_e_script);
873ef191 3028 nl = strchr(p, '\n');
3280af22 3029 nl = (nl) ? nl+1 : SvEND(PL_e_script);
7dfe3f66
PM
3030 if (nl-p == 0) {
3031 filter_del(read_e_script);
873ef191 3032 return 0;
7dfe3f66 3033 }
873ef191 3034 sv_catpvn(buf_sv, p, nl-p);
3280af22 3035 sv_chop(PL_e_script, nl);
873ef191
GS
3036 return 1;
3037}
3038
1163b5c4 3039