This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
https://perl5.git.perl.org / perl5.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
It seems that FreeBSD does not like using Perl's malloc
[perl5.git] / perl.c
CommitLineData
a0d0e21e
LW		 1/* perl.c
2 *
be3c0a43 3 * Copyright (c) 1987-2002 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 14#include "EXTERN.h"
864dbfa3 15#define PERL_IN_PERL_C
378cc40b 16#include "perl.h"
e3321bb0 17#include "patchlevel.h" /* for local_patches */
378cc40b 18
df5cef82 19/* XXX If this causes problems, set i_unistd=undef in the hint file. */
a0d0e21e
LW		 20#ifdef I_UNISTD
21#include <unistd.h>
22#endif
a0d0e21e 23
7114a2d2 24#if !defined(STANDARD_C) && !defined(HAS_GETENV_PROTOTYPE) && !defined(PERL_MICRO)
20ce7b12 25char *getenv (char *); /* Usually in <stdlib.h> */
54310121 26#endif
27
acfe0abc 28static I32 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen);
0cb96387 29
a687059c
LW		 30#ifdef IAMSUID
31#ifndef DOSUID
32#define DOSUID
33#endif
34#endif
378cc40b 35
a687059c
LW		 36#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
37#ifdef DOSUID
38#undef DOSUID
39#endif
40#endif
8d063cd8 41
4d1ff10f 42#if defined(USE_5005THREADS)
06d86050
GS		 43# define INIT_TLS_AND_INTERP \
44 STMT_START { \
45 if (!PL_curinterp) { \
46 PERL_SET_INTERP(my_perl); \
47 INIT_THREADS; \
48 ALLOC_THREAD_KEY; \
49 } \
50 } STMT_END
51#else
52# if defined(USE_ITHREADS)
53# define INIT_TLS_AND_INTERP \
54 STMT_START { \
55 if (!PL_curinterp) { \
56 PERL_SET_INTERP(my_perl); \
57 INIT_THREADS; \
58 ALLOC_THREAD_KEY; \
534825c4
GS		 59 PERL_SET_THX(my_perl); \
60 OP_REFCNT_INIT; \
61 } \
62 else { \
63 PERL_SET_THX(my_perl); \
06d86050 64 } \
06d86050
GS		 65 } STMT_END
66# else
67# define INIT_TLS_AND_INTERP \
68 STMT_START { \
69 if (!PL_curinterp) { \
70 PERL_SET_INTERP(my_perl); \
71 } \
72 PERL_SET_THX(my_perl); \
73 } STMT_END
74# endif
75#endif
76
32e30700
GS		 77#ifdef PERL_IMPLICIT_SYS
78PerlInterpreter *
7766f137
GS		 79perl_alloc_using(struct IPerlMem* ipM, struct IPerlMem* ipMS,
80 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
32e30700
GS		 81 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
82 struct IPerlDir* ipD, struct IPerlSock* ipS,
83 struct IPerlProc* ipP)
84{
85 PerlInterpreter *my_perl;
32e30700
GS		 86 /* New() needs interpreter, so call malloc() instead */
87 my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
06d86050 88 INIT_TLS_AND_INTERP;
32e30700
GS		 89 Zero(my_perl, 1, PerlInterpreter);
90 PL_Mem = ipM;
7766f137
GS		 91 PL_MemShared = ipMS;
92 PL_MemParse = ipMP;
32e30700
GS		 93 PL_Env = ipE;
94 PL_StdIO = ipStd;
95 PL_LIO = ipLIO;
96 PL_Dir = ipD;
97 PL_Sock = ipS;
98 PL_Proc = ipP;
7766f137 99
32e30700
GS		 100 return my_perl;
101}
102#else
954c1994
GS		 103
104/*
ccfc67b7
JH		 105=head1 Embedding Functions
106
954c1994
GS		 107=for apidoc perl_alloc
108
109Allocates a new Perl interpreter. See L<perlembed>.
110
111=cut
112*/
113
93a17b20 114PerlInterpreter *
cea2e8a9 115perl_alloc(void)
79072805 116{
cea2e8a9 117 PerlInterpreter *my_perl;
35d7cf2c
JH		 118#ifdef USE_5005THREADS
119 dTHX;
120#endif
79072805 121
54aff467 122 /* New() needs interpreter, so call malloc() instead */
e8ee3774 123 my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
ba869deb 124
06d86050 125 INIT_TLS_AND_INTERP;
dedcbb81 126 Zero(my_perl, 1, PerlInterpreter);
cea2e8a9 127 return my_perl;
79072805 128}
32e30700 129#endif /* PERL_IMPLICIT_SYS */
79072805 130
954c1994
GS		 131/*
132=for apidoc perl_construct
133
134Initializes a new Perl interpreter. See L<perlembed>.
135
136=cut
137*/
138
79072805 139void
0cb96387 140perl_construct(pTHXx)
79072805 141{
4d1ff10f 142#ifdef USE_5005THREADS
a863c7d1 143#ifndef FAKE_THREADS
e1f15930 144 struct perl_thread *thr = NULL;
a863c7d1 145#endif /* FAKE_THREADS */
4d1ff10f 146#endif /* USE_5005THREADS */
ba869deb 147
8990e307 148#ifdef MULTIPLICITY
54aff467 149 init_interp();
ac27b0f5 150 PL_perl_destruct_level = 1;
54aff467
GS		 151#else
152 if (PL_perl_destruct_level > 0)
153 init_interp();
154#endif
155
33f46ff6 156 /* Init the real globals (and main thread)? */
3280af22 157 if (!PL_linestr) {
4d1ff10f 158#ifdef USE_5005THREADS
533c011a 159 MUTEX_INIT(&PL_sv_mutex);
a863c7d1
MB		 160 /*
161 * Safe to use basic SV functions from now on (though
162 * not things like mortals or tainting yet).
163 */
533c011a
NIS		 164 MUTEX_INIT(&PL_eval_mutex);
165 COND_INIT(&PL_eval_cond);
166 MUTEX_INIT(&PL_threads_mutex);
167 COND_INIT(&PL_nthreads_cond);
ba869deb 168# ifdef EMULATE_ATOMIC_REFCOUNTS
533c011a 169 MUTEX_INIT(&PL_svref_mutex);
ba869deb 170# endif /* EMULATE_ATOMIC_REFCOUNTS */
a863c7d1 171
5ff3f7a4 172 MUTEX_INIT(&PL_cred_mutex);
3d35f11b
GS		 173 MUTEX_INIT(&PL_sv_lock_mutex);
174 MUTEX_INIT(&PL_fdpid_mutex);
5ff3f7a4 175
199100c8 176 thr = init_main_thread();
4d1ff10f 177#endif /* USE_5005THREADS */
11343788 178
14dd3ad8 179#ifdef PERL_FLEXIBLE_EXCEPTIONS
0b94c7bb 180 PL_protect = MEMBER_TO_FPTR(Perl_default_protect); /* for exceptions */
14dd3ad8 181#endif
312caa8e 182
2aea9f8a
GS		 183 PL_curcop = &PL_compiling; /* needed by ckWARN, right away */
184
3280af22
NIS		 185 PL_linestr = NEWSV(65,79);
186 sv_upgrade(PL_linestr,SVt_PVIV);
79072805 187
3280af22 188 if (!SvREADONLY(&PL_sv_undef)) {
d689ffdd
JP		 189 /* set read-only and try to insure than we wont see REFCNT==0
190 very often */
191
3280af22
NIS		 192 SvREADONLY_on(&PL_sv_undef);
193 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
79072805 194
3280af22
NIS		 195 sv_setpv(&PL_sv_no,PL_No);
196 SvNV(&PL_sv_no);
197 SvREADONLY_on(&PL_sv_no);
198 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
79072805 199
3280af22
NIS		 200 sv_setpv(&PL_sv_yes,PL_Yes);
201 SvNV(&PL_sv_yes);
202 SvREADONLY_on(&PL_sv_yes);
203 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
6e72f9df 204 }
79072805 205
cea2e8a9 206 PL_sighandlerp = Perl_sighandler;
3280af22 207 PL_pidstatus = newHV();
79072805
LW		 208 }
209
8bfdd7d9 210 PL_rs = newSVpvn("\n", 1);
dc92893f 211
cea2e8a9 212 init_stacks();
79072805 213
748a9306 214 init_ids();
3280af22 215 PL_lex_state = LEX_NOTPARSING;
a5f75d66 216
312caa8e 217 JMPENV_BOOTSTRAP;
f86702cc 218 STATUS_ALL_SUCCESS;
219
0672f40e 220 init_i18nl10n(1);
36477c24 221 SET_NUMERIC_STANDARD();
0b5b802d 222
a7cb1f99
GS		 223 {
224 U8 *s;
225 PL_patchlevel = NEWSV(0,4);
155aba94 226 (void)SvUPGRADE(PL_patchlevel, SVt_PVNV);
a7cb1f99 227 if (PERL_REVISION > 127 || PERL_VERSION > 127 || PERL_SUBVERSION > 127)
806e7201 228 SvGROW(PL_patchlevel, UTF8_MAXLEN*3+1);
a7cb1f99 229 s = (U8*)SvPVX(PL_patchlevel);
9041c2e3
NIS		 230 /* Build version strings using "native" characters */
231 s = uvchr_to_utf8(s, (UV)PERL_REVISION);
232 s = uvchr_to_utf8(s, (UV)PERL_VERSION);
233 s = uvchr_to_utf8(s, (UV)PERL_SUBVERSION);
a7cb1f99
GS		 234 *s = '\0';
235 SvCUR_set(PL_patchlevel, s - (U8*)SvPVX(PL_patchlevel));
236 SvPOK_on(PL_patchlevel);
237 SvNVX(PL_patchlevel) = (NV)PERL_REVISION
238 + ((NV)PERL_VERSION / (NV)1000)
cceca5ed 239#if defined(PERL_SUBVERSION) && PERL_SUBVERSION > 0
a7cb1f99 240 + ((NV)PERL_SUBVERSION / (NV)1000000)
a5f75d66 241#endif
a7cb1f99
GS		 242 ;
243 SvNOK_on(PL_patchlevel); /* dual valued */
244 SvUTF8_on(PL_patchlevel);
245 SvREADONLY_on(PL_patchlevel);
246 }
79072805 247
ab821d7f 248#if defined(LOCAL_PATCH_COUNT)
3280af22 249 PL_localpatches = local_patches; /* For possible -v */
ab821d7f 250#endif
251
52853b95
GS		 252#ifdef HAVE_INTERP_INTERN
253 sys_intern_init();
254#endif
255
3a1ee7e8 256 PerlIO_init(aTHX); /* Hook to IO system */
760ac839 257
3280af22
NIS		 258 PL_fdpid = newAV(); /* for remembering popen pids by fd */
259 PL_modglobal = newHV(); /* pointers to per-interpreter module globals */
24944567 260 PL_errors = newSVpvn("",0);
48c6b404 261 sv_setpvn(PERL_DEBUG_PAD(0), "", 0); /* For regex debugging. */
1f483ca1
JH		 262 sv_setpvn(PERL_DEBUG_PAD(1), "", 0); /* ext/re needs these */
263 sv_setpvn(PERL_DEBUG_PAD(2), "", 0); /* even without DEBUGGING. */
1fcf4c12 264#ifdef USE_ITHREADS
13137afc
AB		 265 PL_regex_padav = newAV();
266 av_push(PL_regex_padav,(SV*)newAV()); /* First entry is an array of empty elements */
267 PL_regex_pad = AvARRAY(PL_regex_padav);
1fcf4c12 268#endif
e5dd39fc 269#ifdef USE_REENTRANT_API
59bd0823 270 Perl_reentrant_init(aTHX);
e5dd39fc 271#endif
3d47000e
AB		 272
273 /* Note that strtab is a rather special HV. Assumptions are made
274 about not iterating on it, and not adding tie magic to it.
275 It is properly deallocated in perl_destruct() */
276 PL_strtab = newHV();
277
278#ifdef USE_5005THREADS
279 MUTEX_INIT(&PL_strtab_mutex);
280#endif
281 HvSHAREKEYS_off(PL_strtab); /* mandatory */
282 hv_ksplit(PL_strtab, 512);
283
0631ea03
AB		 284#if defined(__DYNAMIC__) && (defined(NeXT) || defined(__NeXT__))
285 _dyld_lookup_and_bind
286 ("__environ", (unsigned long *) &environ_pointer, NULL);
287#endif /* environ */
288
289#ifdef USE_ENVIRON_ARRAY
290 PL_origenviron = environ;
291#endif
292
8990e307 293 ENTER;
79072805
LW		 294}
295
954c1994
GS		 296/*
297=for apidoc perl_destruct
298
299Shuts down a Perl interpreter. See L<perlembed>.
300
301=cut
302*/
303
31d77e54 304int
0cb96387 305perl_destruct(pTHXx)
79072805 306{
7c474504 307 volatile int destruct_level; /* 0=none, 1=full, 2=full with checks */
a0d0e21e 308 HV *hv;
4d1ff10f 309#ifdef USE_5005THREADS
33f46ff6 310 Thread t;
cea2e8a9 311 dTHX;
4d1ff10f 312#endif /* USE_5005THREADS */
8990e307 313
7766f137
GS		 314 /* wait for all pseudo-forked children to finish */
315 PERL_WAIT_FOR_CHILDREN;
316
4d1ff10f 317#ifdef USE_5005THREADS
0f15f207 318#ifndef FAKE_THREADS
8023c3ce
MB		 319 /* Pass 1 on any remaining threads: detach joinables, join zombies */
320 retry_cleanup:
533c011a 321 MUTEX_LOCK(&PL_threads_mutex);
bf49b057 322 DEBUG_S(PerlIO_printf(Perl_debug_log,
c7848ba1 323 "perl_destruct: waiting for %d threads...\n",
533c011a 324 PL_nthreads - 1));
33f46ff6 325 for (t = thr->next; t != thr; t = t->next) {
605e5515
MB		 326 MUTEX_LOCK(&t->mutex);
327 switch (ThrSTATE(t)) {
328 AV *av;
c7848ba1 329 case THRf_ZOMBIE:
bf49b057 330 DEBUG_S(PerlIO_printf(Perl_debug_log,
c7848ba1 331 "perl_destruct: joining zombie %p\n", t));
605e5515
MB		 332 ThrSETSTATE(t, THRf_DEAD);
333 MUTEX_UNLOCK(&t->mutex);
533c011a 334 PL_nthreads--;
8023c3ce
MB		 335 /*
336 * The SvREFCNT_dec below may take a long time (e.g. av
337 * may contain an object scalar whose destructor gets
338 * called) so we have to unlock threads_mutex and start
339 * all over again.
340 */
533c011a 341 MUTEX_UNLOCK(&PL_threads_mutex);
ea0efc06 342 JOIN(t, &av);
605e5515 343 SvREFCNT_dec((SV*)av);
bf49b057 344 DEBUG_S(PerlIO_printf(Perl_debug_log,
c7848ba1 345 "perl_destruct: joined zombie %p OK\n", t));
8023c3ce 346 goto retry_cleanup;
c7848ba1 347 case THRf_R_JOINABLE:
bf49b057 348 DEBUG_S(PerlIO_printf(Perl_debug_log,
c7848ba1
MB		 349 "perl_destruct: detaching thread %p\n", t));
350 ThrSETSTATE(t, THRf_R_DETACHED);
ac27b0f5 351 /*
c7848ba1
MB		 352 * We unlock threads_mutex and t->mutex in the opposite order
353 * from which we locked them just so that DETACH won't
354 * deadlock if it panics. It's only a breach of good style
355 * not a bug since they are unlocks not locks.
356 */
533c011a 357 MUTEX_UNLOCK(&PL_threads_mutex);
c7848ba1
MB		 358 DETACH(t);
359 MUTEX_UNLOCK(&t->mutex);
8023c3ce 360 goto retry_cleanup;
c7848ba1 361 default:
bf49b057 362 DEBUG_S(PerlIO_printf(Perl_debug_log,
c7848ba1
MB		 363 "perl_destruct: ignoring %p (state %u)\n",
364 t, ThrSTATE(t)));
365 MUTEX_UNLOCK(&t->mutex);
c7848ba1 366 /* fall through and out */
33f46ff6
MB		 367 }
368 }
8023c3ce
MB		 369 /* We leave the above "Pass 1" loop with threads_mutex still locked */
370
371 /* Pass 2 on remaining threads: wait for the thread count to drop to one */
533c011a 372 while (PL_nthreads > 1)
11343788 373 {
bf49b057 374 DEBUG_S(PerlIO_printf(Perl_debug_log,
c7848ba1 375 "perl_destruct: final wait for %d threads\n",
533c011a
NIS		 376 PL_nthreads - 1));
377 COND_WAIT(&PL_nthreads_cond, &PL_threads_mutex);
11343788
MB		 378 }
379 /* At this point, we're the last thread */
533c011a 380 MUTEX_UNLOCK(&PL_threads_mutex);
bf49b057 381 DEBUG_S(PerlIO_printf(Perl_debug_log, "perl_destruct: armageddon has arrived\n"));
533c011a
NIS		 382 MUTEX_DESTROY(&PL_threads_mutex);
383 COND_DESTROY(&PL_nthreads_cond);
b57a092c 384 PL_nthreads--;
0f15f207 385#endif /* !defined(FAKE_THREADS) */
4d1ff10f 386#endif /* USE_5005THREADS */
11343788 387
3280af22 388 destruct_level = PL_perl_destruct_level;
4633a7c4
LW		 389#ifdef DEBUGGING
390 {
391 char *s;
155aba94 392 if ((s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL"))) {
5f05dabc 393 int i = atoi(s);
394 if (destruct_level < i)
395 destruct_level = i;
396 }
4633a7c4
LW		 397 }
398#endif
399
31d77e54
AB		 400
401 if(PL_exit_flags & PERL_EXIT_DESTRUCT_END) {
f3faeb53
AB		 402 dJMPENV;
403 int x = 0;
404
405 JMPENV_PUSH(x);
406 if (PL_endav && !PL_minus_c)
407 call_list(PL_scopestack_ix, PL_endav);
408 JMPENV_POP;
26f423df 409 }
f3faeb53 410 LEAVE;
a0d0e21e
LW		 411 FREETMPS;
412
ff0cee69 413 /* We must account for everything. */
414
415 /* Destroy the main CV and syntax tree */
3280af22
NIS		 416 if (PL_main_root) {
417 PL_curpad = AvARRAY(PL_comppad);
418 op_free(PL_main_root);
419 PL_main_root = Nullop;
a0d0e21e 420 }
3280af22
NIS		 421 PL_curcop = &PL_compiling;
422 PL_main_start = Nullop;
423 SvREFCNT_dec(PL_main_cv);
424 PL_main_cv = Nullcv;
24d3c518 425 PL_dirty = TRUE;
ff0cee69 426
13621cfb
NIS		 427 /* Tell PerlIO we are about to tear things apart in case
428 we have layers which are using resources that should
429 be cleaned up now.
430 */
431
432 PerlIO_destruct(aTHX);
433
3280af22 434 if (PL_sv_objcount) {
a0d0e21e
LW		 435 /*
436 * Try to destruct global references. We do this first so that the
437 * destructors and destructees still exist. Some sv's might remain.
438 * Non-referenced objects are on their own.
439 */
a0d0e21e 440 sv_clean_objs();
8990e307
LW		 441 }
442
5cd24f17 443 /* unhook hooks which will soon be, or use, destroyed data */
3280af22
NIS		 444 SvREFCNT_dec(PL_warnhook);
445 PL_warnhook = Nullsv;
446 SvREFCNT_dec(PL_diehook);
447 PL_diehook = Nullsv;
5cd24f17 448
4b556e6c 449 /* call exit list functions */
3280af22 450 while (PL_exitlistlen-- > 0)
acfe0abc 451 PL_exitlist[PL_exitlistlen].fn(aTHX_ PL_exitlist[PL_exitlistlen].ptr);
4b556e6c 452
3280af22 453 Safefree(PL_exitlist);
4b556e6c 454
a0d0e21e 455 if (destruct_level == 0){
8990e307 456
a0d0e21e 457 DEBUG_P(debprofdump());
ac27b0f5 458
56a2bab7
NIS		 459#if defined(PERLIO_LAYERS)
460 /* No more IO - including error messages ! */
461 PerlIO_cleanup(aTHX);
462#endif
463
a0d0e21e 464 /* The exit() function will do everything that needs doing. */
31d77e54 465 return STATUS_NATIVE_EXPORT;;
a0d0e21e 466 }
5dd60ef7 467
551a8b83 468 /* jettison our possibly duplicated environment */
4b647fb0
DM		 469 /* if PERL_USE_SAFE_PUTENV is defined environ will not have been copied
470 * so we certainly shouldn't free it here
471 */
472#if defined(USE_ENVIRON_ARRAY) && !defined(PERL_USE_SAFE_PUTENV)
551a8b83
JH		 473 if (environ != PL_origenviron) {
474 I32 i;
475
476 for (i = 0; environ[i]; i++)
4b420006 477 safesysfree(environ[i]);
0631ea03 478
4b420006
JH		 479 /* Must use safesysfree() when working with environ. */
480 safesysfree(environ);
551a8b83
JH		 481
482 environ = PL_origenviron;
483 }
484#endif
485
5f8cb046
DM		 486#ifdef USE_ITHREADS
487 /* the syntax tree is shared between clones
488 * so op_free(PL_main_root) only ReREFCNT_dec's
489 * REGEXPs in the parent interpreter
490 * we need to manually ReREFCNT_dec for the clones
491 */
492 {
493 I32 i = AvFILLp(PL_regex_padav) + 1;
494 SV **ary = AvARRAY(PL_regex_padav);
495
496 while (i) {
35061a7e 497 SV *resv = ary[--i];
ba89bb6e 498 REGEXP *re = INT2PTR(REGEXP *,SvIVX(resv));
35061a7e
DM		 499
500 if (SvFLAGS(resv) & SVf_BREAK) {
577e12cc 501 /* this is PL_reg_curpm, already freed
35061a7e
DM		 502 * flag is set in regexec.c:S_regtry
503 */
504 SvFLAGS(resv) &= ~SVf_BREAK;
3a1ee7e8 505 }
1cc8b4c5
AB		 506 else if(SvREPADTMP(resv)) {
507 SvREPADTMP_off(resv);
508 }
35061a7e 509 else {
5f8cb046
DM		 510 ReREFCNT_dec(re);
511 }
512 }
513 }
514 SvREFCNT_dec(PL_regex_padav);
515 PL_regex_padav = Nullav;
516 PL_regex_pad = NULL;
517#endif
518
5f05dabc 519 /* loosen bonds of global variables */
520
3280af22
NIS		 521 if(PL_rsfp) {
522 (void)PerlIO_close(PL_rsfp);
523 PL_rsfp = Nullfp;
8ebc5c01 524 }
525
526 /* Filters for program text */
3280af22
NIS		 527 SvREFCNT_dec(PL_rsfp_filters);
528 PL_rsfp_filters = Nullav;
8ebc5c01 529
530 /* switches */
3280af22
NIS		 531 PL_preprocess = FALSE;
532 PL_minus_n = FALSE;
533 PL_minus_p = FALSE;
534 PL_minus_l = FALSE;
535 PL_minus_a = FALSE;
536 PL_minus_F = FALSE;
537 PL_doswitches = FALSE;
599cee73 538 PL_dowarn = G_WARN_OFF;
3280af22
NIS		 539 PL_doextract = FALSE;
540 PL_sawampersand = FALSE; /* must save all match strings */
3280af22
NIS		 541 PL_unsafe = FALSE;
542
543 Safefree(PL_inplace);
544 PL_inplace = Nullch;
a7cb1f99 545 SvREFCNT_dec(PL_patchlevel);
3280af22
NIS		 546
547 if (PL_e_script) {
548 SvREFCNT_dec(PL_e_script);
549 PL_e_script = Nullsv;
8ebc5c01 550 }
551
bc0a45ed
DM		 552 while (--PL_origargc >= 0) {
553 Safefree(PL_origargv[PL_origargc]);
554 }
555 Safefree(PL_origargv);
556
8ebc5c01 557 /* magical thingies */
558
7889fe52
NIS		 559 SvREFCNT_dec(PL_ofs_sv); /* $, */
560 PL_ofs_sv = Nullsv;
5f05dabc 561
7889fe52
NIS		 562 SvREFCNT_dec(PL_ors_sv); /* $\ */
563 PL_ors_sv = Nullsv;
8ebc5c01 564
3280af22
NIS		 565 SvREFCNT_dec(PL_rs); /* $/ */
566 PL_rs = Nullsv;
dc92893f 567
d33b2eba
GS		 568 PL_multiline = 0; /* $* */
569 Safefree(PL_osname); /* $^O */
570 PL_osname = Nullch;
5f05dabc 571
3280af22
NIS		 572 SvREFCNT_dec(PL_statname);
573 PL_statname = Nullsv;
574 PL_statgv = Nullgv;
5f05dabc 575
8ebc5c01 576 /* defgv, aka *_ should be taken care of elsewhere */
577
8ebc5c01 578 /* clean up after study() */
3280af22
NIS		 579 SvREFCNT_dec(PL_lastscream);
580 PL_lastscream = Nullsv;
581 Safefree(PL_screamfirst);
582 PL_screamfirst = 0;
583 Safefree(PL_screamnext);
584 PL_screamnext = 0;
8ebc5c01 585
7d5ea4e7
GS		 586 /* float buffer */
587 Safefree(PL_efloatbuf);
588 PL_efloatbuf = Nullch;
589 PL_efloatsize = 0;
590
8ebc5c01 591 /* startup and shutdown function lists */
3280af22 592 SvREFCNT_dec(PL_beginav);
5a837c8f 593 SvREFCNT_dec(PL_beginav_save);
3280af22 594 SvREFCNT_dec(PL_endav);
7d30b5c4 595 SvREFCNT_dec(PL_checkav);
3280af22
NIS		 596 SvREFCNT_dec(PL_initav);
597 PL_beginav = Nullav;
5a837c8f 598 PL_beginav_save = Nullav;
3280af22 599 PL_endav = Nullav;
7d30b5c4 600 PL_checkav = Nullav;
3280af22 601 PL_initav = Nullav;
5618dfe8 602
8ebc5c01 603 /* shortcuts just get cleared */
3280af22 604 PL_envgv = Nullgv;
3280af22
NIS		 605 PL_incgv = Nullgv;
606 PL_hintgv = Nullgv;
607 PL_errgv = Nullgv;
608 PL_argvgv = Nullgv;
609 PL_argvoutgv = Nullgv;
610 PL_stdingv = Nullgv;
bf49b057 611 PL_stderrgv = Nullgv;
3280af22
NIS		 612 PL_last_in_gv = Nullgv;
613 PL_replgv = Nullgv;
5c831c24 614 PL_debstash = Nullhv;
8ebc5c01 615
616 /* reset so print() ends up where we expect */
617 setdefout(Nullgv);
5c831c24 618
7a1c5554
GS		 619 SvREFCNT_dec(PL_argvout_stack);
620 PL_argvout_stack = Nullav;
8ebc5c01 621
5c831c24
GS		 622 SvREFCNT_dec(PL_modglobal);
623 PL_modglobal = Nullhv;
624 SvREFCNT_dec(PL_preambleav);
625 PL_preambleav = Nullav;
626 SvREFCNT_dec(PL_subname);
627 PL_subname = Nullsv;
628 SvREFCNT_dec(PL_linestr);
629 PL_linestr = Nullsv;
630 SvREFCNT_dec(PL_pidstatus);
631 PL_pidstatus = Nullhv;
632 SvREFCNT_dec(PL_toptarget);
633 PL_toptarget = Nullsv;
634 SvREFCNT_dec(PL_bodytarget);
635 PL_bodytarget = Nullsv;
636 PL_formtarget = Nullsv;
637
d33b2eba 638 /* free locale stuff */
b9582b6a 639#ifdef USE_LOCALE_COLLATE
d33b2eba
GS		 640 Safefree(PL_collation_name);
641 PL_collation_name = Nullch;
b9582b6a 642#endif
d33b2eba 643
b9582b6a 644#ifdef USE_LOCALE_NUMERIC
d33b2eba
GS		 645 Safefree(PL_numeric_name);
646 PL_numeric_name = Nullch;
a453c169 647 SvREFCNT_dec(PL_numeric_radix_sv);
b9582b6a 648#endif
d33b2eba 649
5c831c24
GS		 650 /* clear utf8 character classes */
651 SvREFCNT_dec(PL_utf8_alnum);
652 SvREFCNT_dec(PL_utf8_alnumc);
653 SvREFCNT_dec(PL_utf8_ascii);
654 SvREFCNT_dec(PL_utf8_alpha);
655 SvREFCNT_dec(PL_utf8_space);
656 SvREFCNT_dec(PL_utf8_cntrl);
657 SvREFCNT_dec(PL_utf8_graph);
658 SvREFCNT_dec(PL_utf8_digit);
659 SvREFCNT_dec(PL_utf8_upper);
660 SvREFCNT_dec(PL_utf8_lower);
661 SvREFCNT_dec(PL_utf8_print);
662 SvREFCNT_dec(PL_utf8_punct);
663 SvREFCNT_dec(PL_utf8_xdigit);
664 SvREFCNT_dec(PL_utf8_mark);
665 SvREFCNT_dec(PL_utf8_toupper);
4dbdbdc2 666 SvREFCNT_dec(PL_utf8_totitle);
5c831c24 667 SvREFCNT_dec(PL_utf8_tolower);
b4e400f9 668 SvREFCNT_dec(PL_utf8_tofold);
5c831c24
GS		 669 PL_utf8_alnum = Nullsv;
670 PL_utf8_alnumc = Nullsv;
671 PL_utf8_ascii = Nullsv;
672 PL_utf8_alpha = Nullsv;
673 PL_utf8_space = Nullsv;
674 PL_utf8_cntrl = Nullsv;
675 PL_utf8_graph = Nullsv;
676 PL_utf8_digit = Nullsv;
677 PL_utf8_upper = Nullsv;
678 PL_utf8_lower = Nullsv;
679 PL_utf8_print = Nullsv;
680 PL_utf8_punct = Nullsv;
681 PL_utf8_xdigit = Nullsv;
682 PL_utf8_mark = Nullsv;
683 PL_utf8_toupper = Nullsv;
684 PL_utf8_totitle = Nullsv;
685 PL_utf8_tolower = Nullsv;
b4e400f9 686 PL_utf8_tofold = Nullsv;
5c831c24 687
971a9dd3
GS		 688 if (!specialWARN(PL_compiling.cop_warnings))
689 SvREFCNT_dec(PL_compiling.cop_warnings);
5c831c24 690 PL_compiling.cop_warnings = Nullsv;
ac27b0f5
NIS		 691 if (!specialCopIO(PL_compiling.cop_io))
692 SvREFCNT_dec(PL_compiling.cop_io);
693 PL_compiling.cop_io = Nullsv;
05ec9bb3
NIS		 694 CopFILE_free(&PL_compiling);
695 CopSTASH_free(&PL_compiling);
5c831c24 696
a0d0e21e 697 /* Prepare to destruct main symbol table. */
5f05dabc 698
3280af22
NIS		 699 hv = PL_defstash;
700 PL_defstash = 0;
a0d0e21e 701 SvREFCNT_dec(hv);
5c831c24
GS		 702 SvREFCNT_dec(PL_curstname);
703 PL_curstname = Nullsv;
a0d0e21e 704
5a844595
GS		 705 /* clear queued errors */
706 SvREFCNT_dec(PL_errors);
707 PL_errors = Nullsv;
708
a0d0e21e 709 FREETMPS;
0453d815 710 if (destruct_level >= 2 && ckWARN_d(WARN_INTERNAL)) {
3280af22 711 if (PL_scopestack_ix != 0)
9014280d 712 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
0453d815 713 "Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
3280af22
NIS		 714 (long)PL_scopestack_ix);
715 if (PL_savestack_ix != 0)
9014280d 716 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
0453d815 717 "Unbalanced saves: %ld more saves than restores\n",
3280af22
NIS		 718 (long)PL_savestack_ix);
719 if (PL_tmps_floor != -1)
9014280d 720 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced tmps: %ld more allocs than frees\n",
3280af22 721 (long)PL_tmps_floor + 1);
a0d0e21e 722 if (cxstack_ix != -1)
9014280d 723 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced context: %ld more PUSHes than POPs\n",
ff0cee69 724 (long)cxstack_ix + 1);
a0d0e21e 725 }
8990e307
LW		 726
727 /* Now absolutely destruct everything, somehow or other, loops or no. */
d33b2eba 728 SvFLAGS(PL_fdpid) |= SVTYPEMASK; /* don't clean out pid table now */
3280af22 729 SvFLAGS(PL_strtab) |= SVTYPEMASK; /* don't clean out strtab now */
5226ed68
JH		 730
731 /* the 2 is for PL_fdpid and PL_strtab */
732 while (PL_sv_count > 2 && sv_clean_all())
733 ;
734
d33b2eba
GS		 735 SvFLAGS(PL_fdpid) &= ~SVTYPEMASK;
736 SvFLAGS(PL_fdpid) |= SVt_PVAV;
3280af22
NIS		 737 SvFLAGS(PL_strtab) &= ~SVTYPEMASK;
738 SvFLAGS(PL_strtab) |= SVt_PVHV;
d33b2eba 739
d4777f27
GS		 740 AvREAL_off(PL_fdpid); /* no surviving entries */
741 SvREFCNT_dec(PL_fdpid); /* needed in io_close() */
d33b2eba
GS		 742 PL_fdpid = Nullav;
743
6c644e78
GS		 744#ifdef HAVE_INTERP_INTERN
745 sys_intern_clear();
746#endif
747
6e72f9df 748 /* Destruct the global string table. */
749 {
750 /* Yell and reset the HeVAL() slots that are still holding refcounts,
751 * so that sv_free() won't fail on them.
752 */
753 I32 riter;
754 I32 max;
755 HE *hent;
756 HE **array;
757
758 riter = 0;
3280af22
NIS		 759 max = HvMAX(PL_strtab);
760 array = HvARRAY(PL_strtab);
6e72f9df 761 hent = array[0];
762 for (;;) {
0453d815 763 if (hent && ckWARN_d(WARN_INTERNAL)) {
9014280d 764 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
0453d815 765 "Unbalanced string table refcount: (%d) for \"%s\"",
6e72f9df 766 HeVAL(hent) - Nullsv, HeKEY(hent));
767 HeVAL(hent) = Nullsv;
768 hent = HeNEXT(hent);
769 }
770 if (!hent) {
771 if (++riter > max)
772 break;
773 hent = array[riter];
774 }
775 }
776 }
3280af22 777 SvREFCNT_dec(PL_strtab);
6e72f9df 778
e652bb2f 779#ifdef USE_ITHREADS
a0739874
DM		 780 /* free the pointer table used for cloning */
781 ptr_table_free(PL_ptr_table);
53186e96 782#endif
a0739874 783
d33b2eba
GS		 784 /* free special SVs */
785
786 SvREFCNT(&PL_sv_yes) = 0;
787 sv_clear(&PL_sv_yes);
788 SvANY(&PL_sv_yes) = NULL;
4c5e2b0d 789 SvFLAGS(&PL_sv_yes) = 0;
d33b2eba
GS		 790
791 SvREFCNT(&PL_sv_no) = 0;
792 sv_clear(&PL_sv_no);
793 SvANY(&PL_sv_no) = NULL;
4c5e2b0d 794 SvFLAGS(&PL_sv_no) = 0;
01724ea0
GS		 795
796 SvREFCNT(&PL_sv_undef) = 0;
797 SvREADONLY_off(&PL_sv_undef);
d33b2eba 798
0453d815 799 if (PL_sv_count != 0 && ckWARN_d(WARN_INTERNAL))
9014280d 800 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Scalars leaked: %ld\n", (long)PL_sv_count);
6e72f9df 801
56a2bab7 802#if defined(PERLIO_LAYERS)
3a1ee7e8
NIS		 803 /* No more IO - including error messages ! */
804 PerlIO_cleanup(aTHX);
805#endif
806
3280af22 807 Safefree(PL_origfilename);
3280af22 808 Safefree(PL_reg_start_tmp);
5c5e4c24
IZ		 809 if (PL_reg_curpm)
810 Safefree(PL_reg_curpm);
82ba1be6 811 Safefree(PL_reg_poscache);
3280af22
NIS		 812 Safefree(HeKEY_hek(&PL_hv_fetch_ent_mh));
813 Safefree(PL_op_mask);
cf36064f
GS		 814 Safefree(PL_psig_ptr);
815 Safefree(PL_psig_name);
2c2666fc 816 Safefree(PL_bitcount);
ce08f86c 817 Safefree(PL_psig_pend);
6e72f9df 818 nuke_stacks();
3280af22 819 PL_hints = 0; /* Reset hints. Should hints be per-interpreter ? */
ac27b0f5 820
a0d0e21e 821 DEBUG_P(debprofdump());
4d1ff10f 822#ifdef USE_5005THREADS
5f08fbcd 823 MUTEX_DESTROY(&PL_strtab_mutex);
533c011a
NIS		 824 MUTEX_DESTROY(&PL_sv_mutex);
825 MUTEX_DESTROY(&PL_eval_mutex);
5ff3f7a4 826 MUTEX_DESTROY(&PL_cred_mutex);
3d35f11b 827 MUTEX_DESTROY(&PL_fdpid_mutex);
533c011a 828 COND_DESTROY(&PL_eval_cond);
11d617a5
GS		 829#ifdef EMULATE_ATOMIC_REFCOUNTS
830 MUTEX_DESTROY(&PL_svref_mutex);
831#endif /* EMULATE_ATOMIC_REFCOUNTS */
fc36a67e 832
8023c3ce 833 /* As the penultimate thing, free the non-arena SV for thrsv */
533c011a
NIS		 834 Safefree(SvPVX(PL_thrsv));
835 Safefree(SvANY(PL_thrsv));
836 Safefree(PL_thrsv);
837 PL_thrsv = Nullsv;
4d1ff10f 838#endif /* USE_5005THREADS */
d33b2eba 839
e5dd39fc 840#ifdef USE_REENTRANT_API
10bc17b6 841 Perl_reentrant_free(aTHX);
e5dd39fc
AB		 842#endif
843
612f20c3
GS		 844 sv_free_arenas();
845
fc36a67e 846 /* As the absolutely last thing, free the non-arena SV for mess() */
847
3280af22 848 if (PL_mess_sv) {
9c63abab
GS		 849 /* it could have accumulated taint magic */
850 if (SvTYPE(PL_mess_sv) >= SVt_PVMG) {
851 MAGIC* mg;
852 MAGIC* moremagic;
853 for (mg = SvMAGIC(PL_mess_sv); mg; mg = moremagic) {
854 moremagic = mg->mg_moremagic;
14befaf4
DM		 855 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global
856 && mg->mg_len >= 0)
9c63abab
GS		 857 Safefree(mg->mg_ptr);
858 Safefree(mg);
859 }
860 }
fc36a67e 861 /* we know that type >= SVt_PV */
155aba94 862 (void)SvOOK_off(PL_mess_sv);
3280af22
NIS		 863 Safefree(SvPVX(PL_mess_sv));
864 Safefree(SvANY(PL_mess_sv));
865 Safefree(PL_mess_sv);
866 PL_mess_sv = Nullsv;
fc36a67e 867 }
31d77e54 868 return STATUS_NATIVE_EXPORT;
79072805
LW		 869}
870
954c1994
GS		 871/*
872=for apidoc perl_free
873
874Releases a Perl interpreter. See L<perlembed>.
875
876=cut
877*/
878
79072805 879void
0cb96387 880perl_free(pTHXx)
79072805 881{
acfe0abc 882#if defined(WIN32) || defined(NETWARE)
ce3e5b80 883# if defined(PERL_IMPLICIT_SYS)
acfe0abc
GS		 884# ifdef NETWARE
885 void *host = nw_internal_host;
886# else
887 void *host = w32_internal_host;
888# endif
ce3e5b80 889 PerlMem_free(aTHXx);
acfe0abc
GS		 890# ifdef NETWARE
891 nw5_delete_internal_host(host);
892# else
893 win32_delete_internal_host(host);
894# endif
1c0ca838
GS		 895# else
896 PerlMem_free(aTHXx);
897# endif
acfe0abc
GS		 898#else
899 PerlMem_free(aTHXx);
76e3520e 900#endif
79072805
LW		 901}
902
4b556e6c 903void
864dbfa3 904Perl_call_atexit(pTHX_ ATEXIT_t fn, void *ptr)
4b556e6c 905{
3280af22
NIS		 906 Renew(PL_exitlist, PL_exitlistlen+1, PerlExitListEntry);
907 PL_exitlist[PL_exitlistlen].fn = fn;
908 PL_exitlist[PL_exitlistlen].ptr = ptr;
909 ++PL_exitlistlen;
4b556e6c
JD		 910}
911
954c1994
GS		 912/*
913=for apidoc perl_parse
914
915Tells a Perl interpreter to parse a Perl script. See L<perlembed>.
916
917=cut
918*/
919
79072805 920int
0cb96387 921perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env)
8d063cd8 922{
6224f72b 923 I32 oldscope;
6224f72b 924 int ret;
db36c5a1 925 dJMPENV;
4d1ff10f 926#ifdef USE_5005THREADS
cea2e8a9
GS		 927 dTHX;
928#endif
8d063cd8 929
a687059c
LW		 930#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
931#ifdef IAMSUID
932#undef IAMSUID
cea2e8a9 933 Perl_croak(aTHX_ "suidperl is no longer needed since the kernel can now execute\n\
a687059c
LW		 934setuid perl scripts securely.\n");
935#endif
936#endif
937
3280af22 938 PL_origargc = argc;
bc0a45ed
DM		 939 {
940 /* we copy rather than point to argv
941 * since perl_clone will copy and perl_destruct
3a1ee7e8 942 * has no way of knowing if we've made a copy or
bc0a45ed
DM		 943 * just point to argv
944 */
945 int i = PL_origargc;
946 New(0, PL_origargv, i+1, char*);
947 PL_origargv[i] = '\0';
948 while (i-- > 0) {
949 PL_origargv[i] = savepv(argv[i]);
950 }
951 }
952
0631ea03 953
a0d0e21e 954
3280af22 955 if (PL_do_undump) {
a0d0e21e
LW		 956
957 /* Come here if running an undumped a.out. */
958
3280af22
NIS		 959 PL_origfilename = savepv(argv[0]);
960 PL_do_undump = FALSE;
a0d0e21e 961 cxstack_ix = -1; /* start label stack again */
748a9306 962 init_ids();
a0d0e21e
LW		 963 init_postdump_symbols(argc,argv,env);
964 return 0;
965 }
966
3280af22
NIS		 967 if (PL_main_root) {
968 PL_curpad = AvARRAY(PL_comppad);
969 op_free(PL_main_root);
970 PL_main_root = Nullop;
ff0cee69 971 }
3280af22
NIS		 972 PL_main_start = Nullop;
973 SvREFCNT_dec(PL_main_cv);
974 PL_main_cv = Nullcv;
79072805 975
3280af22
NIS		 976 time(&PL_basetime);
977 oldscope = PL_scopestack_ix;
599cee73 978 PL_dowarn = G_WARN_OFF;
f86702cc 979
14dd3ad8
GS		 980#ifdef PERL_FLEXIBLE_EXCEPTIONS
981 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vparse_body), env, xsinit);
982#else
983 JMPENV_PUSH(ret);
984#endif
6224f72b 985 switch (ret) {
312caa8e 986 case 0:
14dd3ad8
GS		 987#ifndef PERL_FLEXIBLE_EXCEPTIONS
988 parse_body(env,xsinit);
989#endif
7d30b5c4
GS		 990 if (PL_checkav)
991 call_list(oldscope, PL_checkav);
14dd3ad8
GS		 992 ret = 0;
993 break;
6224f72b
GS		 994 case 1:
995 STATUS_ALL_FAILURE;
996 /* FALL THROUGH */
997 case 2:
998 /* my_exit() was called */
3280af22 999 while (PL_scopestack_ix > oldscope)
6224f72b
GS		 1000 LEAVE;
1001 FREETMPS;
3280af22 1002 PL_curstash = PL_defstash;
7d30b5c4
GS		 1003 if (PL_checkav)
1004 call_list(oldscope, PL_checkav);
14dd3ad8
GS		 1005 ret = STATUS_NATIVE_EXPORT;
1006 break;
6224f72b 1007 case 3:
bf49b057 1008 PerlIO_printf(Perl_error_log, "panic: top_env\n");
14dd3ad8
GS		 1009 ret = 1;
1010 break;
6224f72b 1011 }
14dd3ad8
GS		 1012 JMPENV_POP;
1013 return ret;
1014}
1015
1016#ifdef PERL_FLEXIBLE_EXCEPTIONS
1017STATIC void *
1018S_vparse_body(pTHX_ va_list args)
1019{
1020 char **env = va_arg(args, char**);
1021 XSINIT_t xsinit = va_arg(args, XSINIT_t);
1022
1023 return parse_body(env, xsinit);
312caa8e 1024}
14dd3ad8 1025#endif
312caa8e
CS		 1026
1027STATIC void *
14dd3ad8 1028S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
312caa8e 1029{
312caa8e
CS		 1030 int argc = PL_origargc;
1031 char **argv = PL_origargv;
312caa8e
CS		 1032 char *scriptname = NULL;
1033 int fdscript = -1;
1034 VOL bool dosearch = FALSE;
1035 char *validarg = "";
1036 AV* comppadlist;
1037 register SV *sv;
1038 register char *s;
cf756827 1039 char *cddir = Nullch;
312caa8e 1040
3280af22 1041 sv_setpvn(PL_linestr,"",0);
79cb57f6 1042 sv = newSVpvn("",0); /* first used for -I flags */
6224f72b
GS		 1043 SAVEFREESV(sv);
1044 init_main_stash();
54310121 1045
6224f72b
GS		 1046 for (argc--,argv++; argc > 0; argc--,argv++) {
1047 if (argv[0][0] != '-' || !argv[0][1])
1048 break;
1049#ifdef DOSUID
1050 if (*validarg)
1051 validarg = " PHOOEY ";
1052 else
1053 validarg = argv[0];
13281fa4 1054#endif
6224f72b
GS		 1055 s = argv[0]+1;
1056 reswitch:
1057 switch (*s) {
729a02f2
GS		 1058 case 'C':
1059#ifdef WIN32
c0932edc 1060 win32_argv2utf8(argc-1, argv+1);
729a02f2
GS		 1061 /* FALL THROUGH */
1062#endif
1d5472a9
GS		 1063#ifndef PERL_STRICT_CR
1064 case '\r':
1065#endif
6224f72b
GS		 1066 case ' ':
1067 case '0':
1068 case 'F':
1069 case 'a':
1070 case 'c':
1071 case 'd':
1072 case 'D':
1073 case 'h':
1074 case 'i':
1075 case 'l':
1076 case 'M':
1077 case 'm':
1078 case 'n':
1079 case 'p':
1080 case 's':
1081 case 'u':
1082 case 'U':
1083 case 'v':
599cee73
PM		 1084 case 'W':
1085 case 'X':
6224f72b 1086 case 'w':
155aba94 1087 if ((s = moreswitches(s)))
6224f72b
GS		 1088 goto reswitch;
1089 break;
33b78306 1090
1dbad523 1091 case 't':
317ea90d
MS		 1092 if( !PL_tainting ) {
1093 PL_taint_warn = TRUE;
1094 PL_tainting = TRUE;
1095 }
1096 s++;
1097 goto reswitch;
6224f72b 1098 case 'T':
3280af22 1099 PL_tainting = TRUE;
317ea90d 1100 PL_taint_warn = FALSE;
6224f72b
GS		 1101 s++;
1102 goto reswitch;
f86702cc 1103
6224f72b 1104 case 'e':
bf4acbe4
GS		 1105#ifdef MACOS_TRADITIONAL
1106 /* ignore -e for Dev:Pseudo argument */
1107 if (argv[1] && !strcmp(argv[1], "Dev:Pseudo"))
ac27b0f5 1108 break;
bf4acbe4 1109#endif
3280af22 1110 if (PL_euid != PL_uid || PL_egid != PL_gid)
cea2e8a9 1111 Perl_croak(aTHX_ "No -e allowed in setuid scripts");
3280af22 1112 if (!PL_e_script) {
79cb57f6 1113 PL_e_script = newSVpvn("",0);
0cb96387 1114 filter_add(read_e_script, NULL);
6224f72b
GS		 1115 }
1116 if (*++s)
3280af22 1117 sv_catpv(PL_e_script, s);
6224f72b 1118 else if (argv[1]) {
3280af22 1119 sv_catpv(PL_e_script, argv[1]);
6224f72b
GS		 1120 argc--,argv++;
1121 }
1122 else
cea2e8a9 1123 Perl_croak(aTHX_ "No code specified for -e");
3280af22 1124 sv_catpv(PL_e_script, "\n");
6224f72b 1125 break;
afe37c7d 1126
6224f72b
GS		 1127 case 'I': /* -I handled both here and in moreswitches() */
1128 forbid_setid("-I");
1129 if (!*++s && (s=argv[1]) != Nullch) {
1130 argc--,argv++;
1131 }
6224f72b 1132 if (s && *s) {
0df16ed7
GS		 1133 char *p;
1134 STRLEN len = strlen(s);
1135 p = savepvn(s, len);
9c8a64f0 1136 incpush(p, TRUE, TRUE);
0df16ed7
GS		 1137 sv_catpvn(sv, "-I", 2);
1138 sv_catpvn(sv, p, len);
1139 sv_catpvn(sv, " ", 1);
6224f72b 1140 Safefree(p);
0df16ed7
GS		 1141 }
1142 else
a67e862a 1143 Perl_croak(aTHX_ "No directory specified for -I");
6224f72b
GS		 1144 break;
1145 case 'P':
1146 forbid_setid("-P");
3280af22 1147 PL_preprocess = TRUE;
6224f72b
GS		 1148 s++;
1149 goto reswitch;
1150 case 'S':
1151 forbid_setid("-S");
1152 dosearch = TRUE;
1153 s++;
1154 goto reswitch;
1155 case 'V':
3280af22
NIS		 1156 if (!PL_preambleav)
1157 PL_preambleav = newAV();
1158 av_push(PL_preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
6224f72b 1159 if (*++s != ':') {
3280af22 1160 PL_Sv = newSVpv("print myconfig();",0);
6224f72b 1161#ifdef VMS
6b88bc9c 1162 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
6224f72b 1163#else
3280af22 1164 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
6224f72b 1165#endif
3280af22 1166 sv_catpv(PL_Sv,"\" Compile-time options:");
6224f72b 1167# ifdef DEBUGGING
3280af22 1168 sv_catpv(PL_Sv," DEBUGGING");
6224f72b 1169# endif
6224f72b 1170# ifdef MULTIPLICITY
8f872242 1171 sv_catpv(PL_Sv," MULTIPLICITY");
6224f72b 1172# endif
4d1ff10f
AB		 1173# ifdef USE_5005THREADS
1174 sv_catpv(PL_Sv," USE_5005THREADS");
b363f7ed 1175# endif
ac5e8965
JH		 1176# ifdef USE_ITHREADS
1177 sv_catpv(PL_Sv," USE_ITHREADS");
1178# endif
10cc9d2a
JH		 1179# ifdef USE_64_BIT_INT
1180 sv_catpv(PL_Sv," USE_64_BIT_INT");
1181# endif
1182# ifdef USE_64_BIT_ALL
1183 sv_catpv(PL_Sv," USE_64_BIT_ALL");
ac5e8965
JH		 1184# endif
1185# ifdef USE_LONG_DOUBLE
1186 sv_catpv(PL_Sv," USE_LONG_DOUBLE");
1187# endif
53430762
JH		 1188# ifdef USE_LARGE_FILES
1189 sv_catpv(PL_Sv," USE_LARGE_FILES");
1190# endif
ac5e8965
JH		 1191# ifdef USE_SOCKS
1192 sv_catpv(PL_Sv," USE_SOCKS");
1193# endif
b363f7ed
GS		 1194# ifdef PERL_IMPLICIT_CONTEXT
1195 sv_catpv(PL_Sv," PERL_IMPLICIT_CONTEXT");
1196# endif
1197# ifdef PERL_IMPLICIT_SYS
1198 sv_catpv(PL_Sv," PERL_IMPLICIT_SYS");
1199# endif
3280af22 1200 sv_catpv(PL_Sv,"\\n\",");
b363f7ed 1201
6224f72b
GS		 1202#if defined(LOCAL_PATCH_COUNT)
1203 if (LOCAL_PATCH_COUNT > 0) {
1204 int i;
3280af22 1205 sv_catpv(PL_Sv,"\" Locally applied patches:\\n\",");
6224f72b 1206 for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
3280af22 1207 if (PL_localpatches[i])
cea2e8a9 1208 Perl_sv_catpvf(aTHX_ PL_Sv,"q\" \t%s\n\",",PL_localpatches[i]);
6224f72b
GS		 1209 }
1210 }
1211#endif
cea2e8a9 1212 Perl_sv_catpvf(aTHX_ PL_Sv,"\" Built under %s\\n\"",OSNAME);
6224f72b
GS		 1213#ifdef __DATE__
1214# ifdef __TIME__
cea2e8a9 1215 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
6224f72b 1216# else
cea2e8a9 1217 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled on %s\\n\"",__DATE__);
6224f72b
GS		 1218# endif
1219#endif
3280af22 1220 sv_catpv(PL_Sv, "; \
6224f72b 1221$\"=\"\\n \"; \
69fcd688
JH		 1222@env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; ");
1223#ifdef __CYGWIN__
1224 sv_catpv(PL_Sv,"\
1225push @env, \"CYGWIN=\\\"$ENV{CYGWIN}\\\"\";");
1226#endif
1227 sv_catpv(PL_Sv, "\
6224f72b
GS		 1228print \" \\%ENV:\\n @env\\n\" if @env; \
1229print \" \\@INC:\\n @INC\\n\";");
1230 }
1231 else {
3280af22
NIS		 1232 PL_Sv = newSVpv("config_vars(qw(",0);
1233 sv_catpv(PL_Sv, ++s);
1234 sv_catpv(PL_Sv, "))");
6224f72b
GS		 1235 s += strlen(s);
1236 }
3280af22 1237 av_push(PL_preambleav, PL_Sv);
6224f72b
GS		 1238 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
1239 goto reswitch;
1240 case 'x':
3280af22 1241 PL_doextract = TRUE;
6224f72b
GS		 1242 s++;
1243 if (*s)
f4c556ac 1244 cddir = s;
6224f72b
GS		 1245 break;
1246 case 0:
1247 break;
1248 case '-':
1249 if (!*++s || isSPACE(*s)) {
1250 argc--,argv++;
1251 goto switch_end;
1252 }
1253 /* catch use of gnu style long options */
1254 if (strEQ(s, "version")) {
1255 s = "v";
1256 goto reswitch;
1257 }
1258 if (strEQ(s, "help")) {
1259 s = "h";
1260 goto reswitch;
1261 }
1262 s--;
1263 /* FALL THROUGH */
1264 default:
cea2e8a9 1265 Perl_croak(aTHX_ "Unrecognized switch: -%s (-h will show valid options)",s);
8d063cd8
LW		 1266 }
1267 }
6224f72b 1268 switch_end:
54310121 1269
f675dbe5
CB		 1270 if (
1271#ifndef SECURE_INTERNAL_GETENV
1272 !PL_tainting &&
1273#endif
cf756827 1274 (s = PerlEnv_getenv("PERL5OPT")))
0df16ed7 1275 {
cf756827 1276 char *popt = s;
74288ac8
GS		 1277 while (isSPACE(*s))
1278 s++;
317ea90d 1279 if (*s == '-' && *(s+1) == 'T') {
74288ac8 1280 PL_tainting = TRUE;
317ea90d
MS		 1281 PL_taint_warn = FALSE;
1282 }
74288ac8 1283 else {
cf756827 1284 char *popt_copy = Nullch;
74288ac8 1285 while (s && *s) {
4ea8f8fb 1286 char *d;
74288ac8
GS		 1287 while (isSPACE(*s))
1288 s++;
1289 if (*s == '-') {
1290 s++;
1291 if (isSPACE(*s))
1292 continue;
1293 }
4ea8f8fb 1294 d = s;
74288ac8
GS		 1295 if (!*s)
1296 break;
1c4db469 1297 if (!strchr("DIMUdmtw", *s))
cea2e8a9 1298 Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s);
4ea8f8fb
MS		 1299 while (++s && *s) {
1300 if (isSPACE(*s)) {
cf756827
GS		 1301 if (!popt_copy) {
1302 popt_copy = SvPVX(sv_2mortal(newSVpv(popt,0)));
1303 s = popt_copy + (s - popt);
1304 d = popt_copy + (d - popt);
1305 }
4ea8f8fb
MS		 1306 *s++ = '\0';
1307 break;
1308 }
1309 }
1c4db469 1310 if (*d == 't') {
317ea90d
MS		 1311 if( !PL_tainting ) {
1312 PL_taint_warn = TRUE;
1313 PL_tainting = TRUE;
1314 }
1c4db469
RGS		 1315 } else {
1316 moreswitches(d);
1317 }
6224f72b 1318 }
6224f72b
GS		 1319 }
1320 }
a0d0e21e 1321
317ea90d
MS		 1322 if (PL_taint_warn && PL_dowarn != G_WARN_ALL_OFF) {
1323 PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
1324 }
1325
6224f72b
GS		 1326 if (!scriptname)
1327 scriptname = argv[0];
3280af22 1328 if (PL_e_script) {
6224f72b
GS		 1329 argc++,argv--;
1330 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
1331 }
1332 else if (scriptname == Nullch) {
1333#ifdef MSDOS
1334 if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
1335 moreswitches("h");
1336#endif
1337 scriptname = "-";
1338 }
1339
1340 init_perllib();
1341
1342 open_script(scriptname,dosearch,sv,&fdscript);
1343
1344 validate_suid(validarg, scriptname,fdscript);
1345
64ca3a65 1346#ifndef PERL_MICRO
0b5b802d
GS		 1347#if defined(SIGCHLD) || defined(SIGCLD)
1348 {
1349#ifndef SIGCHLD
1350# define SIGCHLD SIGCLD
1351#endif
1352 Sighandler_t sigstate = rsignal_state(SIGCHLD);
1353 if (sigstate == SIG_IGN) {
1354 if (ckWARN(WARN_SIGNAL))
9014280d 1355 Perl_warner(aTHX_ packWARN(WARN_SIGNAL),
0b5b802d
GS		 1356 "Can't ignore signal CHLD, forcing to default");
1357 (void)rsignal(SIGCHLD, (Sighandler_t)SIG_DFL);
1358 }
1359 }
1360#endif
64ca3a65 1361#endif
0b5b802d 1362
bf4acbe4
GS		 1363#ifdef MACOS_TRADITIONAL
1364 if (PL_doextract || gMacPerl_AlwaysExtract) {
1365#else
f4c556ac 1366 if (PL_doextract) {
bf4acbe4 1367#endif
6224f72b 1368 find_beginning();
f4c556ac
GS		 1369 if (cddir && PerlDir_chdir(cddir) < 0)
1370 Perl_croak(aTHX_ "Can't chdir to %s",cddir);
1371
1372 }
6224f72b 1373
3280af22
NIS		 1374 PL_main_cv = PL_compcv = (CV*)NEWSV(1104,0);
1375 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
1376 CvUNIQUE_on(PL_compcv);
1377
1378 PL_comppad = newAV();
1379 av_push(PL_comppad, Nullsv);
1380 PL_curpad = AvARRAY(PL_comppad);
1381 PL_comppad_name = newAV();
1382 PL_comppad_name_fill = 0;
1383 PL_min_intro_pending = 0;
1384 PL_padix = 0;
4d1ff10f 1385#ifdef USE_5005THREADS
79cb57f6 1386 av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
533c011a
NIS		 1387 PL_curpad[0] = (SV*)newAV();
1388 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
1389 CvOWNER(PL_compcv) = 0;
1390 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
1391 MUTEX_INIT(CvMUTEXP(PL_compcv));
4d1ff10f 1392#endif /* USE_5005THREADS */
6224f72b
GS		 1393
1394 comppadlist = newAV();
1395 AvREAL_off(comppadlist);
3280af22
NIS		 1396 av_store(comppadlist, 0, (SV*)PL_comppad_name);
1397 av_store(comppadlist, 1, (SV*)PL_comppad);
1398 CvPADLIST(PL_compcv) = comppadlist;
6224f72b 1399
0c4f7ff0 1400 boot_core_PerlIO();
6224f72b 1401 boot_core_UNIVERSAL();
9a34ef1d 1402#ifndef PERL_MICRO
09bef843 1403 boot_core_xsutils();
9a34ef1d 1404#endif
6224f72b
GS		 1405
1406 if (xsinit)
acfe0abc 1407 (*xsinit)(aTHX); /* in case linked C routines want magical variables */
64ca3a65 1408#ifndef PERL_MICRO
ed79a026 1409#if defined(VMS) || defined(WIN32) || defined(DJGPP) || defined(__CYGWIN__) || defined(EPOC)
c5be433b 1410 init_os_extras();
6224f72b 1411#endif
64ca3a65 1412#endif
6224f72b 1413
29209bc5 1414#ifdef USE_SOCKS
1b9c9cf5
DH		 1415# ifdef HAS_SOCKS5_INIT
1416 socks5_init(argv[0]);
1417# else
29209bc5 1418 SOCKSinit(argv[0]);
1b9c9cf5 1419# endif
ac27b0f5 1420#endif
29209bc5 1421
6224f72b
GS		 1422 init_predump_symbols();
1423 /* init_postdump_symbols not currently designed to be called */
1424 /* more than once (ENV isn't cleared first, for example) */
1425 /* But running with -u leaves %ENV & @ARGV undefined! XXX */
3280af22 1426 if (!PL_do_undump)
6224f72b
GS		 1427 init_postdump_symbols(argc,argv,env);
1428
b310b053
JH		 1429 if (PL_wantutf8) { /* Requires init_predump_symbols(). */
1430 IO* io;
1431 PerlIO* fp;
1432 SV* sv;
1433 if (PL_stdingv && (io = GvIO(PL_stdingv)) && (fp = IoIFP(io)))
1434 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
1435 if (PL_defoutgv && (io = GvIO(PL_defoutgv)) && (fp = IoOFP(io)))
1436 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
1437 if (PL_stderrgv && (io = GvIO(PL_stderrgv)) && (fp = IoOFP(io)))
1438 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
1439 if ((sv = GvSV(gv_fetchpv("\017PEN", TRUE, SVt_PV)))) {
1440 sv_setpvn(sv, ":utf8\0:utf8", 11);
1441 SvSETMAGIC(sv);
1442 }
1443 }
1444
6224f72b
GS		 1445 init_lexer();
1446
1447 /* now parse the script */
1448
91487cfc 1449 SETERRNO(0,SS$_NORMAL);
3280af22 1450 PL_error_count = 0;
bf4acbe4
GS		 1451#ifdef MACOS_TRADITIONAL
1452 if (gMacPerl_SyntaxError = (yyparse() || PL_error_count)) {
1453 if (PL_minus_c)
1454 Perl_croak(aTHX_ "%s had compilation errors.\n", MacPerl_MPWFileName(PL_origfilename));
1455 else {
1456 Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
1457 MacPerl_MPWFileName(PL_origfilename));
1458 }
1459 }
1460#else
3280af22
NIS		 1461 if (yyparse() || PL_error_count) {
1462 if (PL_minus_c)
cea2e8a9 1463 Perl_croak(aTHX_ "%s had compilation errors.\n", PL_origfilename);
6224f72b 1464 else {
cea2e8a9 1465 Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
097ee67d 1466 PL_origfilename);
6224f72b
GS		 1467 }
1468 }
bf4acbe4 1469#endif
57843af0 1470 CopLINE_set(PL_curcop, 0);
3280af22
NIS		 1471 PL_curstash = PL_defstash;
1472 PL_preprocess = FALSE;
1473 if (PL_e_script) {
1474 SvREFCNT_dec(PL_e_script);
1475 PL_e_script = Nullsv;
6224f72b
GS		 1476 }
1477
8bfdd7d9
HS		 1478/*
1479 Not sure that this is still the right place to do this now that we
1480 no longer use PL_nrs. HVDS 2001/09/09
1481*/
864dbfa3 1482 sv_setsv(get_sv("/", TRUE), PL_rs);
8bfdd7d9 1483
3280af22 1484 if (PL_do_undump)
6224f72b
GS		 1485 my_unexec();
1486
57843af0
GS		 1487 if (isWARN_ONCE) {
1488 SAVECOPFILE(PL_curcop);
1489 SAVECOPLINE(PL_curcop);
3280af22 1490 gv_check(PL_defstash);
57843af0 1491 }
6224f72b
GS		 1492
1493 LEAVE;
1494 FREETMPS;
1495
1496#ifdef MYMALLOC
1497 if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
1498 dump_mstats("after compilation:");
1499#endif
1500
1501 ENTER;
3280af22 1502 PL_restartop = 0;
312caa8e 1503 return NULL;
6224f72b
GS		 1504}
1505
954c1994
GS		 1506/*
1507=for apidoc perl_run
1508
1509Tells a Perl interpreter to run. See L<perlembed>.
1510
1511=cut
1512*/
1513
6224f72b 1514int
0cb96387 1515perl_run(pTHXx)
6224f72b 1516{
6224f72b 1517 I32 oldscope;
14dd3ad8 1518 int ret = 0;
db36c5a1 1519 dJMPENV;
4d1ff10f 1520#ifdef USE_5005THREADS
cea2e8a9
GS		 1521 dTHX;
1522#endif
6224f72b 1523
3280af22 1524 oldscope = PL_scopestack_ix;
96e176bf
CL		 1525#ifdef VMS
1526 VMSISH_HUSHED = 0;
1527#endif
6224f72b 1528
14dd3ad8 1529#ifdef PERL_FLEXIBLE_EXCEPTIONS
312caa8e 1530 redo_body:
14dd3ad8
GS		 1531 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vrun_body), oldscope);
1532#else
1533 JMPENV_PUSH(ret);
1534#endif
6224f72b
GS		 1535 switch (ret) {
1536 case 1:
1537 cxstack_ix = -1; /* start context stack again */
312caa8e 1538 goto redo_body;
14dd3ad8
GS		 1539 case 0: /* normal completion */
1540#ifndef PERL_FLEXIBLE_EXCEPTIONS
1541 redo_body:
1542 run_body(oldscope);
1543#endif
1544 /* FALL THROUGH */
1545 case 2: /* my_exit() */
3280af22 1546 while (PL_scopestack_ix > oldscope)
6224f72b
GS		 1547 LEAVE;
1548 FREETMPS;
3280af22 1549 PL_curstash = PL_defstash;
3a1ee7e8 1550 if (!(PL_exit_flags & PERL_EXIT_DESTRUCT_END) &&
31d77e54
AB		 1551 PL_endav && !PL_minus_c)
1552 call_list(oldscope, PL_endav);
6224f72b
GS		 1553#ifdef MYMALLOC
1554 if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
1555 dump_mstats("after execution: ");
1556#endif
14dd3ad8
GS		 1557 ret = STATUS_NATIVE_EXPORT;
1558 break;
6224f72b 1559 case 3:
312caa8e
CS		 1560 if (PL_restartop) {
1561 POPSTACK_TO(PL_mainstack);
1562 goto redo_body;
6224f72b 1563 }
bf49b057 1564 PerlIO_printf(Perl_error_log, "panic: restartop\n");
312caa8e 1565 FREETMPS;
14dd3ad8
GS		 1566 ret = 1;
1567 break;
6224f72b
GS		 1568 }
1569
14dd3ad8
GS		 1570 JMPENV_POP;
1571 return ret;
312caa8e
CS		 1572}
1573
14dd3ad8 1574#ifdef PERL_FLEXIBLE_EXCEPTIONS
312caa8e 1575STATIC void *
14dd3ad8 1576S_vrun_body(pTHX_ va_list args)
312caa8e 1577{
312caa8e
CS		 1578 I32 oldscope = va_arg(args, I32);
1579
14dd3ad8
GS		 1580 return run_body(oldscope);
1581}
1582#endif
1583
1584
1585STATIC void *
1586S_run_body(pTHX_ I32 oldscope)
1587{
6224f72b 1588 DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
3280af22 1589 PL_sawampersand ? "Enabling" : "Omitting"));
6224f72b 1590
3280af22 1591 if (!PL_restartop) {
6224f72b
GS		 1592 DEBUG_x(dump_all());
1593 DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
b900a521
JH		 1594 DEBUG_S(PerlIO_printf(Perl_debug_log, "main thread is 0x%"UVxf"\n",
1595 PTR2UV(thr)));
6224f72b 1596
3280af22 1597 if (PL_minus_c) {
bf4acbe4 1598#ifdef MACOS_TRADITIONAL
be708cc0 1599 PerlIO_printf(Perl_error_log, "# %s syntax OK\n", MacPerl_MPWFileName(PL_origfilename));
bf4acbe4 1600#else
bf49b057 1601 PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename);
bf4acbe4 1602#endif
6224f72b
GS		 1603 my_exit(0);
1604 }
3280af22 1605 if (PERLDB_SINGLE && PL_DBsingle)
ac27b0f5 1606 sv_setiv(PL_DBsingle, 1);
3280af22
NIS		 1607 if (PL_initav)
1608 call_list(oldscope, PL_initav);
6224f72b
GS		 1609 }
1610
1611 /* do it */
1612
3280af22 1613 if (PL_restartop) {
533c011a 1614 PL_op = PL_restartop;
3280af22 1615 PL_restartop = 0;
cea2e8a9 1616 CALLRUNOPS(aTHX);
6224f72b 1617 }
3280af22
NIS		 1618 else if (PL_main_start) {
1619 CvDEPTH(PL_main_cv) = 1;
533c011a 1620 PL_op = PL_main_start;
cea2e8a9 1621 CALLRUNOPS(aTHX);
6224f72b
GS		 1622 }
1623
f6b3007c
JH		 1624 my_exit(0);
1625 /* NOTREACHED */
312caa8e 1626 return NULL;
6224f72b
GS		 1627}
1628
954c1994 1629/*
ccfc67b7
JH		 1630=head1 SV Manipulation Functions
1631
954c1994
GS		 1632=for apidoc p||get_sv
1633
1634Returns the SV of the specified Perl scalar. If C<create> is set and the
1635Perl variable does not exist then it will be created. If C<create> is not
1636set and the variable does not exist then NULL is returned.
1637
1638=cut
1639*/
1640
6224f72b 1641SV*
864dbfa3 1642Perl_get_sv(pTHX_ const char *name, I32 create)
6224f72b
GS		 1643{
1644 GV *gv;
4d1ff10f 1645#ifdef USE_5005THREADS
6224f72b
GS		 1646 if (name[1] == '\0' && !isALPHA(name[0])) {
1647 PADOFFSET tmp = find_threadsv(name);
411caa50 1648 if (tmp != NOT_IN_PAD)
6224f72b 1649 return THREADSV(tmp);
6224f72b 1650 }
4d1ff10f 1651#endif /* USE_5005THREADS */
6224f72b
GS		 1652 gv = gv_fetchpv(name, create, SVt_PV);
1653 if (gv)
1654 return GvSV(gv);
1655 return Nullsv;
1656}
1657
954c1994 1658/*
ccfc67b7
JH		 1659=head1 Array Manipulation Functions
1660
954c1994
GS		 1661=for apidoc p||get_av
1662
1663Returns the AV of the specified Perl array. If C<create> is set and the
1664Perl variable does not exist then it will be created. If C<create> is not
1665set and the variable does not exist then NULL is returned.
1666
1667=cut
1668*/
1669
6224f72b 1670AV*
864dbfa3 1671Perl_get_av(pTHX_ const char *name, I32 create)
6224f72b
GS		 1672{
1673 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
1674 if (create)
1675 return GvAVn(gv);
1676 if (gv)
1677 return GvAV(gv);
1678 return Nullav;
1679}
1680
954c1994 1681/*
ccfc67b7
JH		 1682=head1 Hash Manipulation Functions
1683
954c1994
GS		 1684=for apidoc p||get_hv
1685
1686Returns the HV of the specified Perl hash. If C<create> is set and the
1687Perl variable does not exist then it will be created. If C<create> is not
1688set and the variable does not exist then NULL is returned.
1689
1690=cut
1691*/
1692
6224f72b 1693HV*
864dbfa3 1694Perl_get_hv(pTHX_ const char *name, I32 create)
6224f72b 1695{
a0d0e21e
LW		 1696 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
1697 if (create)
1698 return GvHVn(gv);
1699 if (gv)
1700 return GvHV(gv);
1701 return Nullhv;
1702}
1703
954c1994 1704/*
ccfc67b7
JH		 1705=head1 CV Manipulation Functions
1706
954c1994
GS		 1707=for apidoc p||get_cv
1708
1709Returns the CV of the specified Perl subroutine. If C<create> is set and
1710the Perl subroutine does not exist then it will be declared (which has the
1711same effect as saying C<sub name;>). If C<create> is not set and the
1712subroutine does not exist then NULL is returned.
1713
1714=cut
1715*/
1716
a0d0e21e 1717CV*
864dbfa3 1718Perl_get_cv(pTHX_ const char *name, I32 create)
a0d0e21e
LW		 1719{
1720 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
b099ddc0 1721 /* XXX unsafe for threads if eval_owner isn't held */
f6ec51f7
GS		 1722 /* XXX this is probably not what they think they're getting.
1723 * It has the same effect as "sub name;", i.e. just a forward
1724 * declaration! */
8ebc5c01 1725 if (create && !GvCVu(gv))
774d564b 1726 return newSUB(start_subparse(FALSE, 0),
a0d0e21e 1727 newSVOP(OP_CONST, 0, newSVpv(name,0)),
4633a7c4 1728 Nullop,
a0d0e21e
LW		 1729 Nullop);
1730 if (gv)
8ebc5c01 1731 return GvCVu(gv);
a0d0e21e
LW		 1732 return Nullcv;
1733}
1734
79072805
LW		 1735/* Be sure to refetch the stack pointer after calling these routines. */
1736
954c1994 1737/*
ccfc67b7
JH		 1738
1739=head1 Callback Functions
1740
954c1994
GS		 1741=for apidoc p||call_argv
1742
1743Performs a callback to the specified Perl sub. See L<perlcall>.
1744
1745=cut
1746*/
1747
a0d0e21e 1748I32
864dbfa3 1749Perl_call_argv(pTHX_ const char *sub_name, I32 flags, register char **argv)
ac27b0f5 1750
8ac85365
NIS		 1751 /* See G_* flags in cop.h */
1752 /* null terminated arg list */
8990e307 1753{
a0d0e21e 1754 dSP;
8990e307 1755
924508f0 1756 PUSHMARK(SP);
a0d0e21e 1757 if (argv) {
8990e307 1758 while (*argv) {
a0d0e21e 1759 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
8990e307
LW		 1760 argv++;
1761 }
a0d0e21e 1762 PUTBACK;
8990e307 1763 }
864dbfa3 1764 return call_pv(sub_name, flags);
8990e307
LW		 1765}
1766
954c1994
GS		 1767/*
1768=for apidoc p||call_pv
1769
1770Performs a callback to the specified Perl sub. See L<perlcall>.
1771
1772=cut
1773*/
1774
a0d0e21e 1775I32
864dbfa3 1776Perl_call_pv(pTHX_ const char *sub_name, I32 flags)
8ac85365
NIS		 1777 /* name of the subroutine */
1778 /* See G_* flags in cop.h */
a0d0e21e 1779{
864dbfa3 1780 return call_sv((SV*)get_cv(sub_name, TRUE), flags);
a0d0e21e
LW		 1781}
1782
954c1994
GS		 1783/*
1784=for apidoc p||call_method
1785
1786Performs a callback to the specified Perl method. The blessed object must
1787be on the stack. See L<perlcall>.
1788
1789=cut
1790*/
1791
a0d0e21e 1792I32
864dbfa3 1793Perl_call_method(pTHX_ const char *methname, I32 flags)
8ac85365
NIS		 1794 /* name of the subroutine */
1795 /* See G_* flags in cop.h */
a0d0e21e 1796{
968b3946 1797 return call_sv(sv_2mortal(newSVpv(methname,0)), flags | G_METHOD);
a0d0e21e
LW		 1798}
1799
1800/* May be called with any of a CV, a GV, or an SV containing the name. */
954c1994
GS		 1801/*
1802=for apidoc p||call_sv
1803
1804Performs a callback to the Perl sub whose name is in the SV. See
1805L<perlcall>.
1806
1807=cut
1808*/
1809
a0d0e21e 1810I32
864dbfa3 1811Perl_call_sv(pTHX_ SV *sv, I32 flags)
8ac85365 1812 /* See G_* flags in cop.h */
a0d0e21e 1813{
924508f0 1814 dSP;
a0d0e21e 1815 LOGOP myop; /* fake syntax tree node */
968b3946 1816 UNOP method_op;
aa689395 1817 I32 oldmark;
13689cfe 1818 volatile I32 retval = 0;
a0d0e21e 1819 I32 oldscope;
54310121 1820 bool oldcatch = CATCH_GET;
6224f72b 1821 int ret;
533c011a 1822 OP* oldop = PL_op;
db36c5a1 1823 dJMPENV;
1e422769 1824
a0d0e21e
LW		 1825 if (flags & G_DISCARD) {
1826 ENTER;
1827 SAVETMPS;
1828 }
1829
aa689395 1830 Zero(&myop, 1, LOGOP);
54310121 1831 myop.op_next = Nullop;
f51d4af5 1832 if (!(flags & G_NOARGS))
aa689395 1833 myop.op_flags |= OPf_STACKED;
54310121 1834 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1835 (flags & G_ARRAY) ? OPf_WANT_LIST :
1836 OPf_WANT_SCALAR);
462e5cf6 1837 SAVEOP();
533c011a 1838 PL_op = (OP*)&myop;
aa689395 1839
3280af22
NIS		 1840 EXTEND(PL_stack_sp, 1);
1841 *++PL_stack_sp = sv;
aa689395 1842 oldmark = TOPMARK;
3280af22 1843 oldscope = PL_scopestack_ix;
a0d0e21e 1844
3280af22 1845 if (PERLDB_SUB && PL_curstash != PL_debstash
36477c24 1846 /* Handle first BEGIN of -d. */
3280af22 1847 && (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub)))
36477c24 1848 /* Try harder, since this may have been a sighandler, thus
1849 * curstash may be meaningless. */
3280af22 1850 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != PL_debstash)
491527d0 1851 && !(flags & G_NODEBUG))
533c011a 1852 PL_op->op_private |= OPpENTERSUB_DB;
a0d0e21e 1853
968b3946
GS		 1854 if (flags & G_METHOD) {
1855 Zero(&method_op, 1, UNOP);
1856 method_op.op_next = PL_op;
1857 method_op.op_ppaddr = PL_ppaddr[OP_METHOD];
1858 myop.op_ppaddr = PL_ppaddr[OP_ENTERSUB];
f39d0b86 1859 PL_op = (OP*)&method_op;
968b3946
GS		 1860 }
1861
312caa8e 1862 if (!(flags & G_EVAL)) {
0cdb2077 1863 CATCH_SET(TRUE);
14dd3ad8 1864 call_body((OP*)&myop, FALSE);
312caa8e 1865 retval = PL_stack_sp - (PL_stack_base + oldmark);
0253cb41 1866 CATCH_SET(oldcatch);
312caa8e
CS		 1867 }
1868 else {
d78bda3d 1869 myop.op_other = (OP*)&myop;
3280af22 1870 PL_markstack_ptr--;
4633a7c4
LW		 1871 /* we're trying to emulate pp_entertry() here */
1872 {
c09156bb 1873 register PERL_CONTEXT *cx;
54310121 1874 I32 gimme = GIMME_V;
ac27b0f5 1875
4633a7c4
LW		 1876 ENTER;
1877 SAVETMPS;
ac27b0f5 1878
968b3946 1879 push_return(Nullop);
1d76a5c3 1880 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
4633a7c4 1881 PUSHEVAL(cx, 0, 0);
533c011a 1882 PL_eval_root = PL_op; /* Only needed so that goto works right. */
ac27b0f5 1883
faef0170 1884 PL_in_eval = EVAL_INEVAL;
4633a7c4 1885 if (flags & G_KEEPERR)
faef0170 1886 PL_in_eval |= EVAL_KEEPERR;
4633a7c4 1887 else
38a03e6e 1888 sv_setpv(ERRSV,"");
4633a7c4 1889 }
3280af22 1890 PL_markstack_ptr++;
a0d0e21e 1891
14dd3ad8
GS		 1892#ifdef PERL_FLEXIBLE_EXCEPTIONS
1893 redo_body:
1894 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_body),
db36c5a1 1895 (OP*)&myop, FALSE);
14dd3ad8
GS		 1896#else
1897 JMPENV_PUSH(ret);
1898#endif
6224f72b
GS		 1899 switch (ret) {
1900 case 0:
14dd3ad8
GS		 1901#ifndef PERL_FLEXIBLE_EXCEPTIONS
1902 redo_body:
1903 call_body((OP*)&myop, FALSE);
1904#endif
312caa8e
CS		 1905 retval = PL_stack_sp - (PL_stack_base + oldmark);
1906 if (!(flags & G_KEEPERR))
1907 sv_setpv(ERRSV,"");
a0d0e21e 1908 break;
6224f72b 1909 case 1:
f86702cc 1910 STATUS_ALL_FAILURE;
a0d0e21e 1911 /* FALL THROUGH */
6224f72b 1912 case 2:
a0d0e21e 1913 /* my_exit() was called */
3280af22 1914 PL_curstash = PL_defstash;
a0d0e21e 1915 FREETMPS;
14dd3ad8 1916 JMPENV_POP;
cc3604b1 1917 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
cea2e8a9 1918 Perl_croak(aTHX_ "Callback called exit");
f86702cc 1919 my_exit_jump();
a0d0e21e 1920 /* NOTREACHED */
6224f72b 1921 case 3:
3280af22 1922 if (PL_restartop) {
533c011a 1923 PL_op = PL_restartop;
3280af22 1924 PL_restartop = 0;
312caa8e 1925 goto redo_body;
a0d0e21e 1926 }
3280af22 1927 PL_stack_sp = PL_stack_base + oldmark;
a0d0e21e
LW		 1928 if (flags & G_ARRAY)
1929 retval = 0;
1930 else {
1931 retval = 1;
3280af22 1932 *++PL_stack_sp = &PL_sv_undef;
a0d0e21e 1933 }
312caa8e 1934 break;
a0d0e21e 1935 }
a0d0e21e 1936
3280af22 1937 if (PL_scopestack_ix > oldscope) {
a0a2876f
LW		 1938 SV **newsp;
1939 PMOP *newpm;
1940 I32 gimme;
c09156bb 1941 register PERL_CONTEXT *cx;
a0a2876f
LW		 1942 I32 optype;
1943
1944 POPBLOCK(cx,newpm);
1945 POPEVAL(cx);
1946 pop_return();
3280af22 1947 PL_curpm = newpm;
a0a2876f 1948 LEAVE;
a0d0e21e 1949 }
14dd3ad8 1950 JMPENV_POP;
a0d0e21e 1951 }
1e422769 1952
a0d0e21e 1953 if (flags & G_DISCARD) {
3280af22 1954 PL_stack_sp = PL_stack_base + oldmark;
a0d0e21e
LW		 1955 retval = 0;
1956 FREETMPS;
1957 LEAVE;
1958 }
533c011a 1959 PL_op = oldop;
a0d0e21e
LW		 1960 return retval;
1961}
1962
14dd3ad8 1963#ifdef PERL_FLEXIBLE_EXCEPTIONS
312caa8e 1964STATIC void *
14dd3ad8 1965S_vcall_body(pTHX_ va_list args)
312caa8e
CS		 1966{
1967 OP *myop = va_arg(args, OP*);
1968 int is_eval = va_arg(args, int);
1969
14dd3ad8 1970 call_body(myop, is_eval);
312caa8e
CS		 1971 return NULL;
1972}
14dd3ad8 1973#endif
312caa8e
CS		 1974
1975STATIC void
14dd3ad8 1976S_call_body(pTHX_ OP *myop, int is_eval)
312caa8e 1977{
312caa8e
CS		 1978 if (PL_op == myop) {
1979 if (is_eval)
f807eda9 1980 PL_op = Perl_pp_entereval(aTHX); /* this doesn't do a POPMARK */
312caa8e 1981 else
f807eda9 1982 PL_op = Perl_pp_entersub(aTHX); /* this does */
312caa8e
CS		 1983 }
1984 if (PL_op)
cea2e8a9 1985 CALLRUNOPS(aTHX);
312caa8e
CS		 1986}
1987
6e72f9df 1988/* Eval a string. The G_EVAL flag is always assumed. */
8990e307 1989
954c1994
GS		 1990/*
1991=for apidoc p||eval_sv
1992
1993Tells Perl to C<eval> the string in the SV.
1994
1995=cut
1996*/
1997
a0d0e21e 1998I32
864dbfa3 1999Perl_eval_sv(pTHX_ SV *sv, I32 flags)
ac27b0f5 2000
8ac85365 2001 /* See G_* flags in cop.h */
a0d0e21e 2002{
924508f0 2003 dSP;
a0d0e21e 2004 UNOP myop; /* fake syntax tree node */
8fa7f367 2005 volatile I32 oldmark = SP - PL_stack_base;
13689cfe 2006 volatile I32 retval = 0;
4633a7c4 2007 I32 oldscope;
6224f72b 2008 int ret;
533c011a 2009 OP* oldop = PL_op;
db36c5a1 2010 dJMPENV;
84902520 2011
4633a7c4
LW		 2012 if (flags & G_DISCARD) {
2013 ENTER;
2014 SAVETMPS;
2015 }
2016
462e5cf6 2017 SAVEOP();
533c011a
NIS		 2018 PL_op = (OP*)&myop;
2019 Zero(PL_op, 1, UNOP);
3280af22
NIS		 2020 EXTEND(PL_stack_sp, 1);
2021 *++PL_stack_sp = sv;
2022 oldscope = PL_scopestack_ix;
79072805 2023
4633a7c4
LW		 2024 if (!(flags & G_NOARGS))
2025 myop.op_flags = OPf_STACKED;
79072805 2026 myop.op_next = Nullop;
6e72f9df 2027 myop.op_type = OP_ENTEREVAL;
54310121 2028 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
2029 (flags & G_ARRAY) ? OPf_WANT_LIST :
2030 OPf_WANT_SCALAR);
6e72f9df 2031 if (flags & G_KEEPERR)
2032 myop.op_flags |= OPf_SPECIAL;
4633a7c4 2033
14dd3ad8 2034#ifdef PERL_FLEXIBLE_EXCEPTIONS
312caa8e 2035 redo_body:
14dd3ad8 2036 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_body),
db36c5a1 2037 (OP*)&myop, TRUE);
14dd3ad8
GS		 2038#else
2039 JMPENV_PUSH(ret);
2040#endif
6224f72b
GS		 2041 switch (ret) {
2042 case 0:
14dd3ad8
GS		 2043#ifndef PERL_FLEXIBLE_EXCEPTIONS
2044 redo_body:
2045 call_body((OP*)&myop,TRUE);
2046#endif
312caa8e
CS		 2047 retval = PL_stack_sp - (PL_stack_base + oldmark);
2048 if (!(flags & G_KEEPERR))
2049 sv_setpv(ERRSV,"");
4633a7c4 2050 break;
6224f72b 2051 case 1:
f86702cc 2052 STATUS_ALL_FAILURE;
4633a7c4 2053 /* FALL THROUGH */
6224f72b 2054 case 2:
4633a7c4 2055 /* my_exit() was called */
3280af22 2056 PL_curstash = PL_defstash;
4633a7c4 2057 FREETMPS;
14dd3ad8 2058 JMPENV_POP;
cc3604b1 2059 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
cea2e8a9 2060 Perl_croak(aTHX_ "Callback called exit");
f86702cc 2061 my_exit_jump();
4633a7c4 2062 /* NOTREACHED */
6224f72b 2063 case 3:
3280af22 2064 if (PL_restartop) {
533c011a 2065 PL_op = PL_restartop;
3280af22 2066 PL_restartop = 0;
312caa8e 2067 goto redo_body;
4633a7c4 2068 }
3280af22 2069 PL_stack_sp = PL_stack_base + oldmark;
4633a7c4
LW		 2070 if (flags & G_ARRAY)
2071 retval = 0;
2072 else {
2073 retval = 1;
3280af22 2074 *++PL_stack_sp = &PL_sv_undef;
4633a7c4 2075 }
312caa8e 2076 break;
4633a7c4
LW		 2077 }
2078
14dd3ad8 2079 JMPENV_POP;
4633a7c4 2080 if (flags & G_DISCARD) {
3280af22 2081 PL_stack_sp = PL_stack_base + oldmark;
4633a7c4
LW		 2082 retval = 0;
2083 FREETMPS;
2084 LEAVE;
2085 }
533c011a 2086 PL_op = oldop;
4633a7c4
LW		 2087 return retval;
2088}
2089
954c1994
GS		 2090/*
2091=for apidoc p||eval_pv
2092
2093Tells Perl to C<eval> the given string and return an SV* result.
2094
2095=cut
2096*/
2097
137443ea 2098SV*
864dbfa3 2099Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
137443ea 2100{
2101 dSP;
2102 SV* sv = newSVpv(p, 0);
2103
864dbfa3 2104 eval_sv(sv, G_SCALAR);
137443ea 2105 SvREFCNT_dec(sv);
2106
2107 SPAGAIN;
2108 sv = POPs;
2109 PUTBACK;
2110
2d8e6c8d
GS		 2111 if (croak_on_error && SvTRUE(ERRSV)) {
2112 STRLEN n_a;
cea2e8a9 2113 Perl_croak(aTHX_ SvPVx(ERRSV, n_a));
2d8e6c8d 2114 }
137443ea 2115
2116 return sv;
2117}
2118
4633a7c4
LW		 2119/* Require a module. */
2120
954c1994 2121/*
ccfc67b7
JH		 2122=head1 Embedding Functions
2123
954c1994
GS		 2124=for apidoc p||require_pv
2125
7d3fb230
BS		 2126Tells Perl to C<require> the file named by the string argument. It is
2127analogous to the Perl code C<eval "require '$file'">. It's even
2128implemented that way; consider using Perl_load_module instead.
954c1994 2129
7d3fb230 2130=cut */
954c1994 2131
4633a7c4 2132void
864dbfa3 2133Perl_require_pv(pTHX_ const char *pv)
4633a7c4 2134{
d3acc0f7
JP		 2135 SV* sv;
2136 dSP;
e788e7d3 2137 PUSHSTACKi(PERLSI_REQUIRE);
d3acc0f7
JP		 2138 PUTBACK;
2139 sv = sv_newmortal();
4633a7c4
LW		 2140 sv_setpv(sv, "require '");
2141 sv_catpv(sv, pv);
2142 sv_catpv(sv, "'");
864dbfa3 2143 eval_sv(sv, G_DISCARD);
d3acc0f7
JP		 2144 SPAGAIN;
2145 POPSTACK;
79072805
LW		 2146}
2147
79072805 2148void
864dbfa3 2149Perl_magicname(pTHX_ char *sym, char *name, I32 namlen)
79072805
LW		 2150{
2151 register GV *gv;
2152
155aba94 2153 if ((gv = gv_fetchpv(sym,TRUE, SVt_PV)))
14befaf4 2154 sv_magic(GvSV(gv), (SV*)gv, PERL_MAGIC_sv, name, namlen);
79072805
LW		 2155}
2156
76e3520e 2157STATIC void
cea2e8a9 2158S_usage(pTHX_ char *name) /* XXX move this out into a module ? */
4633a7c4 2159{
ab821d7f 2160 /* This message really ought to be max 23 lines.
75c72d73 2161 * Removed -h because the user already knows that option. Others? */
fb73857a 2162
76e3520e 2163 static char *usage_msg[] = {
fb73857a 2164"-0[octal] specify record separator (\\0, if no argument)",
2165"-a autosplit mode with -n or -p (splits $_ into @F)",
46487f74 2166"-C enable native wide character system interfaces",
1950ee41 2167"-c check syntax only (runs BEGIN and CHECK blocks)",
aac3bd0d
GS		 2168"-d[:debugger] run program under debugger",
2169"-D[number/list] set debugging flags (argument is a bit mask or alphabets)",
2170"-e 'command' one line of program (several -e's allowed, omit programfile)",
2171"-F/pattern/ split() pattern for -a switch (//'s are optional)",
2172"-i[extension] edit <> files in place (makes backup if extension supplied)",
2173"-Idirectory specify @INC/#include directory (several -I's allowed)",
fb73857a 2174"-l[octal] enable line ending processing, specifies line terminator",
aac3bd0d
GS		 2175"-[mM][-]module execute `use/no module...' before executing program",
2176"-n assume 'while (<>) { ... }' loop around program",
2177"-p assume loop like -n but print line also, like sed",
2178"-P run program through C preprocessor before compilation",
2179"-s enable rudimentary parsing for switches after programfile",
2180"-S look for programfile using PATH environment variable",
2181"-T enable tainting checks",
9cbc33e8 2182"-t enable tainting warnings",
aac3bd0d 2183"-u dump core after parsing program",
fb73857a 2184"-U allow unsafe operations",
aac3bd0d
GS		 2185"-v print version, subversion (includes VERY IMPORTANT perl info)",
2186"-V[:variable] print configuration summary (or a single Config.pm variable)",
2187"-w enable many useful warnings (RECOMMENDED)",
3c0facb2
GS		 2188"-W enable all warnings",
2189"-X disable all warnings",
fb73857a 2190"-x[directory] strip off text before #!perl line and perhaps cd to directory",
2191"\n",
2192NULL
2193};
76e3520e 2194 char **p = usage_msg;
fb73857a 2195
b0e47665
GS		 2196 PerlIO_printf(PerlIO_stdout(),
2197 "\nUsage: %s [switches] [--] [programfile] [arguments]",
2198 name);
fb73857a 2199 while (*p)
b0e47665 2200 PerlIO_printf(PerlIO_stdout(), "\n %s", *p++);
4633a7c4
LW		 2201}
2202
79072805
LW		 2203/* This routine handles any switches that can be given during run */
2204
2205char *
864dbfa3 2206Perl_moreswitches(pTHX_ char *s)
79072805 2207{
ba210ebe 2208 STRLEN numlen;
c07a80fd 2209 U32 rschar;
79072805
LW		 2210
2211 switch (*s) {
2212 case '0':
a863c7d1 2213 {
53305cf1
NC		 2214 I32 flags = 0;
2215 numlen = 4;
2216 rschar = (U32)grok_oct(s, &numlen, &flags, NULL);
8bfdd7d9 2217 SvREFCNT_dec(PL_rs);
c07a80fd 2218 if (rschar & ~((U8)~0))
8bfdd7d9 2219 PL_rs = &PL_sv_undef;
c07a80fd 2220 else if (!rschar && numlen >= 2)
8bfdd7d9 2221 PL_rs = newSVpvn("", 0);
c07a80fd 2222 else {
2223 char ch = rschar;
8bfdd7d9 2224 PL_rs = newSVpvn(&ch, 1);
79072805
LW		 2225 }
2226 return s + numlen;
a863c7d1 2227 }
46487f74
GS		 2228 case 'C':
2229 PL_widesyscalls = TRUE;
2230 s++;
2231 return s;
2304df62 2232 case 'F':
3280af22 2233 PL_minus_F = TRUE;
ebce5377
RGS		 2234 PL_splitstr = ++s;
2235 while (*s && !isSPACE(*s)) ++s;
2236 *s = '\0';
2237 PL_splitstr = savepv(PL_splitstr);
2304df62 2238 return s;
79072805 2239 case 'a':
3280af22 2240 PL_minus_a = TRUE;
79072805
LW		 2241 s++;
2242 return s;
2243 case 'c':
3280af22 2244 PL_minus_c = TRUE;
79072805
LW		 2245 s++;
2246 return s;
2247 case 'd':
bbce6d69 2248 forbid_setid("-d");
4633a7c4 2249 s++;
70c94a19
RR		 2250 /* The following permits -d:Mod to accepts arguments following an =
2251 in the fashion that -MSome::Mod does. */
2252 if (*s == ':' || *s == '=') {
2253 char *start;
2254 SV *sv;
2255 sv = newSVpv("use Devel::", 0);
2256 start = ++s;
2257 /* We now allow -d:Module=Foo,Bar */
2258 while(isALNUM(*s) || *s==':') ++s;
2259 if (*s != '=')
2260 sv_catpv(sv, start);
2261 else {
2262 sv_catpvn(sv, start, s-start);
2263 sv_catpv(sv, " split(/,/,q{");
2264 sv_catpv(sv, ++s);
2265 sv_catpv(sv, "})");
2266 }
4633a7c4 2267 s += strlen(s);
70c94a19 2268 my_setenv("PERL5DB", SvPV(sv, PL_na));
4633a7c4 2269 }
ed094faf 2270 if (!PL_perldb) {
3280af22 2271 PL_perldb = PERLDB_ALL;
a0d0e21e 2272 init_debugger();
ed094faf 2273 }
79072805
LW		 2274 return s;
2275 case 'D':
0453d815 2276 {
79072805 2277#ifdef DEBUGGING
bbce6d69 2278 forbid_setid("-D");
79072805 2279 if (isALPHA(s[1])) {
04932ac8 2280 /* if adding extra options, remember to update DEBUG_MASK */
1045810a 2281 static char debopts[] = "psltocPmfrxuLHXDSTRJ";
79072805
LW		 2282 char *d;
2283
93a17b20 2284 for (s++; *s && (d = strchr(debopts,*s)); s++)
3280af22 2285 PL_debug |= 1 << (d - debopts);
79072805
LW		 2286 }
2287 else {
3280af22 2288 PL_debug = atoi(s+1);
79072805
LW		 2289 for (s++; isDIGIT(*s); s++) ;
2290 }
aea4f609 2291 PL_debug |= DEBUG_TOP_FLAG;
79072805 2292#else
0453d815 2293 if (ckWARN_d(WARN_DEBUGGING))
9014280d 2294 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
0453d815 2295 "Recompile perl with -DDEBUGGING to use -D switch\n");
a0d0e21e 2296 for (s++; isALNUM(*s); s++) ;
79072805
LW		 2297#endif
2298 /*SUPPRESS 530*/
2299 return s;
0453d815 2300 }
4633a7c4 2301 case 'h':
ac27b0f5 2302 usage(PL_origargv[0]);
6ad3d225 2303 PerlProc_exit(0);
79072805 2304 case 'i':
3280af22
NIS		 2305 if (PL_inplace)
2306 Safefree(PL_inplace);
2307 PL_inplace = savepv(s+1);
79072805 2308 /*SUPPRESS 530*/
3280af22 2309 for (s = PL_inplace; *s && !isSPACE(*s); s++) ;
7b8d334a 2310 if (*s) {
fb73857a 2311 *s++ = '\0';
7b8d334a
GS		 2312 if (*s == '-') /* Additional switches on #! line. */
2313 s++;
2314 }
fb73857a 2315 return s;
4e49a025 2316 case 'I': /* -I handled both here and in parse_body() */
bbce6d69 2317 forbid_setid("-I");
fb73857a 2318 ++s;
2319 while (*s && isSPACE(*s))
2320 ++s;
2321 if (*s) {
774d564b 2322 char *e, *p;
0df16ed7
GS		 2323 p = s;
2324 /* ignore trailing spaces (possibly followed by other switches) */
2325 do {
2326 for (e = p; *e && !isSPACE(*e); e++) ;
2327 p = e;
2328 while (isSPACE(*p))
2329 p++;
2330 } while (*p && *p != '-');
2331 e = savepvn(s, e-s);
9c8a64f0 2332 incpush(e, TRUE, TRUE);
0df16ed7
GS		 2333 Safefree(e);
2334 s = p;
2335 if (*s == '-')
2336 s++;
79072805
LW		 2337 }
2338 else
a67e862a 2339 Perl_croak(aTHX_ "No directory specified for -I");
fb73857a 2340 return s;
79072805 2341 case 'l':
3280af22 2342 PL_minus_l = TRUE;
79072805 2343 s++;
7889fe52
NIS		 2344 if (PL_ors_sv) {
2345 SvREFCNT_dec(PL_ors_sv);
2346 PL_ors_sv = Nullsv;
2347 }
79072805 2348 if (isDIGIT(*s)) {
53305cf1 2349 I32 flags = 0;
7889fe52 2350 PL_ors_sv = newSVpvn("\n",1);
53305cf1
NC		 2351 numlen = 3 + (*s == '0');
2352 *SvPVX(PL_ors_sv) = (char)grok_oct(s, &numlen, &flags, NULL);
79072805
LW		 2353 s += numlen;
2354 }
2355 else {
8bfdd7d9 2356 if (RsPARA(PL_rs)) {
7889fe52
NIS		 2357 PL_ors_sv = newSVpvn("\n\n",2);
2358 }
2359 else {
8bfdd7d9 2360 PL_ors_sv = newSVsv(PL_rs);
c07a80fd 2361 }
79072805
LW		 2362 }
2363 return s;
1a30305b 2364 case 'M':
bbce6d69 2365 forbid_setid("-M"); /* XXX ? */
1a30305b 2366 /* FALL THROUGH */
2367 case 'm':
bbce6d69 2368 forbid_setid("-m"); /* XXX ? */
1a30305b 2369 if (*++s) {
a5f75d66 2370 char *start;
11343788 2371 SV *sv;
a5f75d66
AD		 2372 char *use = "use ";
2373 /* -M-foo == 'no foo' */
2374 if (*s == '-') { use = "no "; ++s; }
11343788 2375 sv = newSVpv(use,0);
a5f75d66 2376 start = s;
1a30305b 2377 /* We allow -M'Module qw(Foo Bar)' */
c07a80fd 2378 while(isALNUM(*s) || *s==':') ++s;
2379 if (*s != '=') {
11343788 2380 sv_catpv(sv, start);
c07a80fd 2381 if (*(start-1) == 'm') {
2382 if (*s != '\0')
cea2e8a9 2383 Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
11343788 2384 sv_catpv( sv, " ()");
c07a80fd 2385 }
2386 } else {
6df41af2 2387 if (s == start)
be98fb35
GS		 2388 Perl_croak(aTHX_ "Module name required with -%c option",
2389 s[-1]);
11343788
MB		 2390 sv_catpvn(sv, start, s-start);
2391 sv_catpv(sv, " split(/,/,q{");
2392 sv_catpv(sv, ++s);
2393 sv_catpv(sv, "})");
c07a80fd 2394 }
1a30305b 2395 s += strlen(s);
5c831c24 2396 if (!PL_preambleav)
3280af22
NIS		 2397 PL_preambleav = newAV();
2398 av_push(PL_preambleav, sv);
1a30305b 2399 }
2400 else
cea2e8a9 2401 Perl_croak(aTHX_ "No space allowed after -%c", *(s-1));
1a30305b 2402 return s;
79072805 2403 case 'n':
3280af22 2404 PL_minus_n = TRUE;
79072805
LW		 2405 s++;
2406 return s;
2407 case 'p':
3280af22 2408 PL_minus_p = TRUE;
79072805
LW		 2409 s++;
2410 return s;
2411 case 's':
bbce6d69 2412 forbid_setid("-s");
3280af22 2413 PL_doswitches = TRUE;
79072805
LW		 2414 s++;
2415 return s;
6537fe72
MS		 2416 case 't':
2417 if (!PL_tainting)
2418 Perl_croak(aTHX_ "Too late for \"-t\" option");
2419 s++;
2420 return s;
463ee0b2 2421 case 'T':
3280af22 2422 if (!PL_tainting)
cea2e8a9 2423 Perl_croak(aTHX_ "Too late for \"-T\" option");
463ee0b2
LW		 2424 s++;
2425 return s;
79072805 2426 case 'u':
bf4acbe4
GS		 2427#ifdef MACOS_TRADITIONAL
2428 Perl_croak(aTHX_ "Believe me, you don't want to use \"-u\" on a Macintosh");
2429#endif
3280af22 2430 PL_do_undump = TRUE;
79072805
LW		 2431 s++;
2432 return s;
2433 case 'U':
3280af22 2434 PL_unsafe = TRUE;
79072805
LW		 2435 s++;
2436 return s;
2437 case 'v':
8e9464f1 2438#if !defined(DGUX)
b0e47665 2439 PerlIO_printf(PerlIO_stdout(),
d2560b70 2440 Perl_form(aTHX_ "\nThis is perl, v%"VDf" built for %s",
b0e47665 2441 PL_patchlevel, ARCHNAME));
8e9464f1
JH		 2442#else /* DGUX */
2443/* Adjust verbose output as in the perl that ships with the DG/UX OS from EMC */
2444 PerlIO_printf(PerlIO_stdout(),
2445 Perl_form(aTHX_ "\nThis is perl, version %vd\n", PL_patchlevel));
2446 PerlIO_printf(PerlIO_stdout(),
2447 Perl_form(aTHX_ " built under %s at %s %s\n",
2448 OSNAME, __DATE__, __TIME__));
2449 PerlIO_printf(PerlIO_stdout(),
2450 Perl_form(aTHX_ " OS Specific Release: %s\n",
40a39f85 2451 OSVERS));
8e9464f1
JH		 2452#endif /* !DGUX */
2453
fb73857a 2454#if defined(LOCAL_PATCH_COUNT)
2455 if (LOCAL_PATCH_COUNT > 0)
b0e47665
GS		 2456 PerlIO_printf(PerlIO_stdout(),
2457 "\n(with %d registered patch%s, "
2458 "see perl -V for more detail)",
2459 (int)LOCAL_PATCH_COUNT,
2460 (LOCAL_PATCH_COUNT!=1) ? "es" : "");
a5f75d66 2461#endif
1a30305b 2462
b0e47665 2463 PerlIO_printf(PerlIO_stdout(),
be3c0a43 2464 "\n\nCopyright 1987-2002, Larry Wall\n");
eae9c151
JH		 2465#ifdef MACOS_TRADITIONAL
2466 PerlIO_printf(PerlIO_stdout(),
be3c0a43 2467 "\nMac OS port Copyright 1991-2002, Matthias Neeracher;\n"
03765510 2468 "maintained by Chris Nandor\n");
eae9c151 2469#endif
79072805 2470#ifdef MSDOS
b0e47665
GS		 2471 PerlIO_printf(PerlIO_stdout(),
2472 "\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
55497cff 2473#endif
2474#ifdef DJGPP
b0e47665
GS		 2475 PerlIO_printf(PerlIO_stdout(),
2476 "djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n"
2477 "djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
4633a7c4 2478#endif
79072805 2479#ifdef OS2
b0e47665
GS		 2480 PerlIO_printf(PerlIO_stdout(),
2481 "\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
be3c0a43 2482 "Version 5 port Copyright (c) 1994-2002, Andreas Kaiser, Ilya Zakharevich\n");
79072805 2483#endif
79072805 2484#ifdef atarist
b0e47665
GS		 2485 PerlIO_printf(PerlIO_stdout(),
2486 "atariST series port, ++jrb bammi@cadence.com\n");
79072805 2487#endif
a3f9223b 2488#ifdef __BEOS__
b0e47665
GS		 2489 PerlIO_printf(PerlIO_stdout(),
2490 "BeOS port Copyright Tom Spindler, 1997-1999\n");
a3f9223b 2491#endif
1d84e8df 2492#ifdef MPE
b0e47665 2493 PerlIO_printf(PerlIO_stdout(),
be3c0a43 2494 "MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-2002\n");
1d84e8df 2495#endif
9d116dd7 2496#ifdef OEMVS
b0e47665
GS		 2497 PerlIO_printf(PerlIO_stdout(),
2498 "MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
9d116dd7 2499#endif
495c5fdc 2500#ifdef __VOS__
b0e47665 2501 PerlIO_printf(PerlIO_stdout(),
be3c0a43 2502 "Stratus VOS port by Paul_Green@stratus.com, 1997-2002\n");
495c5fdc 2503#endif
092bebab 2504#ifdef __OPEN_VM
b0e47665
GS		 2505 PerlIO_printf(PerlIO_stdout(),
2506 "VM/ESA port by Neale Ferguson, 1998-1999\n");
092bebab 2507#endif
a1a0e61e 2508#ifdef POSIX_BC
b0e47665
GS		 2509 PerlIO_printf(PerlIO_stdout(),
2510 "BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
a1a0e61e 2511#endif
61ae2fbf 2512#ifdef __MINT__
b0e47665
GS		 2513 PerlIO_printf(PerlIO_stdout(),
2514 "MiNT port by Guido Flohr, 1997-1999\n");
61ae2fbf 2515#endif
f83d2536 2516#ifdef EPOC
b0e47665 2517 PerlIO_printf(PerlIO_stdout(),
be3c0a43 2518 "EPOC port by Olaf Flebbe, 1999-2002\n");
f83d2536 2519#endif
e1caacb4 2520#ifdef UNDER_CE
be3c0a43 2521 printf("WINCE port by Rainer Keuchel, 2001-2002\n");
e1caacb4
JH		 2522 printf("Built on " __DATE__ " " __TIME__ "\n\n");
2523 wce_hitreturn();
2524#endif
baed7233
DL		 2525#ifdef BINARY_BUILD_NOTICE
2526 BINARY_BUILD_NOTICE;
2527#endif
b0e47665
GS		 2528 PerlIO_printf(PerlIO_stdout(),
2529 "\n\
79072805 2530Perl may be copied only under the terms of either the Artistic License or the\n\
3d6f292d 2531GNU General Public License, which may be found in the Perl 5 source kit.\n\n\
95103687
GS		 2532Complete documentation for Perl, including FAQ lists, should be found on\n\
2533this system using `man perl' or `perldoc perl'. If you have access to the\n\
2534Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n");
6ad3d225 2535 PerlProc_exit(0);
79072805 2536 case 'w':
599cee73 2537 if (! (PL_dowarn & G_WARN_ALL_MASK))
ac27b0f5 2538 PL_dowarn |= G_WARN_ON;
599cee73
PM		 2539 s++;
2540 return s;
2541 case 'W':
ac27b0f5 2542 PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
317ea90d
MS		 2543 if (!specialWARN(PL_compiling.cop_warnings))
2544 SvREFCNT_dec(PL_compiling.cop_warnings);
d3a7d8c7 2545 PL_compiling.cop_warnings = pWARN_ALL ;
599cee73
PM		 2546 s++;
2547 return s;
2548 case 'X':
ac27b0f5 2549 PL_dowarn = G_WARN_ALL_OFF;
317ea90d
MS		 2550 if (!specialWARN(PL_compiling.cop_warnings))
2551 SvREFCNT_dec(PL_compiling.cop_warnings);
d3a7d8c7 2552 PL_compiling.cop_warnings = pWARN_NONE ;
79072805
LW		 2553 s++;
2554 return s;
a0d0e21e 2555 case '*':
79072805
LW		 2556 case ' ':
2557 if (s[1] == '-') /* Additional switches on #! line. */
2558 return s+2;
2559 break;
a0d0e21e 2560 case '-':
79072805 2561 case 0:
51882d45 2562#if defined(WIN32) || !defined(PERL_STRICT_CR)
a868473f
NIS		 2563 case '\r':
2564#endif
79072805
LW		 2565 case '\n':
2566 case '\t':
2567 break;
aa689395 2568#ifdef ALTERNATE_SHEBANG
2569 case 'S': /* OS/2 needs -S on "extproc" line. */
2570 break;
2571#endif
a0d0e21e 2572 case 'P':
3280af22 2573 if (PL_preprocess)
a0d0e21e
LW		 2574 return s+1;
2575 /* FALL THROUGH */
79072805 2576 default:
cea2e8a9 2577 Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
79072805
LW		 2578 }
2579 return Nullch;
2580}
2581
2582/* compliments of Tom Christiansen */
2583
2584/* unexec() can be found in the Gnu emacs distribution */
ee580363 2585/* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
79072805
LW		 2586
2587void
864dbfa3 2588Perl_my_unexec(pTHX)
79072805
LW		 2589{
2590#ifdef UNEXEC
46fc3d4c 2591 SV* prog;
2592 SV* file;
ee580363 2593 int status = 1;
79072805
LW		 2594 extern int etext;
2595
ee580363 2596 prog = newSVpv(BIN_EXP, 0);
46fc3d4c 2597 sv_catpv(prog, "/perl");
6b88bc9c 2598 file = newSVpv(PL_origfilename, 0);
46fc3d4c 2599 sv_catpv(file, ".perldump");
79072805 2600
ee580363
GS		 2601 unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
2602 /* unexec prints msg to stderr in case of failure */
6ad3d225 2603 PerlProc_exit(status);
79072805 2604#else
a5f75d66
AD		 2605# ifdef VMS
2606# include <lib$routines.h>
2607 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
aa689395 2608# else
79072805 2609 ABORT(); /* for use with undump */
aa689395 2610# endif
a5f75d66 2611#endif
79072805
LW		 2612}
2613
cb68f92d
GS		 2614/* initialize curinterp */
2615STATIC void
cea2e8a9 2616S_init_interp(pTHX)
cb68f92d
GS		 2617{
2618
acfe0abc
GS		 2619#ifdef MULTIPLICITY
2620# define PERLVAR(var,type)
2621# define PERLVARA(var,n,type)
2622# if defined(PERL_IMPLICIT_CONTEXT)
2623# if defined(USE_5005THREADS)
2624# define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
c5be433b 2625# define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
acfe0abc
GS		 2626# else /* !USE_5005THREADS */
2627# define PERLVARI(var,type,init) aTHX->var = init;
2628# define PERLVARIC(var,type,init) aTHX->var = init;
2629# endif /* USE_5005THREADS */
3967c732 2630# else
acfe0abc
GS		 2631# define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
2632# define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
066ef5b5 2633# endif
acfe0abc
GS		 2634# include "intrpvar.h"
2635# ifndef USE_5005THREADS
2636# include "thrdvar.h"
2637# endif
2638# undef PERLVAR
2639# undef PERLVARA
2640# undef PERLVARI
2641# undef PERLVARIC
2642#else
2643# define PERLVAR(var,type)
2644# define PERLVARA(var,n,type)
2645# define PERLVARI(var,type,init) PL_##var = init;
2646# define PERLVARIC(var,type,init) PL_##var = init;
2647# include "intrpvar.h"
2648# ifndef USE_5005THREADS
2649# include "thrdvar.h"
2650# endif
2651# undef PERLVAR
2652# undef PERLVARA
2653# undef PERLVARI
2654# undef PERLVARIC
cb68f92d
GS		 2655#endif
2656
cb68f92d
GS		 2657}
2658
76e3520e 2659STATIC void
cea2e8a9 2660S_init_main_stash(pTHX)
79072805 2661{
463ee0b2 2662 GV *gv;
6e72f9df 2663
3d47000e 2664
ac27b0f5 2665
3280af22 2666 PL_curstash = PL_defstash = newHV();
79cb57f6 2667 PL_curstname = newSVpvn("main",4);
adbc6bb1
LW		 2668 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
2669 SvREFCNT_dec(GvHV(gv));
3280af22 2670 GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash);
463ee0b2 2671 SvREADONLY_on(gv);
3280af22
NIS		 2672 HvNAME(PL_defstash) = savepv("main");
2673 PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
2674 GvMULTI_on(PL_incgv);
2675 PL_hintgv = gv_fetchpv("\010",TRUE, SVt_PV); /* ^H */
2676 GvMULTI_on(PL_hintgv);
2677 PL_defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
2678 PL_errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
2679 GvMULTI_on(PL_errgv);
2680 PL_replgv = gv_fetchpv("\022", TRUE, SVt_PV); /* ^R */
2681 GvMULTI_on(PL_replgv);
cea2e8a9 2682 (void)Perl_form(aTHX_ "%240s",""); /* Preallocate temp - for immediate signals. */
38a03e6e
MB		 2683 sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
2684 sv_setpvn(ERRSV, "", 0);
3280af22 2685 PL_curstash = PL_defstash;
11faa288 2686 CopSTASH_set(&PL_compiling, PL_defstash);
ed094faf 2687 PL_debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
3280af22 2688 PL_globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
92d29cee 2689 PL_nullstash = GvHV(gv_fetchpv("<none>::", GV_ADDMULTI, SVt_PVHV));
4633a7c4 2690 /* We must init $/ before switches are processed. */
864dbfa3 2691 sv_setpvn(get_sv("/", TRUE), "\n", 1);
79072805
LW		 2692}
2693
76e3520e 2694STATIC void
cea2e8a9 2695S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript)
79072805 2696{
1b24ed4b
MS		 2697 char *quote;
2698 char *code;
2699 char *cpp_discard_flag;
2700 char *perl;
2701
6c4ab083 2702 *fdscript = -1;
79072805 2703
3280af22
NIS		 2704 if (PL_e_script) {
2705 PL_origfilename = savepv("-e");
96436eeb 2706 }
6c4ab083
GS		 2707 else {
2708 /* if find_script() returns, it returns a malloc()-ed value */
3280af22 2709 PL_origfilename = scriptname = find_script(scriptname, dosearch, NULL, 1);
6c4ab083
GS		 2710
2711 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
2712 char *s = scriptname + 8;
2713 *fdscript = atoi(s);
2714 while (isDIGIT(*s))
2715 s++;
2716 if (*s) {
2717 scriptname = savepv(s + 1);
3280af22
NIS		 2718 Safefree(PL_origfilename);
2719 PL_origfilename = scriptname;
6c4ab083
GS		 2720 }
2721 }
2722 }
2723
05ec9bb3 2724 CopFILE_free(PL_curcop);
57843af0 2725 CopFILE_set(PL_curcop, PL_origfilename);
3280af22 2726 if (strEQ(PL_origfilename,"-"))
79072805 2727 scriptname = "";
01f988be 2728 if (*fdscript >= 0) {
3280af22 2729 PL_rsfp = PerlIO_fdopen(*fdscript,PERL_SCRIPT_MODE);
1b24ed4b
MS		 2730# if defined(HAS_FCNTL) && defined(F_SETFD)
2731 if (PL_rsfp)
2732 /* ensure close-on-exec */
2733 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);
2734# endif
96436eeb 2735 }
3280af22 2736 else if (PL_preprocess) {
46fc3d4c 2737 char *cpp_cfg = CPPSTDIN;
79cb57f6 2738 SV *cpp = newSVpvn("",0);
46fc3d4c 2739 SV *cmd = NEWSV(0,0);
2740
2741 if (strEQ(cpp_cfg, "cppstdin"))
cea2e8a9 2742 Perl_sv_catpvf(aTHX_ cpp, "%s/", BIN_EXP);
46fc3d4c 2743 sv_catpv(cpp, cpp_cfg);
79072805 2744
1b24ed4b
MS		 2745# ifndef VMS
2746 sv_catpvn(sv, "-I", 2);
2747 sv_catpv(sv,PRIVLIB_EXP);
2748# endif
46fc3d4c 2749
14953ddc
MB		 2750 DEBUG_P(PerlIO_printf(Perl_debug_log,
2751 "PL_preprocess: scriptname=\"%s\", cpp=\"%s\", sv=\"%s\", CPPMINUS=\"%s\"\n",
2752 scriptname, SvPVX (cpp), SvPVX (sv), CPPMINUS));
1b24ed4b
MS		 2753
2754# if defined(MSDOS) || defined(WIN32) || defined(VMS)
2755 quote = "\"";
2756# else
2757 quote = "'";
2758# endif
2759
2760# ifdef VMS
2761 cpp_discard_flag = "";
2762# else
2763 cpp_discard_flag = "-C";
2764# endif
2765
2766# ifdef OS2
2767 perl = os2_execname(aTHX);
2768# else
2769 perl = PL_origargv[0];
2770# endif
2771
2772
2773 /* This strips off Perl comments which might interfere with
2774 the C pre-processor, including #!. #line directives are
2775 deliberately stripped to avoid confusion with Perl's version
2776 of #line. FWP played some golf with it so it will fit
2777 into VMS's 255 character buffer.
2778 */
2779 if( PL_doextract )
2780 code = "(1../^#!.*perl/i)|/^\\s*#(?!\\s*((ifn?|un)def|(el|end)?if|define|include|else|error|pragma)\\b)/||!($|=1)||print";
2781 else
2782 code = "/^\\s*#(?!\\s*((ifn?|un)def|(el|end)?if|define|include|else|error|pragma)\\b)/||!($|=1)||print";
2783
2784 Perl_sv_setpvf(aTHX_ cmd, "\
2785%s -ne%s%s%s %s | %"SVf" %s %"SVf" %s",
2786 perl, quote, code, quote, scriptname, cpp,
2787 cpp_discard_flag, sv, CPPMINUS);
2788
3280af22 2789 PL_doextract = FALSE;
1b24ed4b
MS		 2790# ifdef IAMSUID /* actually, this is caught earlier */
2791 if (PL_euid != PL_uid && !PL_euid) { /* if running suidperl */
2792# ifdef HAS_SETEUID
2793 (void)seteuid(PL_uid); /* musn't stay setuid root */
2794# else
2795# ifdef HAS_SETREUID
2796 (void)setreuid((Uid_t)-1, PL_uid);
2797# else
2798# ifdef HAS_SETRESUID
2799 (void)setresuid((Uid_t)-1, PL_uid, (Uid_t)-1);
2800# else
2801 PerlProc_setuid(PL_uid);
2802# endif
2803# endif
2804# endif
b28d0864 2805 if (PerlProc_geteuid() != PL_uid)
cea2e8a9 2806 Perl_croak(aTHX_ "Can't do seteuid!\n");
79072805 2807 }
1b24ed4b 2808# endif /* IAMSUID */
0a6c758d 2809
1b24ed4b
MS		 2810 DEBUG_P(PerlIO_printf(Perl_debug_log,
2811 "PL_preprocess: cmd=\"%s\"\n",
0a6c758d
MS		 2812 SvPVX(cmd)));
2813
3280af22 2814 PL_rsfp = PerlProc_popen(SvPVX(cmd), "r");
46fc3d4c 2815 SvREFCNT_dec(cmd);
2816 SvREFCNT_dec(cpp);
79072805
LW		 2817 }
2818 else if (!*scriptname) {
bbce6d69 2819 forbid_setid("program input from stdin");
3280af22 2820 PL_rsfp = PerlIO_stdin();
79072805 2821 }
96436eeb 2822 else {
3280af22 2823 PL_rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
1b24ed4b
MS		 2824# if defined(HAS_FCNTL) && defined(F_SETFD)
2825 if (PL_rsfp)
2826 /* ensure close-on-exec */
2827 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);
2828# endif
96436eeb 2829 }
3280af22 2830 if (!PL_rsfp) {
1b24ed4b
MS		 2831# ifdef DOSUID
2832# ifndef IAMSUID /* in case script is not readable before setuid */
2833 if (PL_euid &&
2834 PerlLIO_stat(CopFILE(PL_curcop),&PL_statbuf) >= 0 &&
2835 PL_statbuf.st_mode & (S_ISUID|S_ISGID))
2836 {
2837 /* try again */
2838 PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT,
2839 BIN_EXP, (int)PERL_REVISION,
2840 (int)PERL_VERSION,
2841 (int)PERL_SUBVERSION), PL_origargv);
2842 Perl_croak(aTHX_ "Can't do setuid\n");
2843 }
2844# endif
2845# endif
2846# ifdef IAMSUID
2847 errno = EPERM;
2848 Perl_croak(aTHX_ "Can't open perl script: %s\n",
2849 Strerror(errno));
2850# else
2851 Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
2852 CopFILE(PL_curcop), Strerror(errno));
2853# endif
13281fa4 2854 }
79072805 2855}
8d063cd8 2856
7b89560d
JH		 2857/* Mention
2858 * I_SYSSTATVFS HAS_FSTATVFS
2859 * I_SYSMOUNT
c890dc6c 2860 * I_STATFS HAS_FSTATFS HAS_GETFSSTAT
7b89560d
JH		 2861 * I_MNTENT HAS_GETMNTENT HAS_HASMNTOPT
2862 * here so that metaconfig picks them up. */
2863
104d25b7 2864#ifdef IAMSUID
864dbfa3 2865STATIC int
e688b231 2866S_fd_on_nosuid_fs(pTHX_ int fd)
104d25b7 2867{
0545a864
JH		 2868 int check_okay = 0; /* able to do all the required sys/libcalls */
2869 int on_nosuid = 0; /* the fd is on a nosuid fs */
104d25b7 2870/*
ad27e871 2871 * Preferred order: fstatvfs(), fstatfs(), ustat()+getmnt(), getmntent().
e688b231 2872 * fstatvfs() is UNIX98.
0545a864 2873 * fstatfs() is 4.3 BSD.
ad27e871 2874 * ustat()+getmnt() is pre-4.3 BSD.
0545a864
JH		 2875 * getmntent() is O(number-of-mounted-filesystems) and can hang on
2876 * an irrelevant filesystem while trying to reach the right one.
104d25b7
JH		 2877 */
2878
6439433f
JH		 2879#undef FD_ON_NOSUID_CHECK_OKAY /* found the syscalls to do the check? */
2880
2881# if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
2882 defined(HAS_FSTATVFS)
2883# define FD_ON_NOSUID_CHECK_OKAY
104d25b7 2884 struct statvfs stfs;
6439433f 2885
104d25b7
JH		 2886 check_okay = fstatvfs(fd, &stfs) == 0;
2887 on_nosuid = check_okay && (stfs.f_flag & ST_NOSUID);
6439433f 2888# endif /* fstatvfs */
ac27b0f5 2889
6439433f
JH		 2890# if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
2891 defined(PERL_MOUNT_NOSUID) && \
2892 defined(HAS_FSTATFS) && \
2893 defined(HAS_STRUCT_STATFS) && \
2894 defined(HAS_STRUCT_STATFS_F_FLAGS)
2895# define FD_ON_NOSUID_CHECK_OKAY
e688b231 2896 struct statfs stfs;
6439433f 2897
104d25b7 2898 check_okay = fstatfs(fd, &stfs) == 0;
104d25b7 2899 on_nosuid = check_okay && (stfs.f_flags & PERL_MOUNT_NOSUID);
6439433f
JH		 2900# endif /* fstatfs */
2901
2902# if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
2903 defined(PERL_MOUNT_NOSUID) && \
2904 defined(HAS_FSTAT) && \
2905 defined(HAS_USTAT) && \
2906 defined(HAS_GETMNT) && \
2907 defined(HAS_STRUCT_FS_DATA) && \
2908 defined(NOSTAT_ONE)
2909# define FD_ON_NOSUID_CHECK_OKAY
0545a864 2910 struct stat fdst;
6439433f 2911
0545a864 2912 if (fstat(fd, &fdst) == 0) {
6439433f
JH		 2913 struct ustat us;
2914 if (ustat(fdst.st_dev, &us) == 0) {
2915 struct fs_data fsd;
2916 /* NOSTAT_ONE here because we're not examining fields which
2917 * vary between that case and STAT_ONE. */
ad27e871 2918 if (getmnt((int*)0, &fsd, (int)0, NOSTAT_ONE, us.f_fname) == 0) {
6439433f
JH		 2919 size_t cmplen = sizeof(us.f_fname);
2920 if (sizeof(fsd.fd_req.path) < cmplen)
2921 cmplen = sizeof(fsd.fd_req.path);
2922 if (strnEQ(fsd.fd_req.path, us.f_fname, cmplen) &&
2923 fdst.st_dev == fsd.fd_req.dev) {
2924 check_okay = 1;
2925 on_nosuid = fsd.fd_req.flags & PERL_MOUNT_NOSUID;
2926 }
2927 }
2928 }
2929 }
0545a864 2930 }
6439433f
JH		 2931# endif /* fstat+ustat+getmnt */
2932
2933# if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
2934 defined(HAS_GETMNTENT) && \
2935 defined(HAS_HASMNTOPT) && \
2936 defined(MNTOPT_NOSUID)
2937# define FD_ON_NOSUID_CHECK_OKAY
2938 FILE *mtab = fopen("/etc/mtab", "r");
2939 struct mntent *entry;
2940 struct stat stb, fsb;
104d25b7
JH		 2941
2942 if (mtab && (fstat(fd, &stb) == 0)) {
6439433f
JH		 2943 while (entry = getmntent(mtab)) {
2944 if (stat(entry->mnt_dir, &fsb) == 0
2945 && fsb.st_dev == stb.st_dev)
2946 {
2947 /* found the filesystem */
2948 check_okay = 1;
2949 if (hasmntopt(entry, MNTOPT_NOSUID))
2950 on_nosuid = 1;
2951 break;
2952 } /* A single fs may well fail its stat(). */
2953 }
104d25b7
JH		 2954 }
2955 if (mtab)
6439433f
JH		 2956 fclose(mtab);
2957# endif /* getmntent+hasmntopt */
0545a864 2958
ac27b0f5 2959 if (!check_okay)
0545a864 2960 Perl_croak(aTHX_ "Can't check filesystem of script \"%s\" for nosuid", PL_origfilename);
104d25b7
JH		 2961 return on_nosuid;
2962}
2963#endif /* IAMSUID */
2964
76e3520e 2965STATIC void
cea2e8a9 2966S_validate_suid(pTHX_ char *validarg, char *scriptname, int fdscript)
79072805 2967{
155aba94 2968#ifdef IAMSUID
96436eeb 2969 int which;
155aba94 2970#endif
96436eeb 2971
13281fa4
LW		 2972 /* do we need to emulate setuid on scripts? */
2973
2974 /* This code is for those BSD systems that have setuid #! scripts disabled
2975 * in the kernel because of a security problem. Merely defining DOSUID
2976 * in perl will not fix that problem, but if you have disabled setuid
2977 * scripts in the kernel, this will attempt to emulate setuid and setgid
2978 * on scripts that have those now-otherwise-useless bits set. The setuid
27e2fb84
LW		 2979 * root version must be called suidperl or sperlN.NNN. If regular perl
2980 * discovers that it has opened a setuid script, it calls suidperl with
2981 * the same argv that it had. If suidperl finds that the script it has
2982 * just opened is NOT setuid root, it sets the effective uid back to the
2983 * uid. We don't just make perl setuid root because that loses the
2984 * effective uid we had before invoking perl, if it was different from the
2985 * uid.
13281fa4
LW		 2986 *
2987 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
2988 * be defined in suidperl only. suidperl must be setuid root. The
2989 * Configure script will set this up for you if you want it.
2990 */
a687059c 2991
13281fa4 2992#ifdef DOSUID
6e72f9df 2993 char *s, *s2;
a0d0e21e 2994
b28d0864 2995 if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0) /* normal stat is insecure */
cea2e8a9 2996 Perl_croak(aTHX_ "Can't stat script \"%s\"",PL_origfilename);
b28d0864 2997 if (fdscript < 0 && PL_statbuf.st_mode & (S_ISUID|S_ISGID)) {
79072805 2998 I32 len;
2d8e6c8d 2999 STRLEN n_a;
13281fa4 3000
a687059c 3001#ifdef IAMSUID
fe14fcc3 3002#ifndef HAS_SETREUID
a687059c
LW		 3003 /* On this access check to make sure the directories are readable,
3004 * there is actually a small window that the user could use to make
3005 * filename point to an accessible directory. So there is a faint
3006 * chance that someone could execute a setuid script down in a
3007 * non-accessible directory. I don't know what to do about that.
3008 * But I don't think it's too important. The manual lies when
3009 * it says access() is useful in setuid programs.
3010 */
cc49e20b 3011 if (PerlLIO_access(CopFILE(PL_curcop),1)) /*double check*/
cea2e8a9 3012 Perl_croak(aTHX_ "Permission denied");
a687059c
LW		 3013#else
3014 /* If we can swap euid and uid, then we can determine access rights
3015 * with a simple stat of the file, and then compare device and
3016 * inode to make sure we did stat() on the same file we opened.
3017 * Then we just have to make sure he or she can execute it.
3018 */
3019 {
3020 struct stat tmpstatbuf;
3021
85e6fe83
LW		 3022 if (
3023#ifdef HAS_SETREUID
b28d0864 3024 setreuid(PL_euid,PL_uid) < 0
a0d0e21e
LW		 3025#else
3026# if HAS_SETRESUID
b28d0864 3027 setresuid(PL_euid,PL_uid,(Uid_t)-1) < 0
a0d0e21e 3028# endif
85e6fe83 3029#endif
b28d0864 3030 || PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid)
cea2e8a9 3031 Perl_croak(aTHX_ "Can't swap uid and euid"); /* really paranoid */
cc49e20b 3032 if (PerlLIO_stat(CopFILE(PL_curcop),&tmpstatbuf) < 0)
cea2e8a9 3033 Perl_croak(aTHX_ "Permission denied"); /* testing full pathname here */
2bb3463c 3034#if defined(IAMSUID) && !defined(NO_NOSUID_CHECK)
e688b231 3035 if (fd_on_nosuid_fs(PerlIO_fileno(PL_rsfp)))
cea2e8a9 3036 Perl_croak(aTHX_ "Permission denied");
104d25b7 3037#endif
b28d0864
NIS		 3038 if (tmpstatbuf.st_dev != PL_statbuf.st_dev ||
3039 tmpstatbuf.st_ino != PL_statbuf.st_ino) {
3040 (void)PerlIO_close(PL_rsfp);
cea2e8a9 3041 Perl_croak(aTHX_ "Permission denied\n");
a687059c 3042 }
85e6fe83
LW		 3043 if (
3044#ifdef HAS_SETREUID
b28d0864 3045 setreuid(PL_uid,PL_euid) < 0
a0d0e21e
LW		 3046#else
3047# if defined(HAS_SETRESUID)
b28d0864 3048 setresuid(PL_uid,PL_euid,(Uid_t)-1) < 0
a0d0e21e 3049# endif
85e6fe83 3050#endif
b28d0864 3051 || PerlProc_getuid() != PL_uid || PerlProc_geteuid() != PL_euid)
cea2e8a9 3052 Perl_croak(aTHX_ "Can't reswap uid and euid");
b28d0864 3053 if (!cando(S_IXUSR,FALSE,&PL_statbuf)) /* can real uid exec? */
cea2e8a9 3054 Perl_croak(aTHX_ "Permission denied\n");
a687059c 3055 }
fe14fcc3 3056#endif /* HAS_SETREUID */
a687059c
LW		 3057#endif /* IAMSUID */
3058
b28d0864 3059 if (!S_ISREG(PL_statbuf.st_mode))
cea2e8a9 3060 Perl_croak(aTHX_ "Permission denied");
b28d0864 3061 if (PL_statbuf.st_mode & S_IWOTH)
cea2e8a9 3062 Perl_croak(aTHX_ "Setuid/gid script is writable by world");
6b88bc9c 3063 PL_doswitches = FALSE; /* -s is insecure in suid */
57843af0 3064 CopLINE_inc(PL_curcop);
6b88bc9c 3065 if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch ||
2d8e6c8d 3066 strnNE(SvPV(PL_linestr,n_a),"#!",2) ) /* required even on Sys V */
cea2e8a9 3067 Perl_croak(aTHX_ "No #! line");
2d8e6c8d 3068 s = SvPV(PL_linestr,n_a)+2;
663a0e37 3069 if (*s == ' ') s++;
45d8adaa 3070 while (!isSPACE(*s)) s++;
2d8e6c8d 3071 for (s2 = s; (s2 > SvPV(PL_linestr,n_a)+2 &&
6e72f9df 3072 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
3073 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
cea2e8a9 3074 Perl_croak(aTHX_ "Not a perl script");
a687059c 3075 while (*s == ' ' || *s == '\t') s++;
13281fa4
LW		 3076 /*
3077 * #! arg must be what we saw above. They can invoke it by
3078 * mentioning suidperl explicitly, but they may not add any strange
3079 * arguments beyond what #! says if they do invoke suidperl that way.
3080 */
3081 len = strlen(validarg);
3082 if (strEQ(validarg," PHOOEY ") ||
45d8adaa 3083 strnNE(s,validarg,len) || !isSPACE(s[len]))
cea2e8a9 3084 Perl_croak(aTHX_ "Args must match #! line");
a687059c
LW		 3085
3086#ifndef IAMSUID
b28d0864
NIS		 3087 if (PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) &&
3088 PL_euid == PL_statbuf.st_uid)
3089 if (!PL_do_undump)
cea2e8a9 3090 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
a687059c
LW		 3091FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
3092#endif /* IAMSUID */
13281fa4 3093
b28d0864
NIS		 3094 if (PL_euid) { /* oops, we're not the setuid root perl */
3095 (void)PerlIO_close(PL_rsfp);
13281fa4 3096#ifndef IAMSUID
46fc3d4c 3097 /* try again */
a7cb1f99 3098 PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT, BIN_EXP,
273cf8d1
GS		 3099 (int)PERL_REVISION, (int)PERL_VERSION,
3100 (int)PERL_SUBVERSION), PL_origargv);
13281fa4 3101#endif
cea2e8a9 3102 Perl_croak(aTHX_ "Can't do setuid\n");
13281fa4
LW		 3103 }
3104
b28d0864 3105 if (PL_statbuf.st_mode & S_ISGID && PL_statbuf.st_gid != PL_egid) {
fe14fcc3 3106#ifdef HAS_SETEGID
b28d0864 3107 (void)setegid(PL_statbuf.st_gid);
a687059c 3108#else
fe14fcc3 3109#ifdef HAS_SETREGID
b28d0864 3110 (void)setregid((Gid_t)-1,PL_statbuf.st_gid);
85e6fe83
LW		 3111#else
3112#ifdef HAS_SETRESGID
b28d0864 3113 (void)setresgid((Gid_t)-1,PL_statbuf.st_gid,(Gid_t)-1);
a687059c 3114#else
b28d0864 3115 PerlProc_setgid(PL_statbuf.st_gid);
a687059c
LW		 3116#endif
3117#endif
85e6fe83 3118#endif
b28d0864 3119 if (PerlProc_getegid() != PL_statbuf.st_gid)
cea2e8a9 3120 Perl_croak(aTHX_ "Can't do setegid!\n");
83025b21 3121 }
b28d0864
NIS		 3122 if (PL_statbuf.st_mode & S_ISUID) {
3123 if (PL_statbuf.st_uid != PL_euid)
fe14fcc3 3124#ifdef HAS_SETEUID
b28d0864 3125 (void)seteuid(PL_statbuf.st_uid); /* all that for this */
a687059c 3126#else
fe14fcc3 3127#ifdef HAS_SETREUID
b28d0864 3128 (void)setreuid((Uid_t)-1,PL_statbuf.st_uid);
85e6fe83
LW		 3129#else
3130#ifdef HAS_SETRESUID
b28d0864 3131 (void)setresuid((Uid_t)-1,PL_statbuf.st_uid,(Uid_t)-1);
a687059c 3132#else
b28d0864 3133 PerlProc_setuid(PL_statbuf.st_uid);
a687059c
LW		 3134#endif
3135#endif
85e6fe83 3136#endif
b28d0864 3137 if (PerlProc_geteuid() != PL_statbuf.st_uid)
cea2e8a9 3138 Perl_croak(aTHX_ "Can't do seteuid!\n");
a687059c 3139 }
b28d0864 3140 else if (PL_uid) { /* oops, mustn't run as root */
fe14fcc3 3141#ifdef HAS_SETEUID
b28d0864 3142 (void)seteuid((Uid_t)PL_uid);
a687059c 3143#else
fe14fcc3 3144#ifdef HAS_SETREUID
b28d0864 3145 (void)setreuid((Uid_t)-1,(Uid_t)PL_uid);
a687059c 3146#else
85e6fe83 3147#ifdef HAS_SETRESUID
b28d0864 3148 (void)setresuid((Uid_t)-1,(Uid_t)PL_uid,(Uid_t)-1);
85e6fe83 3149#else
b28d0864 3150 PerlProc_setuid((Uid_t)PL_uid);
85e6fe83 3151#endif
a687059c
LW		 3152#endif
3153#endif
b28d0864 3154 if (PerlProc_geteuid() != PL_uid)
cea2e8a9 3155 Perl_croak(aTHX_ "Can't do seteuid!\n");
83025b21 3156 }
748a9306 3157 init_ids();
b28d0864 3158 if (!cando(S_IXUSR,TRUE,&PL_statbuf))
cea2e8a9 3159 Perl_croak(aTHX_ "Permission denied\n"); /* they can't do this */
13281fa4
LW		 3160 }
3161#ifdef IAMSUID
6b88bc9c 3162 else if (PL_preprocess)
cea2e8a9 3163 Perl_croak(aTHX_ "-P not allowed for setuid/setgid script\n");
96436eeb 3164 else if (fdscript >= 0)
cea2e8a9 3165 Perl_croak(aTHX_ "fd script not allowed in suidperl\n");
13281fa4 3166 else
cea2e8a9 3167 Perl_croak(aTHX_ "Script is not setuid/setgid in suidperl\n");
96436eeb 3168
3169 /* We absolutely must clear out any saved ids here, so we */
3170 /* exec the real perl, substituting fd script for scriptname. */
3171 /* (We pass script name as "subdir" of fd, which perl will grok.) */
b28d0864
NIS		 3172 PerlIO_rewind(PL_rsfp);
3173 PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0); /* just in case rewind didn't */
6b88bc9c
GS		 3174 for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ;
3175 if (!PL_origargv[which])
cea2e8a9
GS		 3176 Perl_croak(aTHX_ "Permission denied");
3177 PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s",
6b88bc9c 3178 PerlIO_fileno(PL_rsfp), PL_origargv[which]));
96436eeb 3179#if defined(HAS_FCNTL) && defined(F_SETFD)
b28d0864 3180 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0); /* ensure no close-on-exec */
96436eeb 3181#endif
a7cb1f99 3182 PerlProc_execv(Perl_form(aTHX_ "%s/perl"PERL_FS_VER_FMT, BIN_EXP,
273cf8d1
GS		 3183 (int)PERL_REVISION, (int)PERL_VERSION,
3184 (int)PERL_SUBVERSION), PL_origargv);/* try again */
cea2e8a9 3185 Perl_croak(aTHX_ "Can't do setuid\n");
13281fa4 3186#endif /* IAMSUID */
a687059c 3187#else /* !DOSUID */
3280af22 3188 if (PL_euid != PL_uid || PL_egid != PL_gid) { /* (suidperl doesn't exist, in fact) */
a687059c 3189#ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
b28d0864
NIS		 3190 PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf); /* may be either wrapped or real suid */
3191 if ((PL_euid != PL_uid && PL_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
a687059c 3192 ||
b28d0864 3193 (PL_egid != PL_gid && PL_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
a687059c 3194 )
b28d0864 3195 if (!PL_do_undump)
cea2e8a9 3196 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
a687059c
LW		 3197FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
3198#endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
3199 /* not set-id, must be wrapped */
a687059c 3200 }
13281fa4 3201#endif /* DOSUID */
79072805 3202}
13281fa4 3203
76e3520e 3204STATIC void
cea2e8a9 3205S_find_beginning(pTHX)
79072805 3206{
6e72f9df 3207 register char *s, *s2;
33b78306
LW		 3208
3209 /* skip forward in input to the real script? */
3210
bbce6d69 3211 forbid_setid("-x");
bf4acbe4 3212#ifdef MACOS_TRADITIONAL
084592ab 3213 /* Since the Mac OS does not honor #! arguments for us, we do it ourselves */
ac27b0f5 3214
bf4acbe4
GS		 3215 while (PL_doextract || gMacPerl_AlwaysExtract) {
3216 if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
3217 if (!gMacPerl_AlwaysExtract)
3218 Perl_croak(aTHX_ "No Perl script found in input\n");
3219
3220 if (PL_doextract) /* require explicit override ? */
3221 if (!OverrideExtract(PL_origfilename))
3222 Perl_croak(aTHX_ "User aborted script\n");
3223 else
3224 PL_doextract = FALSE;
3225
3226 /* Pater peccavi, file does not have #! */
3227 PerlIO_rewind(PL_rsfp);
ac27b0f5 3228
bf4acbe4
GS		 3229 break;
3230 }
3231#else
3280af22
NIS		 3232 while (PL_doextract) {
3233 if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch)
cea2e8a9 3234 Perl_croak(aTHX_ "No Perl script found in input\n");
bf4acbe4 3235#endif
4f0c37ba
IZ		 3236 s2 = s;
3237 if (*s == '#' && s[1] == '!' && ((s = instr(s,"perl")) || (s = instr(s2,"PERL")))) {
3280af22
NIS		 3238 PerlIO_ungetc(PL_rsfp, '\n'); /* to keep line count right */
3239 PL_doextract = FALSE;
6e72f9df 3240 while (*s && !(isSPACE (*s) || *s == '#')) s++;
3241 s2 = s;
3242 while (*s == ' ' || *s == '\t') s++;
3243 if (*s++ == '-') {
3244 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
3245 if (strnEQ(s2-4,"perl",4))
3246 /*SUPPRESS 530*/
155aba94
GS		 3247 while ((s = moreswitches(s)))
3248 ;
33b78306 3249 }
95e8664e
CN		 3250#ifdef MACOS_TRADITIONAL
3251 break;
3252#endif
83025b21
LW		 3253 }
3254 }
3255}
3256
afe37c7d 3257
76e3520e 3258STATIC void
cea2e8a9 3259S_init_ids(pTHX)
352d5a3a 3260{
d8eceb89
JH		 3261 PL_uid = PerlProc_getuid();
3262 PL_euid = PerlProc_geteuid();
3263 PL_gid = PerlProc_getgid();
3264 PL_egid = PerlProc_getegid();
748a9306 3265#ifdef VMS
b28d0864
NIS		 3266 PL_uid |= PL_gid << 16;
3267 PL_euid |= PL_egid << 16;
748a9306 3268#endif
3280af22 3269 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
748a9306 3270}
79072805 3271
76e3520e 3272STATIC void
cea2e8a9 3273S_forbid_setid(pTHX_ char *s)
bbce6d69 3274{
3280af22 3275 if (PL_euid != PL_uid)
cea2e8a9 3276 Perl_croak(aTHX_ "No %s allowed while running setuid", s);
3280af22 3277 if (PL_egid != PL_gid)
cea2e8a9 3278 Perl_croak(aTHX_ "No %s allowed while running setgid", s);
bbce6d69 3279}
3280
1ee4443e
IZ		 3281void
3282Perl_init_debugger(pTHX)
748a9306 3283{
1ee4443e
IZ		 3284 HV *ostash = PL_curstash;
3285
3280af22
NIS		 3286 PL_curstash = PL_debstash;
3287 PL_dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
3288 AvREAL_off(PL_dbargs);
3289 PL_DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
3290 PL_DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
3291 PL_DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
1ee4443e 3292 sv_upgrade(GvSV(PL_DBsub), SVt_IV); /* IVX accessed if PERLDB_SUB_NN */
3280af22 3293 PL_DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
ac27b0f5 3294 sv_setiv(PL_DBsingle, 0);
3280af22 3295 PL_DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
ac27b0f5 3296 sv_setiv(PL_DBtrace, 0);
3280af22 3297 PL_DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
ac27b0f5 3298 sv_setiv(PL_DBsignal, 0);
1ee4443e 3299 PL_curstash = ostash;
352d5a3a
LW		 3300}
3301
2ce36478
SM		 3302#ifndef STRESS_REALLOC
3303#define REASONABLE(size) (size)
3304#else
3305#define REASONABLE(size) (1) /* unreasonable */
3306#endif
3307
11343788 3308void
cea2e8a9 3309Perl_init_stacks(pTHX)
79072805 3310{
e336de0d 3311 /* start with 128-item stack and 8K cxstack */
3280af22 3312 PL_curstackinfo = new_stackinfo(REASONABLE(128),
e336de0d 3313 REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
3280af22
NIS		 3314 PL_curstackinfo->si_type = PERLSI_MAIN;
3315 PL_curstack = PL_curstackinfo->si_stack;
3316 PL_mainstack = PL_curstack; /* remember in case we switch stacks */
79072805 3317
3280af22
NIS		 3318 PL_stack_base = AvARRAY(PL_curstack);
3319 PL_stack_sp = PL_stack_base;
3320 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
8990e307 3321
3280af22
NIS		 3322 New(50,PL_tmps_stack,REASONABLE(128),SV*);
3323 PL_tmps_floor = -1;
3324 PL_tmps_ix = -1;
3325 PL_tmps_max = REASONABLE(128);
8990e307 3326
3280af22
NIS		 3327 New(54,PL_markstack,REASONABLE(32),I32);
3328 PL_markstack_ptr = PL_markstack;
3329 PL_markstack_max = PL_markstack + REASONABLE(32);
79072805 3330
ce2f7c3b 3331 SET_MARK_OFFSET;
e336de0d 3332
3280af22
NIS		 3333 New(54,PL_scopestack,REASONABLE(32),I32);
3334 PL_scopestack_ix = 0;
3335 PL_scopestack_max = REASONABLE(32);
79072805 3336
3280af22
NIS		 3337 New(54,PL_savestack,REASONABLE(128),ANY);
3338 PL_savestack_ix = 0;
3339 PL_savestack_max = REASONABLE(128);
79072805 3340
3280af22
NIS		 3341 New(54,PL_retstack,REASONABLE(16),OP*);
3342 PL_retstack_ix = 0;
3343 PL_retstack_max = REASONABLE(16);
378cc40b 3344}
33b78306 3345
2ce36478
SM		 3346#undef REASONABLE
3347
76e3520e 3348STATIC void
cea2e8a9 3349S_nuke_stacks(pTHX)
6e72f9df 3350{
3280af22
NIS		 3351 while (PL_curstackinfo->si_next)
3352 PL_curstackinfo = PL_curstackinfo->si_next;
3353 while (PL_curstackinfo) {
3354 PERL_SI *p = PL_curstackinfo->si_prev;
bac4b2ad 3355 /* curstackinfo->si_stack got nuked by sv_free_arenas() */
3280af22
NIS		 3356 Safefree(PL_curstackinfo->si_cxstack);
3357 Safefree(PL_curstackinfo);
3358 PL_curstackinfo = p;
e336de0d 3359 }
3280af22
NIS		 3360 Safefree(PL_tmps_stack);
3361 Safefree(PL_markstack);
3362 Safefree(PL_scopestack);
3363 Safefree(PL_savestack);
3364 Safefree(PL_retstack);
378cc40b 3365}
33b78306 3366
76e3520e 3367STATIC void
cea2e8a9 3368S_init_lexer(pTHX)
8990e307 3369{
06039172 3370 PerlIO *tmpfp;
3280af22
NIS		 3371 tmpfp = PL_rsfp;
3372 PL_rsfp = Nullfp;
3373 lex_start(PL_linestr);
3374 PL_rsfp = tmpfp;
79cb57f6 3375 PL_subname = newSVpvn("main",4);
8990e307
LW		 3376}
3377
76e3520e 3378STATIC void
cea2e8a9 3379S_init_predump_symbols(pTHX)
45d8adaa 3380{
93a17b20 3381 GV *tmpgv;
af8c498a 3382 IO *io;
79072805 3383
864dbfa3 3384 sv_setpvn(get_sv("\"", TRUE), " ", 1);
3280af22
NIS		 3385 PL_stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
3386 GvMULTI_on(PL_stdingv);
af8c498a 3387 io = GvIOp(PL_stdingv);
a04651f4 3388 IoTYPE(io) = IoTYPE_RDONLY;
af8c498a 3389 IoIFP(io) = PerlIO_stdin();
adbc6bb1 3390 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
a5f75d66 3391 GvMULTI_on(tmpgv);
af8c498a 3392 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
79072805 3393
85e6fe83 3394 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
a5f75d66 3395 GvMULTI_on(tmpgv);
af8c498a 3396 io = GvIOp(tmpgv);
a04651f4 3397 IoTYPE(io) = IoTYPE_WRONLY;
af8c498a 3398 IoOFP(io) = IoIFP(io) = PerlIO_stdout();
4633a7c4 3399 setdefout(tmpgv);
adbc6bb1 3400 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
a5f75d66 3401 GvMULTI_on(tmpgv);
af8c498a 3402 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
79072805 3403
bf49b057
GS		 3404 PL_stderrgv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
3405 GvMULTI_on(PL_stderrgv);
3406 io = GvIOp(PL_stderrgv);
a04651f4 3407 IoTYPE(io) = IoTYPE_WRONLY;
af8c498a 3408 IoOFP(io) = IoIFP(io) = PerlIO_stderr();
adbc6bb1 3409 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
a5f75d66 3410 GvMULTI_on(tmpgv);
af8c498a 3411 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
79072805 3412
3280af22 3413 PL_statname = NEWSV(66,0); /* last filename we did stat on */
ab821d7f 3414
bf4acbe4
GS		 3415 if (PL_osname)
3416 Safefree(PL_osname);
3417 PL_osname = savepv(OSNAME);
79072805 3418}
33b78306 3419
a11ec5a9
RGS		 3420void
3421Perl_init_argv_symbols(pTHX_ register int argc, register char **argv)
33b78306 3422{
79072805 3423 char *s;
79072805 3424 argc--,argv++; /* skip name of script */
3280af22 3425 if (PL_doswitches) {
79072805
LW		 3426 for (; argc > 0 && **argv == '-'; argc--,argv++) {
3427 if (!argv[0][1])
3428 break;
379d538a 3429 if (argv[0][1] == '-' && !argv[0][2]) {
79072805
LW		 3430 argc--,argv++;
3431 break;
3432 }
155aba94 3433 if ((s = strchr(argv[0], '='))) {
79072805 3434 *s++ = '\0';
85e6fe83 3435 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
79072805
LW		 3436 }
3437 else
85e6fe83 3438 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
fe14fcc3 3439 }
79072805 3440 }
a11ec5a9
RGS		 3441 if ((PL_argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV))) {
3442 GvMULTI_on(PL_argvgv);
3443 (void)gv_AVadd(PL_argvgv);
3444 av_clear(GvAVn(PL_argvgv));
3445 for (; argc > 0; argc--,argv++) {
3446 SV *sv = newSVpv(argv[0],0);
3447 av_push(GvAVn(PL_argvgv),sv);
3448 if (PL_widesyscalls)
3449 (void)sv_utf8_decode(sv);
3450 }
3451 }
3452}
3453
04fee9b5
NIS		 3454#ifdef HAS_PROCSELFEXE
3455/* This is a function so that we don't hold on to MAXPATHLEN
8338e367 3456 bytes of stack longer than necessary
04fee9b5
NIS		 3457 */
3458STATIC void
3459S_procself_val(pTHX_ SV *sv, char *arg0)
3460{
3461 char buf[MAXPATHLEN];
d13a6521 3462 int len = readlink(PROCSELFEXE_PATH, buf, sizeof(buf) - 1);
d103ec31
JH		 3463 /* FreeBSD's implementation is acknowledged to be imperfect, sometimes
3464 returning the text "unknown" from the readlink rather than the path
78cb7c00 3465 to the executable (or returning an error from the readlink). Any valid
d103ec31
JH		 3466 path has a '/' in it somewhere, so use that to validate the result.
3467 See http://www.freebsd.org/cgi/query-pr.cgi?pr=35703
3468 */
78cb7c00 3469 if (len > 0 && memchr(buf, '/', len)) {
04fee9b5
NIS		 3470 sv_setpvn(sv,buf,len);
3471 }
3472 else {
3473 sv_setpv(sv,arg0);
3474 }
3475}
3476#endif /* HAS_PROCSELFEXE */
3477
a11ec5a9
RGS		 3478STATIC void
3479S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env)
3480{
3481 char *s;
3482 SV *sv;
3483 GV* tmpgv;
a11ec5a9 3484
3280af22
NIS		 3485 PL_toptarget = NEWSV(0,0);
3486 sv_upgrade(PL_toptarget, SVt_PVFM);
3487 sv_setpvn(PL_toptarget, "", 0);
3488 PL_bodytarget = NEWSV(0,0);
3489 sv_upgrade(PL_bodytarget, SVt_PVFM);
3490 sv_setpvn(PL_bodytarget, "", 0);
3491 PL_formtarget = PL_bodytarget;
79072805 3492
bbce6d69 3493 TAINT;
a11ec5a9
RGS		 3494
3495 init_argv_symbols(argc,argv);
3496
155aba94 3497 if ((tmpgv = gv_fetchpv("0",TRUE, SVt_PV))) {
bf4acbe4
GS		 3498#ifdef MACOS_TRADITIONAL
3499 /* $0 is not majick on a Mac */
3500 sv_setpv(GvSV(tmpgv),MacPerl_MPWFileName(PL_origfilename));
3501#else
3280af22 3502 sv_setpv(GvSV(tmpgv),PL_origfilename);
79072805 3503 magicname("0", "0", 1);
bf4acbe4 3504#endif
79072805 3505 }
04fee9b5
NIS		 3506 if ((tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))) {/* $^X */
3507#ifdef HAS_PROCSELFEXE
3508 S_procself_val(aTHX_ GvSV(tmpgv), PL_origargv[0]);
3509#else
8338e367 3510#ifdef OS2
23da6c43 3511 sv_setpv(GvSV(tmpgv), os2_execname(aTHX));
8338e367
JH		 3512#else
3513 sv_setpv(GvSV(tmpgv),PL_origargv[0]);
3514#endif
04fee9b5
NIS		 3515#endif
3516 }
155aba94 3517 if ((PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV))) {
79072805 3518 HV *hv;
3280af22
NIS		 3519 GvMULTI_on(PL_envgv);
3520 hv = GvHVn(PL_envgv);
14befaf4 3521 hv_magic(hv, Nullgv, PERL_MAGIC_env);
fa6a1c44 3522#ifdef USE_ENVIRON_ARRAY
4633a7c4
LW		 3523 /* Note that if the supplied env parameter is actually a copy
3524 of the global environ then it may now point to free'd memory
3525 if the environment has been modified since. To avoid this
3526 problem we treat env==NULL as meaning 'use the default'
3527 */
3528 if (!env)
3529 env = environ;
5aabfad6 3530 if (env != environ)
79072805 3531 environ[0] = Nullch;
764df951
IZ		 3532 if (env)
3533 for (; *env; env++) {
93a17b20 3534 if (!(s = strchr(*env,'=')))
79072805 3535 continue;
60ce6247 3536#if defined(MSDOS)
61968511 3537 *s = '\0';
137443ea 3538 (void)strupr(*env);
61968511 3539 *s = '=';
137443ea 3540#endif
61968511 3541 sv = newSVpv(s+1, 0);
79072805 3542 (void)hv_store(hv, *env, s - *env, sv, 0);
61968511
GA		 3543 if (env != environ)
3544 mg_set(sv);
764df951 3545 }
103a7189 3546#endif /* USE_ENVIRON_ARRAY */
79072805 3547 }
bbce6d69 3548 TAINT_NOT;
306196c3
MS		 3549 if ((tmpgv = gv_fetchpv("$",TRUE, SVt_PV))) {
3550 SvREADONLY_off(GvSV(tmpgv));
7766f137 3551 sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
306196c3
MS		 3552 SvREADONLY_on(GvSV(tmpgv));
3553 }
33b78306 3554}
34de22dd 3555
76e3520e 3556STATIC void
cea2e8a9 3557S_init_perllib(pTHX)
34de22dd 3558{
85e6fe83 3559 char *s;
3280af22 3560 if (!PL_tainting) {
552a7a9b 3561#ifndef VMS
76e3520e 3562 s = PerlEnv_getenv("PERL5LIB");
85e6fe83 3563 if (s)
9c8a64f0 3564 incpush(s, TRUE, TRUE);
85e6fe83 3565 else
9c8a64f0 3566 incpush(PerlEnv_getenv("PERLLIB"), FALSE, FALSE);
552a7a9b 3567#else /* VMS */
3568 /* Treat PERL5?LIB as a possible search list logical name -- the
3569 * "natural" VMS idiom for a Unix path string. We allow each
3570 * element to be a set of |-separated directories for compatibility.
3571 */
3572 char buf[256];
3573 int idx = 0;
3574 if (my_trnlnm("PERL5LIB",buf,0))
9c8a64f0 3575 do { incpush(buf,TRUE,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
552a7a9b 3576 else
9c8a64f0 3577 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE,FALSE);
552a7a9b 3578#endif /* VMS */
85e6fe83 3579 }
34de22dd 3580
c90c0ff4 3581/* Use the ~-expanded versions of APPLLIB (undocumented),
65f19062 3582 ARCHLIB PRIVLIB SITEARCH SITELIB VENDORARCH and VENDORLIB
df5cef82 3583*/
4633a7c4 3584#ifdef APPLLIB_EXP
9c8a64f0 3585 incpush(APPLLIB_EXP, TRUE, TRUE);
16d20bd9 3586#endif
4633a7c4 3587
fed7345c 3588#ifdef ARCHLIB_EXP
9c8a64f0 3589 incpush(ARCHLIB_EXP, FALSE, FALSE);
a0d0e21e 3590#endif
bf4acbe4
GS		 3591#ifdef MACOS_TRADITIONAL
3592 {
3593 struct stat tmpstatbuf;
3594 SV * privdir = NEWSV(55, 0);
3595 char * macperl = PerlEnv_getenv("MACPERL");
3596
3597 if (!macperl)
3598 macperl = "";
3599
3600 Perl_sv_setpvf(aTHX_ privdir, "%slib:", macperl);
3601 if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode))
3602 incpush(SvPVX(privdir), TRUE, FALSE);
3603 Perl_sv_setpvf(aTHX_ privdir, "%ssite_perl:", macperl);
3604 if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode))
3605 incpush(SvPVX(privdir), TRUE, FALSE);
ac27b0f5 3606
bf4acbe4
GS		 3607 SvREFCNT_dec(privdir);
3608 }
3609 if (!PL_tainting)
3610 incpush(":", FALSE, FALSE);
3611#else
fed7345c 3612#ifndef PRIVLIB_EXP
65f19062 3613# define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
34de22dd 3614#endif
ac27b0f5 3615#if defined(WIN32)
9c8a64f0 3616 incpush(PRIVLIB_EXP, TRUE, FALSE);
00dc2f4f 3617#else
9c8a64f0 3618 incpush(PRIVLIB_EXP, FALSE, FALSE);
00dc2f4f 3619#endif
4633a7c4 3620
65f19062 3621#ifdef SITEARCH_EXP
3b290362
GS		 3622 /* sitearch is always relative to sitelib on Windows for
3623 * DLL-based path intuition to work correctly */
3624# if !defined(WIN32)
9c8a64f0 3625 incpush(SITEARCH_EXP, FALSE, FALSE);
65f19062
GS		 3626# endif
3627#endif
3628
4633a7c4 3629#ifdef SITELIB_EXP
65f19062 3630# if defined(WIN32)
9c8a64f0 3631 incpush(SITELIB_EXP, TRUE, FALSE); /* this picks up sitearch as well */
65f19062 3632# else
9c8a64f0 3633 incpush(SITELIB_EXP, FALSE, FALSE);
65f19062
GS		 3634# endif
3635#endif
189d1e8d 3636
65f19062 3637#ifdef SITELIB_STEM /* Search for version-specific dirs below here */
9c8a64f0 3638 incpush(SITELIB_STEM, FALSE, TRUE);
81c6dfba 3639#endif
65f19062
GS		 3640
3641#ifdef PERL_VENDORARCH_EXP
4ea817c6 3642 /* vendorarch is always relative to vendorlib on Windows for
3b290362
GS		 3643 * DLL-based path intuition to work correctly */
3644# if !defined(WIN32)
9c8a64f0 3645 incpush(PERL_VENDORARCH_EXP, FALSE, FALSE);
65f19062 3646# endif
4b03c463 3647#endif
65f19062
GS		 3648
3649#ifdef PERL_VENDORLIB_EXP
3650# if defined(WIN32)
9c8a64f0 3651 incpush(PERL_VENDORLIB_EXP, TRUE, FALSE); /* this picks up vendorarch as well */
65f19062 3652# else
9c8a64f0 3653 incpush(PERL_VENDORLIB_EXP, FALSE, FALSE);
65f19062 3654# endif
a3635516 3655#endif
65f19062
GS		 3656
3657#ifdef PERL_VENDORLIB_STEM /* Search for version-specific dirs below here */
9c8a64f0 3658 incpush(PERL_VENDORLIB_STEM, FALSE, TRUE);
00dc2f4f 3659#endif
65f19062 3660
3b777bb4
GS		 3661#ifdef PERL_OTHERLIBDIRS
3662 incpush(PERL_OTHERLIBDIRS, TRUE, TRUE);
3663#endif
3664
3280af22 3665 if (!PL_tainting)
9c8a64f0 3666 incpush(".", FALSE, FALSE);
bf4acbe4 3667#endif /* MACOS_TRADITIONAL */
774d564b 3668}
3669
ed79a026 3670#if defined(DOSISH) || defined(EPOC)
774d564b 3671# define PERLLIB_SEP ';'
3672#else
3673# if defined(VMS)
3674# define PERLLIB_SEP '|'
3675# else
bf4acbe4
GS		 3676# if defined(MACOS_TRADITIONAL)
3677# define PERLLIB_SEP ','
3678# else
3679# define PERLLIB_SEP ':'
3680# endif
774d564b 3681# endif
3682#endif
3683#ifndef PERLLIB_MANGLE
3684# define PERLLIB_MANGLE(s,n) (s)
ac27b0f5 3685#endif
774d564b 3686
76e3520e 3687STATIC void
9c8a64f0 3688S_incpush(pTHX_ char *p, int addsubdirs, int addoldvers)
774d564b 3689{
3690 SV *subdir = Nullsv;
774d564b 3691
3b290362 3692 if (!p || !*p)
774d564b 3693 return;
3694
9c8a64f0 3695 if (addsubdirs || addoldvers) {
00db4c45 3696 subdir = sv_newmortal();
774d564b 3697 }
3698
3699 /* Break at all separators */
3700 while (p && *p) {
8c52afec 3701 SV *libdir = NEWSV(55,0);
774d564b 3702 char *s;
3703
3704 /* skip any consecutive separators */
3705 while ( *p == PERLLIB_SEP ) {
3706 /* Uncomment the next line for PATH semantics */
79cb57f6 3707 /* av_push(GvAVn(PL_incgv), newSVpvn(".", 1)); */
774d564b 3708 p++;
3709 }
3710
3711 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
3712 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
3713 (STRLEN)(s - p));
3714 p = s + 1;
3715 }
3716 else {
3717 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
3718 p = Nullch; /* break out */
3719 }
bf4acbe4
GS		 3720#ifdef MACOS_TRADITIONAL
3721 if (!strchr(SvPVX(libdir), ':'))
3722 sv_insert(libdir, 0, 0, ":", 1);
3723 if (SvPVX(libdir)[SvCUR(libdir)-1] != ':')
3724 sv_catpv(libdir, ":");
3725#endif
774d564b 3726
3727 /*
3728 * BEFORE pushing libdir onto @INC we may first push version- and
3729 * archname-specific sub-directories.
3730 */
9c8a64f0 3731 if (addsubdirs || addoldvers) {
29d82f8d 3732#ifdef PERL_INC_VERSION_LIST
8353b874
GS		 3733 /* Configure terminates PERL_INC_VERSION_LIST with a NULL */
3734 const char *incverlist[] = { PERL_INC_VERSION_LIST };
29d82f8d
GS		 3735 const char **incver;
3736#endif
774d564b 3737 struct stat tmpstatbuf;
aa689395 3738#ifdef VMS
3739 char *unix;
3740 STRLEN len;
774d564b 3741
2d8e6c8d 3742 if ((unix = tounixspec_ts(SvPV(libdir,len),Nullch)) != Nullch) {
aa689395 3743 len = strlen(unix);
3744 while (unix[len-1] == '/') len--; /* Cosmetic */
3745 sv_usepvn(libdir,unix,len);
3746 }
3747 else
bf49b057 3748 PerlIO_printf(Perl_error_log,
aa689395 3749 "Failed to unixify @INC element \"%s\"\n",
2d8e6c8d 3750 SvPV(libdir,len));
aa689395 3751#endif
9c8a64f0 3752 if (addsubdirs) {
bf4acbe4
GS		 3753#ifdef MACOS_TRADITIONAL
3754#define PERL_AV_SUFFIX_FMT ""
084592ab
CN		 3755#define PERL_ARCH_FMT "%s:"
3756#define PERL_ARCH_FMT_PATH PERL_FS_VER_FMT PERL_AV_SUFFIX_FMT
bf4acbe4
GS		 3757#else
3758#define PERL_AV_SUFFIX_FMT "/"
3759#define PERL_ARCH_FMT "/%s"
084592ab 3760#define PERL_ARCH_FMT_PATH PERL_AV_SUFFIX_FMT PERL_FS_VER_FMT
bf4acbe4 3761#endif
9c8a64f0 3762 /* .../version/archname if -d .../version/archname */
084592ab 3763 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PATH PERL_ARCH_FMT,
9c8a64f0
GS		 3764 libdir,
3765 (int)PERL_REVISION, (int)PERL_VERSION,
3766 (int)PERL_SUBVERSION, ARCHNAME);
3767 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3768 S_ISDIR(tmpstatbuf.st_mode))
3769 av_push(GvAVn(PL_incgv), newSVsv(subdir));
4b03c463 3770
9c8a64f0 3771 /* .../version if -d .../version */
084592ab 3772 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PATH, libdir,
9c8a64f0
GS		 3773 (int)PERL_REVISION, (int)PERL_VERSION,
3774 (int)PERL_SUBVERSION);
3775 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3776 S_ISDIR(tmpstatbuf.st_mode))
3777 av_push(GvAVn(PL_incgv), newSVsv(subdir));
3778
3779 /* .../archname if -d .../archname */
bf4acbe4 3780 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, libdir, ARCHNAME);
29d82f8d
GS		 3781 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3782 S_ISDIR(tmpstatbuf.st_mode))
3783 av_push(GvAVn(PL_incgv), newSVsv(subdir));
29d82f8d 3784 }
9c8a64f0 3785
9c8a64f0 3786#ifdef PERL_INC_VERSION_LIST
ccc2aad8 3787 if (addoldvers) {
9c8a64f0
GS		 3788 for (incver = incverlist; *incver; incver++) {
3789 /* .../xxx if -d .../xxx */
bf4acbe4 3790 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, libdir, *incver);
9c8a64f0
GS		 3791 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3792 S_ISDIR(tmpstatbuf.st_mode))
3793 av_push(GvAVn(PL_incgv), newSVsv(subdir));
3794 }
3795 }
29d82f8d 3796#endif
774d564b 3797 }
3798
3799 /* finally push this lib directory on the end of @INC */
3280af22 3800 av_push(GvAVn(PL_incgv), libdir);
774d564b 3801 }
34de22dd 3802}
93a17b20 3803
4d1ff10f 3804#ifdef USE_5005THREADS
76e3520e 3805STATIC struct perl_thread *
cea2e8a9 3806S_init_main_thread(pTHX)
199100c8 3807{
c5be433b 3808#if !defined(PERL_IMPLICIT_CONTEXT)
52e1cb5e 3809 struct perl_thread *thr;
cea2e8a9 3810#endif
199100c8
MB		 3811 XPV *xpv;
3812
52e1cb5e 3813 Newz(53, thr, 1, struct perl_thread);
533c011a 3814 PL_curcop = &PL_compiling;
c5be433b 3815 thr->interp = PERL_GET_INTERP;
199100c8 3816 thr->cvcache = newHV();
54b9620d 3817 thr->threadsv = newAV();
940cb80d 3818 /* thr->threadsvp is set when find_threadsv is called */
199100c8
MB		 3819 thr->specific = newAV();
3820 thr->flags = THRf_R_JOINABLE;
3821 MUTEX_INIT(&thr->mutex);
3822 /* Handcraft thrsv similarly to mess_sv */
533c011a 3823 New(53, PL_thrsv, 1, SV);
199100c8 3824 Newz(53, xpv, 1, XPV);
533c011a
NIS		 3825 SvFLAGS(PL_thrsv) = SVt_PV;
3826 SvANY(PL_thrsv) = (void*)xpv;
3827 SvREFCNT(PL_thrsv) = 1 << 30; /* practically infinite */
3828 SvPVX(PL_thrsv) = (char*)thr;
3829 SvCUR_set(PL_thrsv, sizeof(thr));
3830 SvLEN_set(PL_thrsv, sizeof(thr));
3831 *SvEND(PL_thrsv) = '\0'; /* in the trailing_nul field */
3832 thr->oursv = PL_thrsv;
3833 PL_chopset = " \n-";
3967c732 3834 PL_dumpindent = 4;
533c011a
NIS		 3835
3836 MUTEX_LOCK(&PL_threads_mutex);
3837 PL_nthreads++;
199100c8
MB		 3838 thr->tid = 0;
3839 thr->next = thr;
3840 thr->prev = thr;
8dcd6f7b 3841 thr->thr_done = 0;
533c011a 3842 MUTEX_UNLOCK(&PL_threads_mutex);
199100c8 3843
4b026b9e 3844#ifdef HAVE_THREAD_INTERN
4f63d024 3845 Perl_init_thread_intern(thr);
235db74f
GS		 3846#endif
3847
3848#ifdef SET_THREAD_SELF
3849 SET_THREAD_SELF(thr);
199100c8
MB		 3850#else
3851 thr->self = pthread_self();
235db74f 3852#endif /* SET_THREAD_SELF */
06d86050 3853 PERL_SET_THX(thr);
199100c8
MB		 3854
3855 /*
411caa50
JH		 3856 * These must come after the thread self setting
3857 * because sv_setpvn does SvTAINT and the taint
3858 * fields thread selfness being set.
199100c8 3859 */
533c011a
NIS		 3860 PL_toptarget = NEWSV(0,0);
3861 sv_upgrade(PL_toptarget, SVt_PVFM);
3862 sv_setpvn(PL_toptarget, "", 0);
3863 PL_bodytarget = NEWSV(0,0);
3864 sv_upgrade(PL_bodytarget, SVt_PVFM);
3865 sv_setpvn(PL_bodytarget, "", 0);
3866 PL_formtarget = PL_bodytarget;
79cb57f6 3867 thr->errsv = newSVpvn("", 0);
78857c3c 3868 (void) find_threadsv("@"); /* Ensure $@ is initialised early */
5c0ca799 3869
533c011a 3870 PL_maxscream = -1;
a2efc822 3871 PL_peepp = MEMBER_TO_FPTR(Perl_peep);
0b94c7bb
GS		 3872 PL_regcompp = MEMBER_TO_FPTR(Perl_pregcomp);
3873 PL_regexecp = MEMBER_TO_FPTR(Perl_regexec_flags);
3874 PL_regint_start = MEMBER_TO_FPTR(Perl_re_intuit_start);
3875 PL_regint_string = MEMBER_TO_FPTR(Perl_re_intuit_string);
3876 PL_regfree = MEMBER_TO_FPTR(Perl_pregfree);
533c011a
NIS		 3877 PL_regindent = 0;
3878 PL_reginterp_cnt = 0;
5c0ca799 3879
199100c8
MB		 3880 return thr;
3881}
4d1ff10f 3882#endif /* USE_5005THREADS */
199100c8 3883
93a17b20 3884void
864dbfa3 3885Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
93a17b20 3886{
971a9dd3 3887 SV *atsv;
57843af0 3888 line_t oldline = CopLINE(PL_curcop);
312caa8e 3889 CV *cv;
22921e25 3890 STRLEN len;
6224f72b 3891 int ret;
db36c5a1 3892 dJMPENV;
93a17b20 3893
76e3520e 3894 while (AvFILL(paramList) >= 0) {
312caa8e 3895 cv = (CV*)av_shift(paramList);
aefff11f 3896 if (PL_savebegin && (paramList == PL_beginav)) {
059a8bb7
JH		 3897 /* save PL_beginav for compiler */
3898 if (! PL_beginav_save)
3899 PL_beginav_save = newAV();
3900 av_push(PL_beginav_save, (SV*)cv);
3901 } else {
3902 SAVEFREESV(cv);
3903 }
14dd3ad8
GS		 3904#ifdef PERL_FLEXIBLE_EXCEPTIONS
3905 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_list_body), cv);
3906#else
3907 JMPENV_PUSH(ret);
3908#endif
6224f72b 3909 switch (ret) {
312caa8e 3910 case 0:
14dd3ad8
GS		 3911#ifndef PERL_FLEXIBLE_EXCEPTIONS
3912 call_list_body(cv);
3913#endif
971a9dd3 3914 atsv = ERRSV;
312caa8e
CS		 3915 (void)SvPV(atsv, len);
3916 if (len) {
971a9dd3 3917 STRLEN n_a;
312caa8e 3918 PL_curcop = &PL_compiling;
57843af0 3919 CopLINE_set(PL_curcop, oldline);
312caa8e
CS		 3920 if (paramList == PL_beginav)
3921 sv_catpv(atsv, "BEGIN failed--compilation aborted");
3922 else
4f25aa18
GS		 3923 Perl_sv_catpvf(aTHX_ atsv,
3924 "%s failed--call queue aborted",
7d30b5c4 3925 paramList == PL_checkav ? "CHECK"
4f25aa18
GS		 3926 : paramList == PL_initav ? "INIT"
3927 : "END");
312caa8e
CS		 3928 while (PL_scopestack_ix > oldscope)
3929 LEAVE;
14dd3ad8 3930 JMPENV_POP;
971a9dd3 3931 Perl_croak(aTHX_ "%s", SvPVx(atsv, n_a));
a0d0e21e 3932 }
85e6fe83 3933 break;
6224f72b 3934 case 1:
f86702cc 3935 STATUS_ALL_FAILURE;
85e6fe83 3936 /* FALL THROUGH */
6224f72b 3937 case 2:
85e6fe83 3938 /* my_exit() was called */
3280af22 3939 while (PL_scopestack_ix > oldscope)
2ae324a7 3940 LEAVE;
84902520 3941 FREETMPS;
3280af22 3942 PL_curstash = PL_defstash;
3280af22 3943 PL_curcop = &PL_compiling;
57843af0 3944 CopLINE_set(PL_curcop, oldline);
14dd3ad8 3945 JMPENV_POP;
cc3604b1 3946 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED)) {
3280af22 3947 if (paramList == PL_beginav)
cea2e8a9 3948 Perl_croak(aTHX_ "BEGIN failed--compilation aborted");
85e6fe83 3949 else
4f25aa18 3950 Perl_croak(aTHX_ "%s failed--call queue aborted",
7d30b5c4 3951 paramList == PL_checkav ? "CHECK"
4f25aa18
GS		 3952 : paramList == PL_initav ? "INIT"
3953 : "END");
85e6fe83 3954 }
f86702cc 3955 my_exit_jump();
85e6fe83 3956 /* NOTREACHED */
6224f72b 3957 case 3:
312caa8e
CS		 3958 if (PL_restartop) {
3959 PL_curcop = &PL_compiling;
57843af0 3960 CopLINE_set(PL_curcop, oldline);
312caa8e 3961 JMPENV_JUMP(3);
85e6fe83 3962 }
bf49b057 3963 PerlIO_printf(Perl_error_log, "panic: restartop\n");
312caa8e
CS		 3964 FREETMPS;
3965 break;
8990e307 3966 }
14dd3ad8 3967 JMPENV_POP;
93a17b20 3968 }
93a17b20 3969}
93a17b20 3970
14dd3ad8 3971#ifdef PERL_FLEXIBLE_EXCEPTIONS
312caa8e 3972STATIC void *
14dd3ad8 3973S_vcall_list_body(pTHX_ va_list args)
312caa8e 3974{
312caa8e 3975 CV *cv = va_arg(args, CV*);
14dd3ad8
GS		 3976 return call_list_body(cv);
3977}
3978#endif
312caa8e 3979
14dd3ad8
GS		 3980STATIC void *
3981S_call_list_body(pTHX_ CV *cv)
3982{
312caa8e 3983 PUSHMARK(PL_stack_sp);
864dbfa3 3984 call_sv((SV*)cv, G_EVAL|G_DISCARD);
312caa8e
CS		 3985 return NULL;
3986}
3987
f86702cc 3988void
864dbfa3 3989Perl_my_exit(pTHX_ U32 status)
f86702cc 3990{
8b73bbec 3991 DEBUG_S(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
a863c7d1 3992 thr, (unsigned long) status));
f86702cc 3993 switch (status) {
3994 case 0:
3995 STATUS_ALL_SUCCESS;
3996 break;
3997 case 1:
3998 STATUS_ALL_FAILURE;
3999 break;
4000 default:
4001 STATUS_NATIVE_SET(status);
4002 break;
4003 }
4004 my_exit_jump();
4005}
4006
4007void
864dbfa3 4008Perl_my_failure_exit(pTHX)
f86702cc 4009{
4010#ifdef VMS
4011 if (vaxc$errno & 1) {
4fdae800 4012 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
4013 STATUS_NATIVE_SET(44);
f86702cc 4014 }
4015 else {
ff0cee69 4016 if (!vaxc$errno && errno) /* unlikely */
4fdae800 4017 STATUS_NATIVE_SET(44);
f86702cc 4018 else
4fdae800 4019 STATUS_NATIVE_SET(vaxc$errno);
f86702cc 4020 }
4021#else
9b599b2a 4022 int exitstatus;
f86702cc 4023 if (errno & 255)
4024 STATUS_POSIX_SET(errno);
9b599b2a 4025 else {
ac27b0f5 4026 exitstatus = STATUS_POSIX >> 8;
9b599b2a
GS		 4027 if (exitstatus & 255)
4028 STATUS_POSIX_SET(exitstatus);
4029 else
4030 STATUS_POSIX_SET(255);
4031 }
f86702cc 4032#endif
4033 my_exit_jump();
93a17b20
LW		 4034}
4035
76e3520e 4036STATIC void
cea2e8a9 4037S_my_exit_jump(pTHX)
f86702cc 4038{
c09156bb 4039 register PERL_CONTEXT *cx;
f86702cc 4040 I32 gimme;
4041 SV **newsp;
4042
3280af22
NIS		 4043 if (PL_e_script) {
4044 SvREFCNT_dec(PL_e_script);
4045 PL_e_script = Nullsv;
f86702cc 4046 }
4047
3280af22 4048 POPSTACK_TO(PL_mainstack);
f86702cc 4049 if (cxstack_ix >= 0) {
4050 if (cxstack_ix > 0)
4051 dounwind(0);
3280af22 4052 POPBLOCK(cx,PL_curpm);
f86702cc 4053 LEAVE;
4054 }
ff0cee69 4055
6224f72b 4056 JMPENV_JUMP(2);
f86702cc 4057}
873ef191 4058
0cb96387 4059static I32
acfe0abc 4060read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen)
873ef191
GS		 4061{
4062 char *p, *nl;
3280af22 4063 p = SvPVX(PL_e_script);
873ef191 4064 nl = strchr(p, '\n');
3280af22 4065 nl = (nl) ? nl+1 : SvEND(PL_e_script);
7dfe3f66 4066 if (nl-p == 0) {
0cb96387 4067 filter_del(read_e_script);
873ef191 4068 return 0;
7dfe3f66 4069 }
873ef191 4070 sv_catpvn(buf_sv, p, nl-p);
3280af22 4071 sv_chop(PL_e_script, nl);
873ef191
GS		 4072 return 1;
4073}
Unnamed repository; edit this file 'description' to name the repository.