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