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