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