3 * Copyright (c) 1987-2002 Larry Wall
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.
11 * "A ship then new they built for him/of mithril and of elven glass" --Bilbo
15 #define PERL_IN_PERL_C
17 #include "patchlevel.h" /* for local_patches */
19 /* XXX If this causes problems, set i_unistd=undef in the hint file. */
24 #if !defined(STANDARD_C) && !defined(HAS_GETENV_PROTOTYPE) && !defined(PERL_MICRO)
25 char *getenv (char *); /* Usually in <stdlib.h> */
28 static I32 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen);
36 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
42 #if defined(USE_5005THREADS)
43 # define INIT_TLS_AND_INTERP \
45 if (!PL_curinterp) { \
46 PERL_SET_INTERP(my_perl); \
52 # if defined(USE_ITHREADS)
53 # define INIT_TLS_AND_INTERP \
55 if (!PL_curinterp) { \
56 PERL_SET_INTERP(my_perl); \
59 PERL_SET_THX(my_perl); \
63 PERL_SET_THX(my_perl); \
67 # define INIT_TLS_AND_INTERP \
69 if (!PL_curinterp) { \
70 PERL_SET_INTERP(my_perl); \
72 PERL_SET_THX(my_perl); \
77 #ifdef PERL_IMPLICIT_SYS
79 perl_alloc_using(struct IPerlMem* ipM, struct IPerlMem* ipMS,
80 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
81 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
82 struct IPerlDir* ipD, struct IPerlSock* ipS,
83 struct IPerlProc* ipP)
85 PerlInterpreter *my_perl;
86 /* New() needs interpreter, so call malloc() instead */
87 my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
89 Zero(my_perl, 1, PerlInterpreter);
105 =head1 Embedding Functions
107 =for apidoc perl_alloc
109 Allocates a new Perl interpreter. See L<perlembed>.
117 PerlInterpreter *my_perl;
118 #ifdef USE_5005THREADS
122 /* New() needs interpreter, so call malloc() instead */
123 my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
126 Zero(my_perl, 1, PerlInterpreter);
129 #endif /* PERL_IMPLICIT_SYS */
132 =for apidoc perl_construct
134 Initializes a new Perl interpreter. See L<perlembed>.
140 perl_construct(pTHXx)
142 #ifdef USE_5005THREADS
144 struct perl_thread *thr = NULL;
145 #endif /* FAKE_THREADS */
146 #endif /* USE_5005THREADS */
150 PL_perl_destruct_level = 1;
152 if (PL_perl_destruct_level > 0)
156 /* Init the real globals (and main thread)? */
158 #ifdef USE_5005THREADS
159 MUTEX_INIT(&PL_sv_mutex);
161 * Safe to use basic SV functions from now on (though
162 * not things like mortals or tainting yet).
164 MUTEX_INIT(&PL_eval_mutex);
165 COND_INIT(&PL_eval_cond);
166 MUTEX_INIT(&PL_threads_mutex);
167 COND_INIT(&PL_nthreads_cond);
168 # ifdef EMULATE_ATOMIC_REFCOUNTS
169 MUTEX_INIT(&PL_svref_mutex);
170 # endif /* EMULATE_ATOMIC_REFCOUNTS */
172 MUTEX_INIT(&PL_cred_mutex);
173 MUTEX_INIT(&PL_sv_lock_mutex);
174 MUTEX_INIT(&PL_fdpid_mutex);
176 thr = init_main_thread();
177 #endif /* USE_5005THREADS */
179 #ifdef PERL_FLEXIBLE_EXCEPTIONS
180 PL_protect = MEMBER_TO_FPTR(Perl_default_protect); /* for exceptions */
183 PL_curcop = &PL_compiling; /* needed by ckWARN, right away */
185 PL_linestr = NEWSV(65,79);
186 sv_upgrade(PL_linestr,SVt_PVIV);
188 if (!SvREADONLY(&PL_sv_undef)) {
189 /* set read-only and try to insure than we wont see REFCNT==0
192 SvREADONLY_on(&PL_sv_undef);
193 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
195 sv_setpv(&PL_sv_no,PL_No);
197 SvREADONLY_on(&PL_sv_no);
198 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
200 sv_setpv(&PL_sv_yes,PL_Yes);
202 SvREADONLY_on(&PL_sv_yes);
203 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
206 PL_sighandlerp = Perl_sighandler;
207 PL_pidstatus = newHV();
210 PL_rs = newSVpvn("\n", 1);
215 PL_lex_state = LEX_NOTPARSING;
221 SET_NUMERIC_STANDARD();
225 PL_patchlevel = NEWSV(0,4);
226 (void)SvUPGRADE(PL_patchlevel, SVt_PVNV);
227 if (PERL_REVISION > 127 || PERL_VERSION > 127 || PERL_SUBVERSION > 127)
228 SvGROW(PL_patchlevel, UTF8_MAXLEN*3+1);
229 s = (U8*)SvPVX(PL_patchlevel);
230 /* Build version strings using "native" characters */
231 s = uvchr_to_utf8(s, (UV)PERL_REVISION);
232 s = uvchr_to_utf8(s, (UV)PERL_VERSION);
233 s = uvchr_to_utf8(s, (UV)PERL_SUBVERSION);
235 SvCUR_set(PL_patchlevel, s - (U8*)SvPVX(PL_patchlevel));
236 SvPOK_on(PL_patchlevel);
237 SvNVX(PL_patchlevel) = (NV)PERL_REVISION
238 + ((NV)PERL_VERSION / (NV)1000)
239 #if defined(PERL_SUBVERSION) && PERL_SUBVERSION > 0
240 + ((NV)PERL_SUBVERSION / (NV)1000000)
243 SvNOK_on(PL_patchlevel); /* dual valued */
244 SvUTF8_on(PL_patchlevel);
245 SvREADONLY_on(PL_patchlevel);
248 #if defined(LOCAL_PATCH_COUNT)
249 PL_localpatches = local_patches; /* For possible -v */
252 #ifdef HAVE_INTERP_INTERN
256 PerlIO_init(aTHX); /* Hook to IO system */
258 PL_fdpid = newAV(); /* for remembering popen pids by fd */
259 PL_modglobal = newHV(); /* pointers to per-interpreter module globals */
260 PL_errors = newSVpvn("",0);
261 sv_setpvn(PERL_DEBUG_PAD(0), "", 0); /* For regex debugging. */
262 sv_setpvn(PERL_DEBUG_PAD(1), "", 0); /* ext/re needs these */
263 sv_setpvn(PERL_DEBUG_PAD(2), "", 0); /* even without DEBUGGING. */
265 PL_regex_padav = newAV();
266 av_push(PL_regex_padav,(SV*)newAV()); /* First entry is an array of empty elements */
267 PL_regex_pad = AvARRAY(PL_regex_padav);
269 #ifdef USE_REENTRANT_API
270 Perl_reentrant_init(aTHX);
273 /* Note that strtab is a rather special HV. Assumptions are made
274 about not iterating on it, and not adding tie magic to it.
275 It is properly deallocated in perl_destruct() */
278 #ifdef USE_5005THREADS
279 MUTEX_INIT(&PL_strtab_mutex);
281 HvSHAREKEYS_off(PL_strtab); /* mandatory */
282 hv_ksplit(PL_strtab, 512);
284 #if defined(__DYNAMIC__) && (defined(NeXT) || defined(__NeXT__))
285 _dyld_lookup_and_bind
286 ("__environ", (unsigned long *) &environ_pointer, NULL);
289 #ifdef USE_ENVIRON_ARRAY
290 PL_origenviron = environ;
297 =for apidoc perl_destruct
299 Shuts down a Perl interpreter. See L<perlembed>.
307 volatile int destruct_level; /* 0=none, 1=full, 2=full with checks */
309 #ifdef USE_5005THREADS
312 #endif /* USE_5005THREADS */
314 /* wait for all pseudo-forked children to finish */
315 PERL_WAIT_FOR_CHILDREN;
317 #ifdef USE_5005THREADS
319 /* Pass 1 on any remaining threads: detach joinables, join zombies */
321 MUTEX_LOCK(&PL_threads_mutex);
322 DEBUG_S(PerlIO_printf(Perl_debug_log,
323 "perl_destruct: waiting for %d threads...\n",
325 for (t = thr->next; t != thr; t = t->next) {
326 MUTEX_LOCK(&t->mutex);
327 switch (ThrSTATE(t)) {
330 DEBUG_S(PerlIO_printf(Perl_debug_log,
331 "perl_destruct: joining zombie %p\n", t));
332 ThrSETSTATE(t, THRf_DEAD);
333 MUTEX_UNLOCK(&t->mutex);
336 * The SvREFCNT_dec below may take a long time (e.g. av
337 * may contain an object scalar whose destructor gets
338 * called) so we have to unlock threads_mutex and start
341 MUTEX_UNLOCK(&PL_threads_mutex);
343 SvREFCNT_dec((SV*)av);
344 DEBUG_S(PerlIO_printf(Perl_debug_log,
345 "perl_destruct: joined zombie %p OK\n", t));
347 case THRf_R_JOINABLE:
348 DEBUG_S(PerlIO_printf(Perl_debug_log,
349 "perl_destruct: detaching thread %p\n", t));
350 ThrSETSTATE(t, THRf_R_DETACHED);
352 * We unlock threads_mutex and t->mutex in the opposite order
353 * from which we locked them just so that DETACH won't
354 * deadlock if it panics. It's only a breach of good style
355 * not a bug since they are unlocks not locks.
357 MUTEX_UNLOCK(&PL_threads_mutex);
359 MUTEX_UNLOCK(&t->mutex);
362 DEBUG_S(PerlIO_printf(Perl_debug_log,
363 "perl_destruct: ignoring %p (state %u)\n",
365 MUTEX_UNLOCK(&t->mutex);
366 /* fall through and out */
369 /* We leave the above "Pass 1" loop with threads_mutex still locked */
371 /* Pass 2 on remaining threads: wait for the thread count to drop to one */
372 while (PL_nthreads > 1)
374 DEBUG_S(PerlIO_printf(Perl_debug_log,
375 "perl_destruct: final wait for %d threads\n",
377 COND_WAIT(&PL_nthreads_cond, &PL_threads_mutex);
379 /* At this point, we're the last thread */
380 MUTEX_UNLOCK(&PL_threads_mutex);
381 DEBUG_S(PerlIO_printf(Perl_debug_log, "perl_destruct: armageddon has arrived\n"));
382 MUTEX_DESTROY(&PL_threads_mutex);
383 COND_DESTROY(&PL_nthreads_cond);
385 #endif /* !defined(FAKE_THREADS) */
386 #endif /* USE_5005THREADS */
388 destruct_level = PL_perl_destruct_level;
392 if ((s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL"))) {
394 if (destruct_level < i)
401 if(PL_exit_flags & PERL_EXIT_DESTRUCT_END) {
406 if (PL_endav && !PL_minus_c)
407 call_list(PL_scopestack_ix, PL_endav);
413 /* We must account for everything. */
415 /* Destroy the main CV and syntax tree */
417 PL_curpad = AvARRAY(PL_comppad);
418 op_free(PL_main_root);
419 PL_main_root = Nullop;
421 PL_curcop = &PL_compiling;
422 PL_main_start = Nullop;
423 SvREFCNT_dec(PL_main_cv);
427 /* Tell PerlIO we are about to tear things apart in case
428 we have layers which are using resources that should
432 PerlIO_destruct(aTHX);
434 if (PL_sv_objcount) {
436 * Try to destruct global references. We do this first so that the
437 * destructors and destructees still exist. Some sv's might remain.
438 * Non-referenced objects are on their own.
443 /* unhook hooks which will soon be, or use, destroyed data */
444 SvREFCNT_dec(PL_warnhook);
445 PL_warnhook = Nullsv;
446 SvREFCNT_dec(PL_diehook);
449 /* call exit list functions */
450 while (PL_exitlistlen-- > 0)
451 PL_exitlist[PL_exitlistlen].fn(aTHX_ PL_exitlist[PL_exitlistlen].ptr);
453 Safefree(PL_exitlist);
455 if (destruct_level == 0){
457 DEBUG_P(debprofdump());
459 #if defined(PERLIO_LAYERS)
460 /* No more IO - including error messages ! */
461 PerlIO_cleanup(aTHX);
464 /* The exit() function will do everything that needs doing. */
465 return STATUS_NATIVE_EXPORT;;
468 /* jettison our possibly duplicated environment */
469 /* if PERL_USE_SAFE_PUTENV is defined environ will not have been copied
470 * so we certainly shouldn't free it here
472 #if defined(USE_ENVIRON_ARRAY) && !defined(PERL_USE_SAFE_PUTENV)
473 if (environ != PL_origenviron) {
476 for (i = 0; environ[i]; i++)
477 safesysfree(environ[i]);
479 /* Must use safesysfree() when working with environ. */
480 safesysfree(environ);
482 environ = PL_origenviron;
487 /* the syntax tree is shared between clones
488 * so op_free(PL_main_root) only ReREFCNT_dec's
489 * REGEXPs in the parent interpreter
490 * we need to manually ReREFCNT_dec for the clones
493 I32 i = AvFILLp(PL_regex_padav) + 1;
494 SV **ary = AvARRAY(PL_regex_padav);
498 REGEXP *re = INT2PTR(REGEXP *,SvIVX(resv));
500 if (SvFLAGS(resv) & SVf_BREAK) {
501 /* this is PL_reg_curpm, already freed
502 * flag is set in regexec.c:S_regtry
504 SvFLAGS(resv) &= ~SVf_BREAK;
506 else if(SvREPADTMP(resv)) {
507 SvREPADTMP_off(resv);
514 SvREFCNT_dec(PL_regex_padav);
515 PL_regex_padav = Nullav;
519 /* loosen bonds of global variables */
522 (void)PerlIO_close(PL_rsfp);
526 /* Filters for program text */
527 SvREFCNT_dec(PL_rsfp_filters);
528 PL_rsfp_filters = Nullav;
531 PL_preprocess = FALSE;
537 PL_doswitches = FALSE;
538 PL_dowarn = G_WARN_OFF;
539 PL_doextract = FALSE;
540 PL_sawampersand = FALSE; /* must save all match strings */
543 Safefree(PL_inplace);
545 SvREFCNT_dec(PL_patchlevel);
548 SvREFCNT_dec(PL_e_script);
549 PL_e_script = Nullsv;
552 while (--PL_origargc >= 0) {
553 Safefree(PL_origargv[PL_origargc]);
555 Safefree(PL_origargv);
557 /* magical thingies */
559 SvREFCNT_dec(PL_ofs_sv); /* $, */
562 SvREFCNT_dec(PL_ors_sv); /* $\ */
565 SvREFCNT_dec(PL_rs); /* $/ */
568 PL_multiline = 0; /* $* */
569 Safefree(PL_osname); /* $^O */
572 SvREFCNT_dec(PL_statname);
573 PL_statname = Nullsv;
576 /* defgv, aka *_ should be taken care of elsewhere */
578 /* clean up after study() */
579 SvREFCNT_dec(PL_lastscream);
580 PL_lastscream = Nullsv;
581 Safefree(PL_screamfirst);
583 Safefree(PL_screamnext);
587 Safefree(PL_efloatbuf);
588 PL_efloatbuf = Nullch;
591 /* startup and shutdown function lists */
592 SvREFCNT_dec(PL_beginav);
593 SvREFCNT_dec(PL_beginav_save);
594 SvREFCNT_dec(PL_endav);
595 SvREFCNT_dec(PL_checkav);
596 SvREFCNT_dec(PL_initav);
598 PL_beginav_save = Nullav;
603 /* shortcuts just get cleared */
609 PL_argvoutgv = Nullgv;
611 PL_stderrgv = Nullgv;
612 PL_last_in_gv = Nullgv;
614 PL_debstash = Nullhv;
616 /* reset so print() ends up where we expect */
619 SvREFCNT_dec(PL_argvout_stack);
620 PL_argvout_stack = Nullav;
622 SvREFCNT_dec(PL_modglobal);
623 PL_modglobal = Nullhv;
624 SvREFCNT_dec(PL_preambleav);
625 PL_preambleav = Nullav;
626 SvREFCNT_dec(PL_subname);
628 SvREFCNT_dec(PL_linestr);
630 SvREFCNT_dec(PL_pidstatus);
631 PL_pidstatus = Nullhv;
632 SvREFCNT_dec(PL_toptarget);
633 PL_toptarget = Nullsv;
634 SvREFCNT_dec(PL_bodytarget);
635 PL_bodytarget = Nullsv;
636 PL_formtarget = Nullsv;
638 /* free locale stuff */
639 #ifdef USE_LOCALE_COLLATE
640 Safefree(PL_collation_name);
641 PL_collation_name = Nullch;
644 #ifdef USE_LOCALE_NUMERIC
645 Safefree(PL_numeric_name);
646 PL_numeric_name = Nullch;
647 SvREFCNT_dec(PL_numeric_radix_sv);
650 /* clear utf8 character classes */
651 SvREFCNT_dec(PL_utf8_alnum);
652 SvREFCNT_dec(PL_utf8_alnumc);
653 SvREFCNT_dec(PL_utf8_ascii);
654 SvREFCNT_dec(PL_utf8_alpha);
655 SvREFCNT_dec(PL_utf8_space);
656 SvREFCNT_dec(PL_utf8_cntrl);
657 SvREFCNT_dec(PL_utf8_graph);
658 SvREFCNT_dec(PL_utf8_digit);
659 SvREFCNT_dec(PL_utf8_upper);
660 SvREFCNT_dec(PL_utf8_lower);
661 SvREFCNT_dec(PL_utf8_print);
662 SvREFCNT_dec(PL_utf8_punct);
663 SvREFCNT_dec(PL_utf8_xdigit);
664 SvREFCNT_dec(PL_utf8_mark);
665 SvREFCNT_dec(PL_utf8_toupper);
666 SvREFCNT_dec(PL_utf8_totitle);
667 SvREFCNT_dec(PL_utf8_tolower);
668 SvREFCNT_dec(PL_utf8_tofold);
669 PL_utf8_alnum = Nullsv;
670 PL_utf8_alnumc = Nullsv;
671 PL_utf8_ascii = Nullsv;
672 PL_utf8_alpha = Nullsv;
673 PL_utf8_space = Nullsv;
674 PL_utf8_cntrl = Nullsv;
675 PL_utf8_graph = Nullsv;
676 PL_utf8_digit = Nullsv;
677 PL_utf8_upper = Nullsv;
678 PL_utf8_lower = Nullsv;
679 PL_utf8_print = Nullsv;
680 PL_utf8_punct = Nullsv;
681 PL_utf8_xdigit = Nullsv;
682 PL_utf8_mark = Nullsv;
683 PL_utf8_toupper = Nullsv;
684 PL_utf8_totitle = Nullsv;
685 PL_utf8_tolower = Nullsv;
686 PL_utf8_tofold = Nullsv;
688 if (!specialWARN(PL_compiling.cop_warnings))
689 SvREFCNT_dec(PL_compiling.cop_warnings);
690 PL_compiling.cop_warnings = Nullsv;
691 if (!specialCopIO(PL_compiling.cop_io))
692 SvREFCNT_dec(PL_compiling.cop_io);
693 PL_compiling.cop_io = Nullsv;
694 CopFILE_free(&PL_compiling);
695 CopSTASH_free(&PL_compiling);
697 /* Prepare to destruct main symbol table. */
702 SvREFCNT_dec(PL_curstname);
703 PL_curstname = Nullsv;
705 /* clear queued errors */
706 SvREFCNT_dec(PL_errors);
710 if (destruct_level >= 2 && ckWARN_d(WARN_INTERNAL)) {
711 if (PL_scopestack_ix != 0)
712 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
713 "Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
714 (long)PL_scopestack_ix);
715 if (PL_savestack_ix != 0)
716 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
717 "Unbalanced saves: %ld more saves than restores\n",
718 (long)PL_savestack_ix);
719 if (PL_tmps_floor != -1)
720 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced tmps: %ld more allocs than frees\n",
721 (long)PL_tmps_floor + 1);
722 if (cxstack_ix != -1)
723 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced context: %ld more PUSHes than POPs\n",
724 (long)cxstack_ix + 1);
727 /* Now absolutely destruct everything, somehow or other, loops or no. */
728 SvFLAGS(PL_fdpid) |= SVTYPEMASK; /* don't clean out pid table now */
729 SvFLAGS(PL_strtab) |= SVTYPEMASK; /* don't clean out strtab now */
731 /* the 2 is for PL_fdpid and PL_strtab */
732 while (PL_sv_count > 2 && sv_clean_all())
735 SvFLAGS(PL_fdpid) &= ~SVTYPEMASK;
736 SvFLAGS(PL_fdpid) |= SVt_PVAV;
737 SvFLAGS(PL_strtab) &= ~SVTYPEMASK;
738 SvFLAGS(PL_strtab) |= SVt_PVHV;
740 AvREAL_off(PL_fdpid); /* no surviving entries */
741 SvREFCNT_dec(PL_fdpid); /* needed in io_close() */
744 #ifdef HAVE_INTERP_INTERN
748 /* Destruct the global string table. */
750 /* Yell and reset the HeVAL() slots that are still holding refcounts,
751 * so that sv_free() won't fail on them.
759 max = HvMAX(PL_strtab);
760 array = HvARRAY(PL_strtab);
763 if (hent && ckWARN_d(WARN_INTERNAL)) {
764 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
765 "Unbalanced string table refcount: (%d) for \"%s\"",
766 HeVAL(hent) - Nullsv, HeKEY(hent));
767 HeVAL(hent) = Nullsv;
777 SvREFCNT_dec(PL_strtab);
780 /* free the pointer table used for cloning */
781 ptr_table_free(PL_ptr_table);
784 /* free special SVs */
786 SvREFCNT(&PL_sv_yes) = 0;
787 sv_clear(&PL_sv_yes);
788 SvANY(&PL_sv_yes) = NULL;
789 SvFLAGS(&PL_sv_yes) = 0;
791 SvREFCNT(&PL_sv_no) = 0;
793 SvANY(&PL_sv_no) = NULL;
794 SvFLAGS(&PL_sv_no) = 0;
796 SvREFCNT(&PL_sv_undef) = 0;
797 SvREADONLY_off(&PL_sv_undef);
799 if (PL_sv_count != 0 && ckWARN_d(WARN_INTERNAL))
800 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Scalars leaked: %ld\n", (long)PL_sv_count);
802 #if defined(PERLIO_LAYERS)
803 /* No more IO - including error messages ! */
804 PerlIO_cleanup(aTHX);
807 Safefree(PL_origfilename);
808 Safefree(PL_reg_start_tmp);
810 Safefree(PL_reg_curpm);
811 Safefree(PL_reg_poscache);
812 Safefree(HeKEY_hek(&PL_hv_fetch_ent_mh));
813 Safefree(PL_op_mask);
814 Safefree(PL_psig_ptr);
815 Safefree(PL_psig_name);
816 Safefree(PL_bitcount);
817 Safefree(PL_psig_pend);
819 PL_hints = 0; /* Reset hints. Should hints be per-interpreter ? */
821 DEBUG_P(debprofdump());
822 #ifdef USE_5005THREADS
823 MUTEX_DESTROY(&PL_strtab_mutex);
824 MUTEX_DESTROY(&PL_sv_mutex);
825 MUTEX_DESTROY(&PL_eval_mutex);
826 MUTEX_DESTROY(&PL_cred_mutex);
827 MUTEX_DESTROY(&PL_fdpid_mutex);
828 COND_DESTROY(&PL_eval_cond);
829 #ifdef EMULATE_ATOMIC_REFCOUNTS
830 MUTEX_DESTROY(&PL_svref_mutex);
831 #endif /* EMULATE_ATOMIC_REFCOUNTS */
833 /* As the penultimate thing, free the non-arena SV for thrsv */
834 Safefree(SvPVX(PL_thrsv));
835 Safefree(SvANY(PL_thrsv));
838 #endif /* USE_5005THREADS */
840 #ifdef USE_REENTRANT_API
841 Perl_reentrant_free(aTHX);
846 /* As the absolutely last thing, free the non-arena SV for mess() */
849 /* it could have accumulated taint magic */
850 if (SvTYPE(PL_mess_sv) >= SVt_PVMG) {
853 for (mg = SvMAGIC(PL_mess_sv); mg; mg = moremagic) {
854 moremagic = mg->mg_moremagic;
855 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global
857 Safefree(mg->mg_ptr);
861 /* we know that type >= SVt_PV */
862 (void)SvOOK_off(PL_mess_sv);
863 Safefree(SvPVX(PL_mess_sv));
864 Safefree(SvANY(PL_mess_sv));
865 Safefree(PL_mess_sv);
868 return STATUS_NATIVE_EXPORT;
872 =for apidoc perl_free
874 Releases a Perl interpreter. See L<perlembed>.
882 #if defined(WIN32) || defined(NETWARE)
883 # if defined(PERL_IMPLICIT_SYS)
885 void *host = nw_internal_host;
887 void *host = w32_internal_host;
891 nw5_delete_internal_host(host);
893 win32_delete_internal_host(host);
904 Perl_call_atexit(pTHX_ ATEXIT_t fn, void *ptr)
906 Renew(PL_exitlist, PL_exitlistlen+1, PerlExitListEntry);
907 PL_exitlist[PL_exitlistlen].fn = fn;
908 PL_exitlist[PL_exitlistlen].ptr = ptr;
913 =for apidoc perl_parse
915 Tells a Perl interpreter to parse a Perl script. See L<perlembed>.
921 perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env)
926 #ifdef USE_5005THREADS
930 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
933 Perl_croak(aTHX_ "suidperl is no longer needed since the kernel can now execute\n\
934 setuid perl scripts securely.\n");
940 /* we copy rather than point to argv
941 * since perl_clone will copy and perl_destruct
942 * has no way of knowing if we've made a copy or
946 New(0, PL_origargv, i+1, char*);
947 PL_origargv[i] = '\0';
949 PL_origargv[i] = savepv(argv[i]);
957 /* Come here if running an undumped a.out. */
959 PL_origfilename = savepv(argv[0]);
960 PL_do_undump = FALSE;
961 cxstack_ix = -1; /* start label stack again */
963 init_postdump_symbols(argc,argv,env);
968 PL_curpad = AvARRAY(PL_comppad);
969 op_free(PL_main_root);
970 PL_main_root = Nullop;
972 PL_main_start = Nullop;
973 SvREFCNT_dec(PL_main_cv);
977 oldscope = PL_scopestack_ix;
978 PL_dowarn = G_WARN_OFF;
980 #ifdef PERL_FLEXIBLE_EXCEPTIONS
981 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vparse_body), env, xsinit);
987 #ifndef PERL_FLEXIBLE_EXCEPTIONS
988 parse_body(env,xsinit);
991 call_list(oldscope, PL_checkav);
998 /* my_exit() was called */
999 while (PL_scopestack_ix > oldscope)
1002 PL_curstash = PL_defstash;
1004 call_list(oldscope, PL_checkav);
1005 ret = STATUS_NATIVE_EXPORT;
1008 PerlIO_printf(Perl_error_log, "panic: top_env\n");
1016 #ifdef PERL_FLEXIBLE_EXCEPTIONS
1018 S_vparse_body(pTHX_ va_list args)
1020 char **env = va_arg(args, char**);
1021 XSINIT_t xsinit = va_arg(args, XSINIT_t);
1023 return parse_body(env, xsinit);
1028 S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
1030 int argc = PL_origargc;
1031 char **argv = PL_origargv;
1032 char *scriptname = NULL;
1034 VOL bool dosearch = FALSE;
1035 char *validarg = "";
1039 char *cddir = Nullch;
1041 sv_setpvn(PL_linestr,"",0);
1042 sv = newSVpvn("",0); /* first used for -I flags */
1046 for (argc--,argv++; argc > 0; argc--,argv++) {
1047 if (argv[0][0] != '-' || !argv[0][1])
1051 validarg = " PHOOEY ";
1060 win32_argv2utf8(argc-1, argv+1);
1063 #ifndef PERL_STRICT_CR
1087 if ((s = moreswitches(s)))
1092 if( !PL_tainting ) {
1093 PL_taint_warn = TRUE;
1100 PL_taint_warn = FALSE;
1105 #ifdef MACOS_TRADITIONAL
1106 /* ignore -e for Dev:Pseudo argument */
1107 if (argv[1] && !strcmp(argv[1], "Dev:Pseudo"))
1110 if (PL_euid != PL_uid || PL_egid != PL_gid)
1111 Perl_croak(aTHX_ "No -e allowed in setuid scripts");
1113 PL_e_script = newSVpvn("",0);
1114 filter_add(read_e_script, NULL);
1117 sv_catpv(PL_e_script, s);
1119 sv_catpv(PL_e_script, argv[1]);
1123 Perl_croak(aTHX_ "No code specified for -e");
1124 sv_catpv(PL_e_script, "\n");
1127 case 'I': /* -I handled both here and in moreswitches() */
1129 if (!*++s && (s=argv[1]) != Nullch) {
1134 STRLEN len = strlen(s);
1135 p = savepvn(s, len);
1136 incpush(p, TRUE, TRUE);
1137 sv_catpvn(sv, "-I", 2);
1138 sv_catpvn(sv, p, len);
1139 sv_catpvn(sv, " ", 1);
1143 Perl_croak(aTHX_ "No directory specified for -I");
1147 PL_preprocess = TRUE;
1157 PL_preambleav = newAV();
1158 av_push(PL_preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
1160 PL_Sv = newSVpv("print myconfig();",0);
1162 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
1164 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
1166 sv_catpv(PL_Sv,"\" Compile-time options:");
1168 sv_catpv(PL_Sv," DEBUGGING");
1170 # ifdef MULTIPLICITY
1171 sv_catpv(PL_Sv," MULTIPLICITY");
1173 # ifdef USE_5005THREADS
1174 sv_catpv(PL_Sv," USE_5005THREADS");
1176 # ifdef USE_ITHREADS
1177 sv_catpv(PL_Sv," USE_ITHREADS");
1179 # ifdef USE_64_BIT_INT
1180 sv_catpv(PL_Sv," USE_64_BIT_INT");
1182 # ifdef USE_64_BIT_ALL
1183 sv_catpv(PL_Sv," USE_64_BIT_ALL");
1185 # ifdef USE_LONG_DOUBLE
1186 sv_catpv(PL_Sv," USE_LONG_DOUBLE");
1188 # ifdef USE_LARGE_FILES
1189 sv_catpv(PL_Sv," USE_LARGE_FILES");
1192 sv_catpv(PL_Sv," USE_SOCKS");
1194 # ifdef PERL_IMPLICIT_CONTEXT
1195 sv_catpv(PL_Sv," PERL_IMPLICIT_CONTEXT");
1197 # ifdef PERL_IMPLICIT_SYS
1198 sv_catpv(PL_Sv," PERL_IMPLICIT_SYS");
1200 sv_catpv(PL_Sv,"\\n\",");
1202 #if defined(LOCAL_PATCH_COUNT)
1203 if (LOCAL_PATCH_COUNT > 0) {
1205 sv_catpv(PL_Sv,"\" Locally applied patches:\\n\",");
1206 for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
1207 if (PL_localpatches[i])
1208 Perl_sv_catpvf(aTHX_ PL_Sv,"q\" \t%s\n\",",PL_localpatches[i]);
1212 Perl_sv_catpvf(aTHX_ PL_Sv,"\" Built under %s\\n\"",OSNAME);
1215 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
1217 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled on %s\\n\"",__DATE__);
1220 sv_catpv(PL_Sv, "; \
1222 @env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; ");
1225 push @env, \"CYGWIN=\\\"$ENV{CYGWIN}\\\"\";");
1228 print \" \\%ENV:\\n @env\\n\" if @env; \
1229 print \" \\@INC:\\n @INC\\n\";");
1232 PL_Sv = newSVpv("config_vars(qw(",0);
1233 sv_catpv(PL_Sv, ++s);
1234 sv_catpv(PL_Sv, "))");
1237 av_push(PL_preambleav, PL_Sv);
1238 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
1241 PL_doextract = TRUE;
1249 if (!*++s || isSPACE(*s)) {
1253 /* catch use of gnu style long options */
1254 if (strEQ(s, "version")) {
1258 if (strEQ(s, "help")) {
1265 Perl_croak(aTHX_ "Unrecognized switch: -%s (-h will show valid options)",s);
1271 #ifndef SECURE_INTERNAL_GETENV
1274 (s = PerlEnv_getenv("PERL5OPT")))
1279 if (*s == '-' && *(s+1) == 'T') {
1281 PL_taint_warn = FALSE;
1284 char *popt_copy = Nullch;
1297 if (!strchr("DIMUdmtw", *s))
1298 Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s);
1302 popt_copy = SvPVX(sv_2mortal(newSVpv(popt,0)));
1303 s = popt_copy + (s - popt);
1304 d = popt_copy + (d - popt);
1311 if( !PL_tainting ) {
1312 PL_taint_warn = TRUE;
1322 if (PL_taint_warn && PL_dowarn != G_WARN_ALL_OFF) {
1323 PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
1327 scriptname = argv[0];
1330 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
1332 else if (scriptname == Nullch) {
1334 if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
1342 open_script(scriptname,dosearch,sv,&fdscript);
1344 validate_suid(validarg, scriptname,fdscript);
1347 #if defined(SIGCHLD) || defined(SIGCLD)
1350 # define SIGCHLD SIGCLD
1352 Sighandler_t sigstate = rsignal_state(SIGCHLD);
1353 if (sigstate == SIG_IGN) {
1354 if (ckWARN(WARN_SIGNAL))
1355 Perl_warner(aTHX_ packWARN(WARN_SIGNAL),
1356 "Can't ignore signal CHLD, forcing to default");
1357 (void)rsignal(SIGCHLD, (Sighandler_t)SIG_DFL);
1363 #ifdef MACOS_TRADITIONAL
1364 if (PL_doextract || gMacPerl_AlwaysExtract) {
1369 if (cddir && PerlDir_chdir(cddir) < 0)
1370 Perl_croak(aTHX_ "Can't chdir to %s",cddir);
1374 PL_main_cv = PL_compcv = (CV*)NEWSV(1104,0);
1375 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
1376 CvUNIQUE_on(PL_compcv);
1378 PL_comppad = newAV();
1379 av_push(PL_comppad, Nullsv);
1380 PL_curpad = AvARRAY(PL_comppad);
1381 PL_comppad_name = newAV();
1382 PL_comppad_name_fill = 0;
1383 PL_min_intro_pending = 0;
1385 #ifdef USE_5005THREADS
1386 av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
1387 PL_curpad[0] = (SV*)newAV();
1388 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
1389 CvOWNER(PL_compcv) = 0;
1390 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
1391 MUTEX_INIT(CvMUTEXP(PL_compcv));
1392 #endif /* USE_5005THREADS */
1394 comppadlist = newAV();
1395 AvREAL_off(comppadlist);
1396 av_store(comppadlist, 0, (SV*)PL_comppad_name);
1397 av_store(comppadlist, 1, (SV*)PL_comppad);
1398 CvPADLIST(PL_compcv) = comppadlist;
1401 boot_core_UNIVERSAL();
1403 boot_core_xsutils();
1407 (*xsinit)(aTHX); /* in case linked C routines want magical variables */
1409 #if defined(VMS) || defined(WIN32) || defined(DJGPP) || defined(__CYGWIN__) || defined(EPOC)
1415 # ifdef HAS_SOCKS5_INIT
1416 socks5_init(argv[0]);
1422 init_predump_symbols();
1423 /* init_postdump_symbols not currently designed to be called */
1424 /* more than once (ENV isn't cleared first, for example) */
1425 /* But running with -u leaves %ENV & @ARGV undefined! XXX */
1427 init_postdump_symbols(argc,argv,env);
1429 if (PL_wantutf8) { /* Requires init_predump_symbols(). */
1433 if (PL_stdingv && (io = GvIO(PL_stdingv)) && (fp = IoIFP(io)))
1434 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
1435 if (PL_defoutgv && (io = GvIO(PL_defoutgv)) && (fp = IoOFP(io)))
1436 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
1437 if (PL_stderrgv && (io = GvIO(PL_stderrgv)) && (fp = IoOFP(io)))
1438 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
1439 if ((sv = GvSV(gv_fetchpv("\017PEN", TRUE, SVt_PV)))) {
1440 sv_setpvn(sv, ":utf8\0:utf8", 11);
1447 /* now parse the script */
1449 SETERRNO(0,SS$_NORMAL);
1451 #ifdef MACOS_TRADITIONAL
1452 if (gMacPerl_SyntaxError = (yyparse() || PL_error_count)) {
1454 Perl_croak(aTHX_ "%s had compilation errors.\n", MacPerl_MPWFileName(PL_origfilename));
1456 Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
1457 MacPerl_MPWFileName(PL_origfilename));
1461 if (yyparse() || PL_error_count) {
1463 Perl_croak(aTHX_ "%s had compilation errors.\n", PL_origfilename);
1465 Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
1470 CopLINE_set(PL_curcop, 0);
1471 PL_curstash = PL_defstash;
1472 PL_preprocess = FALSE;
1474 SvREFCNT_dec(PL_e_script);
1475 PL_e_script = Nullsv;
1479 Not sure that this is still the right place to do this now that we
1480 no longer use PL_nrs. HVDS 2001/09/09
1482 sv_setsv(get_sv("/", TRUE), PL_rs);
1488 SAVECOPFILE(PL_curcop);
1489 SAVECOPLINE(PL_curcop);
1490 gv_check(PL_defstash);
1497 if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
1498 dump_mstats("after compilation:");
1507 =for apidoc perl_run
1509 Tells a Perl interpreter to run. See L<perlembed>.
1520 #ifdef USE_5005THREADS
1524 oldscope = PL_scopestack_ix;
1529 #ifdef PERL_FLEXIBLE_EXCEPTIONS
1531 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vrun_body), oldscope);
1537 cxstack_ix = -1; /* start context stack again */
1539 case 0: /* normal completion */
1540 #ifndef PERL_FLEXIBLE_EXCEPTIONS
1545 case 2: /* my_exit() */
1546 while (PL_scopestack_ix > oldscope)
1549 PL_curstash = PL_defstash;
1550 if (!(PL_exit_flags & PERL_EXIT_DESTRUCT_END) &&
1551 PL_endav && !PL_minus_c)
1552 call_list(oldscope, PL_endav);
1554 if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
1555 dump_mstats("after execution: ");
1557 ret = STATUS_NATIVE_EXPORT;
1561 POPSTACK_TO(PL_mainstack);
1564 PerlIO_printf(Perl_error_log, "panic: restartop\n");
1574 #ifdef PERL_FLEXIBLE_EXCEPTIONS
1576 S_vrun_body(pTHX_ va_list args)
1578 I32 oldscope = va_arg(args, I32);
1580 return run_body(oldscope);
1586 S_run_body(pTHX_ I32 oldscope)
1588 DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
1589 PL_sawampersand ? "Enabling" : "Omitting"));
1591 if (!PL_restartop) {
1592 DEBUG_x(dump_all());
1593 DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
1594 DEBUG_S(PerlIO_printf(Perl_debug_log, "main thread is 0x%"UVxf"\n",
1598 #ifdef MACOS_TRADITIONAL
1599 PerlIO_printf(Perl_error_log, "# %s syntax OK\n", MacPerl_MPWFileName(PL_origfilename));
1601 PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename);
1605 if (PERLDB_SINGLE && PL_DBsingle)
1606 sv_setiv(PL_DBsingle, 1);
1608 call_list(oldscope, PL_initav);
1614 PL_op = PL_restartop;
1618 else if (PL_main_start) {
1619 CvDEPTH(PL_main_cv) = 1;
1620 PL_op = PL_main_start;
1630 =head1 SV Manipulation Functions
1632 =for apidoc p||get_sv
1634 Returns the SV of the specified Perl scalar. 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.
1642 Perl_get_sv(pTHX_ const char *name, I32 create)
1645 #ifdef USE_5005THREADS
1646 if (name[1] == '\0' && !isALPHA(name[0])) {
1647 PADOFFSET tmp = find_threadsv(name);
1648 if (tmp != NOT_IN_PAD)
1649 return THREADSV(tmp);
1651 #endif /* USE_5005THREADS */
1652 gv = gv_fetchpv(name, create, SVt_PV);
1659 =head1 Array Manipulation Functions
1661 =for apidoc p||get_av
1663 Returns the AV of the specified Perl array. If C<create> is set and the
1664 Perl variable does not exist then it will be created. If C<create> is not
1665 set and the variable does not exist then NULL is returned.
1671 Perl_get_av(pTHX_ const char *name, I32 create)
1673 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
1682 =head1 Hash Manipulation Functions
1684 =for apidoc p||get_hv
1686 Returns the HV of the specified Perl hash. If C<create> is set and the
1687 Perl variable does not exist then it will be created. If C<create> is not
1688 set and the variable does not exist then NULL is returned.
1694 Perl_get_hv(pTHX_ const char *name, I32 create)
1696 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
1705 =head1 CV Manipulation Functions
1707 =for apidoc p||get_cv
1709 Returns the CV of the specified Perl subroutine. If C<create> is set and
1710 the Perl subroutine does not exist then it will be declared (which has the
1711 same effect as saying C<sub name;>). If C<create> is not set and the
1712 subroutine does not exist then NULL is returned.
1718 Perl_get_cv(pTHX_ const char *name, I32 create)
1720 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
1721 /* XXX unsafe for threads if eval_owner isn't held */
1722 /* XXX this is probably not what they think they're getting.
1723 * It has the same effect as "sub name;", i.e. just a forward
1725 if (create && !GvCVu(gv))
1726 return newSUB(start_subparse(FALSE, 0),
1727 newSVOP(OP_CONST, 0, newSVpv(name,0)),
1735 /* Be sure to refetch the stack pointer after calling these routines. */
1739 =head1 Callback Functions
1741 =for apidoc p||call_argv
1743 Performs a callback to the specified Perl sub. See L<perlcall>.
1749 Perl_call_argv(pTHX_ const char *sub_name, I32 flags, register char **argv)
1751 /* See G_* flags in cop.h */
1752 /* null terminated arg list */
1759 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
1764 return call_pv(sub_name, flags);
1768 =for apidoc p||call_pv
1770 Performs a callback to the specified Perl sub. See L<perlcall>.
1776 Perl_call_pv(pTHX_ const char *sub_name, I32 flags)
1777 /* name of the subroutine */
1778 /* See G_* flags in cop.h */
1780 return call_sv((SV*)get_cv(sub_name, TRUE), flags);
1784 =for apidoc p||call_method
1786 Performs a callback to the specified Perl method. The blessed object must
1787 be on the stack. See L<perlcall>.
1793 Perl_call_method(pTHX_ const char *methname, I32 flags)
1794 /* name of the subroutine */
1795 /* See G_* flags in cop.h */
1797 return call_sv(sv_2mortal(newSVpv(methname,0)), flags | G_METHOD);
1800 /* May be called with any of a CV, a GV, or an SV containing the name. */
1802 =for apidoc p||call_sv
1804 Performs a callback to the Perl sub whose name is in the SV. See
1811 Perl_call_sv(pTHX_ SV *sv, I32 flags)
1812 /* See G_* flags in cop.h */
1815 LOGOP myop; /* fake syntax tree node */
1818 volatile I32 retval = 0;
1820 bool oldcatch = CATCH_GET;
1825 if (flags & G_DISCARD) {
1830 Zero(&myop, 1, LOGOP);
1831 myop.op_next = Nullop;
1832 if (!(flags & G_NOARGS))
1833 myop.op_flags |= OPf_STACKED;
1834 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1835 (flags & G_ARRAY) ? OPf_WANT_LIST :
1840 EXTEND(PL_stack_sp, 1);
1841 *++PL_stack_sp = sv;
1843 oldscope = PL_scopestack_ix;
1845 if (PERLDB_SUB && PL_curstash != PL_debstash
1846 /* Handle first BEGIN of -d. */
1847 && (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub)))
1848 /* Try harder, since this may have been a sighandler, thus
1849 * curstash may be meaningless. */
1850 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != PL_debstash)
1851 && !(flags & G_NODEBUG))
1852 PL_op->op_private |= OPpENTERSUB_DB;
1854 if (flags & G_METHOD) {
1855 Zero(&method_op, 1, UNOP);
1856 method_op.op_next = PL_op;
1857 method_op.op_ppaddr = PL_ppaddr[OP_METHOD];
1858 myop.op_ppaddr = PL_ppaddr[OP_ENTERSUB];
1859 PL_op = (OP*)&method_op;
1862 if (!(flags & G_EVAL)) {
1864 call_body((OP*)&myop, FALSE);
1865 retval = PL_stack_sp - (PL_stack_base + oldmark);
1866 CATCH_SET(oldcatch);
1869 myop.op_other = (OP*)&myop;
1871 /* we're trying to emulate pp_entertry() here */
1873 register PERL_CONTEXT *cx;
1874 I32 gimme = GIMME_V;
1879 push_return(Nullop);
1880 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
1882 PL_eval_root = PL_op; /* Only needed so that goto works right. */
1884 PL_in_eval = EVAL_INEVAL;
1885 if (flags & G_KEEPERR)
1886 PL_in_eval |= EVAL_KEEPERR;
1892 #ifdef PERL_FLEXIBLE_EXCEPTIONS
1894 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_body),
1901 #ifndef PERL_FLEXIBLE_EXCEPTIONS
1903 call_body((OP*)&myop, FALSE);
1905 retval = PL_stack_sp - (PL_stack_base + oldmark);
1906 if (!(flags & G_KEEPERR))
1913 /* my_exit() was called */
1914 PL_curstash = PL_defstash;
1917 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
1918 Perl_croak(aTHX_ "Callback called exit");
1923 PL_op = PL_restartop;
1927 PL_stack_sp = PL_stack_base + oldmark;
1928 if (flags & G_ARRAY)
1932 *++PL_stack_sp = &PL_sv_undef;
1937 if (PL_scopestack_ix > oldscope) {
1941 register PERL_CONTEXT *cx;
1953 if (flags & G_DISCARD) {
1954 PL_stack_sp = PL_stack_base + oldmark;
1963 #ifdef PERL_FLEXIBLE_EXCEPTIONS
1965 S_vcall_body(pTHX_ va_list args)
1967 OP *myop = va_arg(args, OP*);
1968 int is_eval = va_arg(args, int);
1970 call_body(myop, is_eval);
1976 S_call_body(pTHX_ OP *myop, int is_eval)
1978 if (PL_op == myop) {
1980 PL_op = Perl_pp_entereval(aTHX); /* this doesn't do a POPMARK */
1982 PL_op = Perl_pp_entersub(aTHX); /* this does */
1988 /* Eval a string. The G_EVAL flag is always assumed. */
1991 =for apidoc p||eval_sv
1993 Tells Perl to C<eval> the string in the SV.
1999 Perl_eval_sv(pTHX_ SV *sv, I32 flags)
2001 /* See G_* flags in cop.h */
2004 UNOP myop; /* fake syntax tree node */
2005 volatile I32 oldmark = SP - PL_stack_base;
2006 volatile I32 retval = 0;
2012 if (flags & G_DISCARD) {
2019 Zero(PL_op, 1, UNOP);
2020 EXTEND(PL_stack_sp, 1);
2021 *++PL_stack_sp = sv;
2022 oldscope = PL_scopestack_ix;
2024 if (!(flags & G_NOARGS))
2025 myop.op_flags = OPf_STACKED;
2026 myop.op_next = Nullop;
2027 myop.op_type = OP_ENTEREVAL;
2028 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
2029 (flags & G_ARRAY) ? OPf_WANT_LIST :
2031 if (flags & G_KEEPERR)
2032 myop.op_flags |= OPf_SPECIAL;
2034 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2036 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_body),
2043 #ifndef PERL_FLEXIBLE_EXCEPTIONS
2045 call_body((OP*)&myop,TRUE);
2047 retval = PL_stack_sp - (PL_stack_base + oldmark);
2048 if (!(flags & G_KEEPERR))
2055 /* my_exit() was called */
2056 PL_curstash = PL_defstash;
2059 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
2060 Perl_croak(aTHX_ "Callback called exit");
2065 PL_op = PL_restartop;
2069 PL_stack_sp = PL_stack_base + oldmark;
2070 if (flags & G_ARRAY)
2074 *++PL_stack_sp = &PL_sv_undef;
2080 if (flags & G_DISCARD) {
2081 PL_stack_sp = PL_stack_base + oldmark;
2091 =for apidoc p||eval_pv
2093 Tells Perl to C<eval> the given string and return an SV* result.
2099 Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
2102 SV* sv = newSVpv(p, 0);
2104 eval_sv(sv, G_SCALAR);
2111 if (croak_on_error && SvTRUE(ERRSV)) {
2113 Perl_croak(aTHX_ SvPVx(ERRSV, n_a));
2119 /* Require a module. */
2122 =head1 Embedding Functions
2124 =for apidoc p||require_pv
2126 Tells Perl to C<require> the file named by the string argument. It is
2127 analogous to the Perl code C<eval "require '$file'">. It's even
2128 implemented that way; consider using Perl_load_module instead.
2133 Perl_require_pv(pTHX_ const char *pv)
2137 PUSHSTACKi(PERLSI_REQUIRE);
2139 sv = sv_newmortal();
2140 sv_setpv(sv, "require '");
2143 eval_sv(sv, G_DISCARD);
2149 Perl_magicname(pTHX_ char *sym, char *name, I32 namlen)
2153 if ((gv = gv_fetchpv(sym,TRUE, SVt_PV)))
2154 sv_magic(GvSV(gv), (SV*)gv, PERL_MAGIC_sv, name, namlen);
2158 S_usage(pTHX_ char *name) /* XXX move this out into a module ? */
2160 /* This message really ought to be max 23 lines.
2161 * Removed -h because the user already knows that option. Others? */
2163 static char *usage_msg[] = {
2164 "-0[octal] specify record separator (\\0, if no argument)",
2165 "-a autosplit mode with -n or -p (splits $_ into @F)",
2166 "-C enable native wide character system interfaces",
2167 "-c check syntax only (runs BEGIN and CHECK blocks)",
2168 "-d[:debugger] run program under debugger",
2169 "-D[number/list] set debugging flags (argument is a bit mask or alphabets)",
2170 "-e 'command' one line of program (several -e's allowed, omit programfile)",
2171 "-F/pattern/ split() pattern for -a switch (//'s are optional)",
2172 "-i[extension] edit <> files in place (makes backup if extension supplied)",
2173 "-Idirectory specify @INC/#include directory (several -I's allowed)",
2174 "-l[octal] enable line ending processing, specifies line terminator",
2175 "-[mM][-]module execute `use/no module...' before executing program",
2176 "-n assume 'while (<>) { ... }' loop around program",
2177 "-p assume loop like -n but print line also, like sed",
2178 "-P run program through C preprocessor before compilation",
2179 "-s enable rudimentary parsing for switches after programfile",
2180 "-S look for programfile using PATH environment variable",
2181 "-T enable tainting checks",
2182 "-t enable tainting warnings",
2183 "-u dump core after parsing program",
2184 "-U allow unsafe operations",
2185 "-v print version, subversion (includes VERY IMPORTANT perl info)",
2186 "-V[:variable] print configuration summary (or a single Config.pm variable)",
2187 "-w enable many useful warnings (RECOMMENDED)",
2188 "-W enable all warnings",
2189 "-X disable all warnings",
2190 "-x[directory] strip off text before #!perl line and perhaps cd to directory",
2194 char **p = usage_msg;
2196 PerlIO_printf(PerlIO_stdout(),
2197 "\nUsage: %s [switches] [--] [programfile] [arguments]",
2200 PerlIO_printf(PerlIO_stdout(), "\n %s", *p++);
2203 /* This routine handles any switches that can be given during run */
2206 Perl_moreswitches(pTHX_ char *s)
2216 rschar = (U32)grok_oct(s, &numlen, &flags, NULL);
2217 SvREFCNT_dec(PL_rs);
2218 if (rschar & ~((U8)~0))
2219 PL_rs = &PL_sv_undef;
2220 else if (!rschar && numlen >= 2)
2221 PL_rs = newSVpvn("", 0);
2224 PL_rs = newSVpvn(&ch, 1);
2229 PL_widesyscalls = TRUE;
2235 while (*s && !isSPACE(*s)) ++s;
2237 PL_splitstr = savepv(PL_splitstr);
2250 /* The following permits -d:Mod to accepts arguments following an =
2251 in the fashion that -MSome::Mod does. */
2252 if (*s == ':' || *s == '=') {
2255 sv = newSVpv("use Devel::", 0);
2257 /* We now allow -d:Module=Foo,Bar */
2258 while(isALNUM(*s) || *s==':') ++s;
2260 sv_catpv(sv, start);
2262 sv_catpvn(sv, start, s-start);
2263 sv_catpv(sv, " split(/,/,q{");
2268 my_setenv("PERL5DB", SvPV(sv, PL_na));
2271 PL_perldb = PERLDB_ALL;
2279 if (isALPHA(s[1])) {
2280 /* if adding extra options, remember to update DEBUG_MASK */
2281 static char debopts[] = "psltocPmfrxuLHXDSTRJ";
2284 for (s++; *s && (d = strchr(debopts,*s)); s++)
2285 PL_debug |= 1 << (d - debopts);
2288 PL_debug = atoi(s+1);
2289 for (s++; isDIGIT(*s); s++) ;
2291 PL_debug |= DEBUG_TOP_FLAG;
2293 if (ckWARN_d(WARN_DEBUGGING))
2294 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
2295 "Recompile perl with -DDEBUGGING to use -D switch\n");
2296 for (s++; isALNUM(*s); s++) ;
2302 usage(PL_origargv[0]);
2306 Safefree(PL_inplace);
2307 PL_inplace = savepv(s+1);
2309 for (s = PL_inplace; *s && !isSPACE(*s); s++) ;
2312 if (*s == '-') /* Additional switches on #! line. */
2316 case 'I': /* -I handled both here and in parse_body() */
2319 while (*s && isSPACE(*s))
2324 /* ignore trailing spaces (possibly followed by other switches) */
2326 for (e = p; *e && !isSPACE(*e); e++) ;
2330 } while (*p && *p != '-');
2331 e = savepvn(s, e-s);
2332 incpush(e, TRUE, TRUE);
2339 Perl_croak(aTHX_ "No directory specified for -I");
2345 SvREFCNT_dec(PL_ors_sv);
2350 PL_ors_sv = newSVpvn("\n",1);
2351 numlen = 3 + (*s == '0');
2352 *SvPVX(PL_ors_sv) = (char)grok_oct(s, &numlen, &flags, NULL);
2356 if (RsPARA(PL_rs)) {
2357 PL_ors_sv = newSVpvn("\n\n",2);
2360 PL_ors_sv = newSVsv(PL_rs);
2365 forbid_setid("-M"); /* XXX ? */
2368 forbid_setid("-m"); /* XXX ? */
2373 /* -M-foo == 'no foo' */
2374 if (*s == '-') { use = "no "; ++s; }
2375 sv = newSVpv(use,0);
2377 /* We allow -M'Module qw(Foo Bar)' */
2378 while(isALNUM(*s) || *s==':') ++s;
2380 sv_catpv(sv, start);
2381 if (*(start-1) == 'm') {
2383 Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
2384 sv_catpv( sv, " ()");
2388 Perl_croak(aTHX_ "Module name required with -%c option",
2390 sv_catpvn(sv, start, s-start);
2391 sv_catpv(sv, " split(/,/,q{");
2397 PL_preambleav = newAV();
2398 av_push(PL_preambleav, sv);
2401 Perl_croak(aTHX_ "No space allowed after -%c", *(s-1));
2413 PL_doswitches = TRUE;
2418 Perl_croak(aTHX_ "Too late for \"-t\" option");
2423 Perl_croak(aTHX_ "Too late for \"-T\" option");
2427 #ifdef MACOS_TRADITIONAL
2428 Perl_croak(aTHX_ "Believe me, you don't want to use \"-u\" on a Macintosh");
2430 PL_do_undump = TRUE;
2439 PerlIO_printf(PerlIO_stdout(),
2440 Perl_form(aTHX_ "\nThis is perl, v%"VDf" built for %s",
2441 PL_patchlevel, ARCHNAME));
2443 /* Adjust verbose output as in the perl that ships with the DG/UX OS from EMC */
2444 PerlIO_printf(PerlIO_stdout(),
2445 Perl_form(aTHX_ "\nThis is perl, version %vd\n", PL_patchlevel));
2446 PerlIO_printf(PerlIO_stdout(),
2447 Perl_form(aTHX_ " built under %s at %s %s\n",
2448 OSNAME, __DATE__, __TIME__));
2449 PerlIO_printf(PerlIO_stdout(),
2450 Perl_form(aTHX_ " OS Specific Release: %s\n",
2454 #if defined(LOCAL_PATCH_COUNT)
2455 if (LOCAL_PATCH_COUNT > 0)
2456 PerlIO_printf(PerlIO_stdout(),
2457 "\n(with %d registered patch%s, "
2458 "see perl -V for more detail)",
2459 (int)LOCAL_PATCH_COUNT,
2460 (LOCAL_PATCH_COUNT!=1) ? "es" : "");
2463 PerlIO_printf(PerlIO_stdout(),
2464 "\n\nCopyright 1987-2002, Larry Wall\n");
2465 #ifdef MACOS_TRADITIONAL
2466 PerlIO_printf(PerlIO_stdout(),
2467 "\nMac OS port Copyright 1991-2002, Matthias Neeracher;\n"
2468 "maintained by Chris Nandor\n");
2471 PerlIO_printf(PerlIO_stdout(),
2472 "\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
2475 PerlIO_printf(PerlIO_stdout(),
2476 "djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n"
2477 "djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
2480 PerlIO_printf(PerlIO_stdout(),
2481 "\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
2482 "Version 5 port Copyright (c) 1994-2002, Andreas Kaiser, Ilya Zakharevich\n");
2485 PerlIO_printf(PerlIO_stdout(),
2486 "atariST series port, ++jrb bammi@cadence.com\n");
2489 PerlIO_printf(PerlIO_stdout(),
2490 "BeOS port Copyright Tom Spindler, 1997-1999\n");
2493 PerlIO_printf(PerlIO_stdout(),
2494 "MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-2002\n");
2497 PerlIO_printf(PerlIO_stdout(),
2498 "MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
2501 PerlIO_printf(PerlIO_stdout(),
2502 "Stratus VOS port by Paul_Green@stratus.com, 1997-2002\n");
2505 PerlIO_printf(PerlIO_stdout(),
2506 "VM/ESA port by Neale Ferguson, 1998-1999\n");
2509 PerlIO_printf(PerlIO_stdout(),
2510 "BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
2513 PerlIO_printf(PerlIO_stdout(),
2514 "MiNT port by Guido Flohr, 1997-1999\n");
2517 PerlIO_printf(PerlIO_stdout(),
2518 "EPOC port by Olaf Flebbe, 1999-2002\n");
2521 printf("WINCE port by Rainer Keuchel, 2001-2002\n");
2522 printf("Built on " __DATE__ " " __TIME__ "\n\n");
2525 #ifdef BINARY_BUILD_NOTICE
2526 BINARY_BUILD_NOTICE;
2528 PerlIO_printf(PerlIO_stdout(),
2530 Perl may be copied only under the terms of either the Artistic License or the\n\
2531 GNU General Public License, which may be found in the Perl 5 source kit.\n\n\
2532 Complete documentation for Perl, including FAQ lists, should be found on\n\
2533 this system using `man perl' or `perldoc perl'. If you have access to the\n\
2534 Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n");
2537 if (! (PL_dowarn & G_WARN_ALL_MASK))
2538 PL_dowarn |= G_WARN_ON;
2542 PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
2543 if (!specialWARN(PL_compiling.cop_warnings))
2544 SvREFCNT_dec(PL_compiling.cop_warnings);
2545 PL_compiling.cop_warnings = pWARN_ALL ;
2549 PL_dowarn = G_WARN_ALL_OFF;
2550 if (!specialWARN(PL_compiling.cop_warnings))
2551 SvREFCNT_dec(PL_compiling.cop_warnings);
2552 PL_compiling.cop_warnings = pWARN_NONE ;
2557 if (s[1] == '-') /* Additional switches on #! line. */
2562 #if defined(WIN32) || !defined(PERL_STRICT_CR)
2568 #ifdef ALTERNATE_SHEBANG
2569 case 'S': /* OS/2 needs -S on "extproc" line. */
2577 Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
2582 /* compliments of Tom Christiansen */
2584 /* unexec() can be found in the Gnu emacs distribution */
2585 /* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
2588 Perl_my_unexec(pTHX)
2596 prog = newSVpv(BIN_EXP, 0);
2597 sv_catpv(prog, "/perl");
2598 file = newSVpv(PL_origfilename, 0);
2599 sv_catpv(file, ".perldump");
2601 unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
2602 /* unexec prints msg to stderr in case of failure */
2603 PerlProc_exit(status);
2606 # include <lib$routines.h>
2607 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
2609 ABORT(); /* for use with undump */
2614 /* initialize curinterp */
2620 # define PERLVAR(var,type)
2621 # define PERLVARA(var,n,type)
2622 # if defined(PERL_IMPLICIT_CONTEXT)
2623 # if defined(USE_5005THREADS)
2624 # define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
2625 # define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
2626 # else /* !USE_5005THREADS */
2627 # define PERLVARI(var,type,init) aTHX->var = init;
2628 # define PERLVARIC(var,type,init) aTHX->var = init;
2629 # endif /* USE_5005THREADS */
2631 # define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
2632 # define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
2634 # include "intrpvar.h"
2635 # ifndef USE_5005THREADS
2636 # include "thrdvar.h"
2643 # define PERLVAR(var,type)
2644 # define PERLVARA(var,n,type)
2645 # define PERLVARI(var,type,init) PL_##var = init;
2646 # define PERLVARIC(var,type,init) PL_##var = init;
2647 # include "intrpvar.h"
2648 # ifndef USE_5005THREADS
2649 # include "thrdvar.h"
2660 S_init_main_stash(pTHX)
2666 PL_curstash = PL_defstash = newHV();
2667 PL_curstname = newSVpvn("main",4);
2668 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
2669 SvREFCNT_dec(GvHV(gv));
2670 GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash);
2672 HvNAME(PL_defstash) = savepv("main");
2673 PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
2674 GvMULTI_on(PL_incgv);
2675 PL_hintgv = gv_fetchpv("\010",TRUE, SVt_PV); /* ^H */
2676 GvMULTI_on(PL_hintgv);
2677 PL_defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
2678 PL_errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
2679 GvMULTI_on(PL_errgv);
2680 PL_replgv = gv_fetchpv("\022", TRUE, SVt_PV); /* ^R */
2681 GvMULTI_on(PL_replgv);
2682 (void)Perl_form(aTHX_ "%240s",""); /* Preallocate temp - for immediate signals. */
2683 sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
2684 sv_setpvn(ERRSV, "", 0);
2685 PL_curstash = PL_defstash;
2686 CopSTASH_set(&PL_compiling, PL_defstash);
2687 PL_debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
2688 PL_globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
2689 PL_nullstash = GvHV(gv_fetchpv("<none>::", GV_ADDMULTI, SVt_PVHV));
2690 /* We must init $/ before switches are processed. */
2691 sv_setpvn(get_sv("/", TRUE), "\n", 1);
2695 S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript)
2699 char *cpp_discard_flag;
2705 PL_origfilename = savepv("-e");
2708 /* if find_script() returns, it returns a malloc()-ed value */
2709 PL_origfilename = scriptname = find_script(scriptname, dosearch, NULL, 1);
2711 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
2712 char *s = scriptname + 8;
2713 *fdscript = atoi(s);
2717 scriptname = savepv(s + 1);
2718 Safefree(PL_origfilename);
2719 PL_origfilename = scriptname;
2724 CopFILE_free(PL_curcop);
2725 CopFILE_set(PL_curcop, PL_origfilename);
2726 if (strEQ(PL_origfilename,"-"))
2728 if (*fdscript >= 0) {
2729 PL_rsfp = PerlIO_fdopen(*fdscript,PERL_SCRIPT_MODE);
2730 # if defined(HAS_FCNTL) && defined(F_SETFD)
2732 /* ensure close-on-exec */
2733 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);
2736 else if (PL_preprocess) {
2737 char *cpp_cfg = CPPSTDIN;
2738 SV *cpp = newSVpvn("",0);
2739 SV *cmd = NEWSV(0,0);
2741 if (strEQ(cpp_cfg, "cppstdin"))
2742 Perl_sv_catpvf(aTHX_ cpp, "%s/", BIN_EXP);
2743 sv_catpv(cpp, cpp_cfg);
2746 sv_catpvn(sv, "-I", 2);
2747 sv_catpv(sv,PRIVLIB_EXP);
2750 DEBUG_P(PerlIO_printf(Perl_debug_log,
2751 "PL_preprocess: scriptname=\"%s\", cpp=\"%s\", sv=\"%s\", CPPMINUS=\"%s\"\n",
2752 scriptname, SvPVX (cpp), SvPVX (sv), CPPMINUS));
2754 # if defined(MSDOS) || defined(WIN32) || defined(VMS)
2761 cpp_discard_flag = "";
2763 cpp_discard_flag = "-C";
2767 perl = os2_execname(aTHX);
2769 perl = PL_origargv[0];
2773 /* This strips off Perl comments which might interfere with
2774 the C pre-processor, including #!. #line directives are
2775 deliberately stripped to avoid confusion with Perl's version
2776 of #line. FWP played some golf with it so it will fit
2777 into VMS's 255 character buffer.
2780 code = "(1../^#!.*perl/i)|/^\\s*#(?!\\s*((ifn?|un)def|(el|end)?if|define|include|else|error|pragma)\\b)/||!($|=1)||print";
2782 code = "/^\\s*#(?!\\s*((ifn?|un)def|(el|end)?if|define|include|else|error|pragma)\\b)/||!($|=1)||print";
2784 Perl_sv_setpvf(aTHX_ cmd, "\
2785 %s -ne%s%s%s %s | %"SVf" %s %"SVf" %s",
2786 perl, quote, code, quote, scriptname, cpp,
2787 cpp_discard_flag, sv, CPPMINUS);
2789 PL_doextract = FALSE;
2790 # ifdef IAMSUID /* actually, this is caught earlier */
2791 if (PL_euid != PL_uid && !PL_euid) { /* if running suidperl */
2793 (void)seteuid(PL_uid); /* musn't stay setuid root */
2795 # ifdef HAS_SETREUID
2796 (void)setreuid((Uid_t)-1, PL_uid);
2798 # ifdef HAS_SETRESUID
2799 (void)setresuid((Uid_t)-1, PL_uid, (Uid_t)-1);
2801 PerlProc_setuid(PL_uid);
2805 if (PerlProc_geteuid() != PL_uid)
2806 Perl_croak(aTHX_ "Can't do seteuid!\n");
2808 # endif /* IAMSUID */
2810 DEBUG_P(PerlIO_printf(Perl_debug_log,
2811 "PL_preprocess: cmd=\"%s\"\n",
2814 PL_rsfp = PerlProc_popen(SvPVX(cmd), "r");
2818 else if (!*scriptname) {
2819 forbid_setid("program input from stdin");
2820 PL_rsfp = PerlIO_stdin();
2823 PL_rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
2824 # if defined(HAS_FCNTL) && defined(F_SETFD)
2826 /* ensure close-on-exec */
2827 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);
2832 # ifndef IAMSUID /* in case script is not readable before setuid */
2834 PerlLIO_stat(CopFILE(PL_curcop),&PL_statbuf) >= 0 &&
2835 PL_statbuf.st_mode & (S_ISUID|S_ISGID))
2838 PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT,
2839 BIN_EXP, (int)PERL_REVISION,
2841 (int)PERL_SUBVERSION), PL_origargv);
2842 Perl_croak(aTHX_ "Can't do setuid\n");
2848 Perl_croak(aTHX_ "Can't open perl script: %s\n",
2851 Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
2852 CopFILE(PL_curcop), Strerror(errno));
2858 * I_SYSSTATVFS HAS_FSTATVFS
2860 * I_STATFS HAS_FSTATFS HAS_GETFSSTAT
2861 * I_MNTENT HAS_GETMNTENT HAS_HASMNTOPT
2862 * here so that metaconfig picks them up. */
2866 S_fd_on_nosuid_fs(pTHX_ int fd)
2868 int check_okay = 0; /* able to do all the required sys/libcalls */
2869 int on_nosuid = 0; /* the fd is on a nosuid fs */
2871 * Preferred order: fstatvfs(), fstatfs(), ustat()+getmnt(), getmntent().
2872 * fstatvfs() is UNIX98.
2873 * fstatfs() is 4.3 BSD.
2874 * ustat()+getmnt() is pre-4.3 BSD.
2875 * getmntent() is O(number-of-mounted-filesystems) and can hang on
2876 * an irrelevant filesystem while trying to reach the right one.
2879 #undef FD_ON_NOSUID_CHECK_OKAY /* found the syscalls to do the check? */
2881 # if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
2882 defined(HAS_FSTATVFS)
2883 # define FD_ON_NOSUID_CHECK_OKAY
2884 struct statvfs stfs;
2886 check_okay = fstatvfs(fd, &stfs) == 0;
2887 on_nosuid = check_okay && (stfs.f_flag & ST_NOSUID);
2888 # endif /* fstatvfs */
2890 # if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
2891 defined(PERL_MOUNT_NOSUID) && \
2892 defined(HAS_FSTATFS) && \
2893 defined(HAS_STRUCT_STATFS) && \
2894 defined(HAS_STRUCT_STATFS_F_FLAGS)
2895 # define FD_ON_NOSUID_CHECK_OKAY
2898 check_okay = fstatfs(fd, &stfs) == 0;
2899 on_nosuid = check_okay && (stfs.f_flags & PERL_MOUNT_NOSUID);
2900 # endif /* fstatfs */
2902 # if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
2903 defined(PERL_MOUNT_NOSUID) && \
2904 defined(HAS_FSTAT) && \
2905 defined(HAS_USTAT) && \
2906 defined(HAS_GETMNT) && \
2907 defined(HAS_STRUCT_FS_DATA) && \
2909 # define FD_ON_NOSUID_CHECK_OKAY
2912 if (fstat(fd, &fdst) == 0) {
2914 if (ustat(fdst.st_dev, &us) == 0) {
2916 /* NOSTAT_ONE here because we're not examining fields which
2917 * vary between that case and STAT_ONE. */
2918 if (getmnt((int*)0, &fsd, (int)0, NOSTAT_ONE, us.f_fname) == 0) {
2919 size_t cmplen = sizeof(us.f_fname);
2920 if (sizeof(fsd.fd_req.path) < cmplen)
2921 cmplen = sizeof(fsd.fd_req.path);
2922 if (strnEQ(fsd.fd_req.path, us.f_fname, cmplen) &&
2923 fdst.st_dev == fsd.fd_req.dev) {
2925 on_nosuid = fsd.fd_req.flags & PERL_MOUNT_NOSUID;
2931 # endif /* fstat+ustat+getmnt */
2933 # if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
2934 defined(HAS_GETMNTENT) && \
2935 defined(HAS_HASMNTOPT) && \
2936 defined(MNTOPT_NOSUID)
2937 # define FD_ON_NOSUID_CHECK_OKAY
2938 FILE *mtab = fopen("/etc/mtab", "r");
2939 struct mntent *entry;
2940 struct stat stb, fsb;
2942 if (mtab && (fstat(fd, &stb) == 0)) {
2943 while (entry = getmntent(mtab)) {
2944 if (stat(entry->mnt_dir, &fsb) == 0
2945 && fsb.st_dev == stb.st_dev)
2947 /* found the filesystem */
2949 if (hasmntopt(entry, MNTOPT_NOSUID))
2952 } /* A single fs may well fail its stat(). */
2957 # endif /* getmntent+hasmntopt */
2960 Perl_croak(aTHX_ "Can't check filesystem of script \"%s\" for nosuid", PL_origfilename);
2963 #endif /* IAMSUID */
2966 S_validate_suid(pTHX_ char *validarg, char *scriptname, int fdscript)
2972 /* do we need to emulate setuid on scripts? */
2974 /* This code is for those BSD systems that have setuid #! scripts disabled
2975 * in the kernel because of a security problem. Merely defining DOSUID
2976 * in perl will not fix that problem, but if you have disabled setuid
2977 * scripts in the kernel, this will attempt to emulate setuid and setgid
2978 * on scripts that have those now-otherwise-useless bits set. The setuid
2979 * root version must be called suidperl or sperlN.NNN. If regular perl
2980 * discovers that it has opened a setuid script, it calls suidperl with
2981 * the same argv that it had. If suidperl finds that the script it has
2982 * just opened is NOT setuid root, it sets the effective uid back to the
2983 * uid. We don't just make perl setuid root because that loses the
2984 * effective uid we had before invoking perl, if it was different from the
2987 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
2988 * be defined in suidperl only. suidperl must be setuid root. The
2989 * Configure script will set this up for you if you want it.
2995 if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0) /* normal stat is insecure */
2996 Perl_croak(aTHX_ "Can't stat script \"%s\"",PL_origfilename);
2997 if (fdscript < 0 && PL_statbuf.st_mode & (S_ISUID|S_ISGID)) {
3002 #ifndef HAS_SETREUID
3003 /* On this access check to make sure the directories are readable,
3004 * there is actually a small window that the user could use to make
3005 * filename point to an accessible directory. So there is a faint
3006 * chance that someone could execute a setuid script down in a
3007 * non-accessible directory. I don't know what to do about that.
3008 * But I don't think it's too important. The manual lies when
3009 * it says access() is useful in setuid programs.
3011 if (PerlLIO_access(CopFILE(PL_curcop),1)) /*double check*/
3012 Perl_croak(aTHX_ "Permission denied");
3014 /* If we can swap euid and uid, then we can determine access rights
3015 * with a simple stat of the file, and then compare device and
3016 * inode to make sure we did stat() on the same file we opened.
3017 * Then we just have to make sure he or she can execute it.
3020 struct stat tmpstatbuf;
3024 setreuid(PL_euid,PL_uid) < 0
3027 setresuid(PL_euid,PL_uid,(Uid_t)-1) < 0
3030 || PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid)
3031 Perl_croak(aTHX_ "Can't swap uid and euid"); /* really paranoid */
3032 if (PerlLIO_stat(CopFILE(PL_curcop),&tmpstatbuf) < 0)
3033 Perl_croak(aTHX_ "Permission denied"); /* testing full pathname here */
3034 #if defined(IAMSUID) && !defined(NO_NOSUID_CHECK)
3035 if (fd_on_nosuid_fs(PerlIO_fileno(PL_rsfp)))
3036 Perl_croak(aTHX_ "Permission denied");
3038 if (tmpstatbuf.st_dev != PL_statbuf.st_dev ||
3039 tmpstatbuf.st_ino != PL_statbuf.st_ino) {
3040 (void)PerlIO_close(PL_rsfp);
3041 Perl_croak(aTHX_ "Permission denied\n");
3045 setreuid(PL_uid,PL_euid) < 0
3047 # if defined(HAS_SETRESUID)
3048 setresuid(PL_uid,PL_euid,(Uid_t)-1) < 0
3051 || PerlProc_getuid() != PL_uid || PerlProc_geteuid() != PL_euid)
3052 Perl_croak(aTHX_ "Can't reswap uid and euid");
3053 if (!cando(S_IXUSR,FALSE,&PL_statbuf)) /* can real uid exec? */
3054 Perl_croak(aTHX_ "Permission denied\n");
3056 #endif /* HAS_SETREUID */
3057 #endif /* IAMSUID */
3059 if (!S_ISREG(PL_statbuf.st_mode))
3060 Perl_croak(aTHX_ "Permission denied");
3061 if (PL_statbuf.st_mode & S_IWOTH)
3062 Perl_croak(aTHX_ "Setuid/gid script is writable by world");
3063 PL_doswitches = FALSE; /* -s is insecure in suid */
3064 CopLINE_inc(PL_curcop);
3065 if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch ||
3066 strnNE(SvPV(PL_linestr,n_a),"#!",2) ) /* required even on Sys V */
3067 Perl_croak(aTHX_ "No #! line");
3068 s = SvPV(PL_linestr,n_a)+2;
3070 while (!isSPACE(*s)) s++;
3071 for (s2 = s; (s2 > SvPV(PL_linestr,n_a)+2 &&
3072 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
3073 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
3074 Perl_croak(aTHX_ "Not a perl script");
3075 while (*s == ' ' || *s == '\t') s++;
3077 * #! arg must be what we saw above. They can invoke it by
3078 * mentioning suidperl explicitly, but they may not add any strange
3079 * arguments beyond what #! says if they do invoke suidperl that way.
3081 len = strlen(validarg);
3082 if (strEQ(validarg," PHOOEY ") ||
3083 strnNE(s,validarg,len) || !isSPACE(s[len]))
3084 Perl_croak(aTHX_ "Args must match #! line");
3087 if (PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) &&
3088 PL_euid == PL_statbuf.st_uid)
3090 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
3091 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
3092 #endif /* IAMSUID */
3094 if (PL_euid) { /* oops, we're not the setuid root perl */
3095 (void)PerlIO_close(PL_rsfp);
3098 PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT, BIN_EXP,
3099 (int)PERL_REVISION, (int)PERL_VERSION,
3100 (int)PERL_SUBVERSION), PL_origargv);
3102 Perl_croak(aTHX_ "Can't do setuid\n");
3105 if (PL_statbuf.st_mode & S_ISGID && PL_statbuf.st_gid != PL_egid) {
3107 (void)setegid(PL_statbuf.st_gid);
3110 (void)setregid((Gid_t)-1,PL_statbuf.st_gid);
3112 #ifdef HAS_SETRESGID
3113 (void)setresgid((Gid_t)-1,PL_statbuf.st_gid,(Gid_t)-1);
3115 PerlProc_setgid(PL_statbuf.st_gid);
3119 if (PerlProc_getegid() != PL_statbuf.st_gid)
3120 Perl_croak(aTHX_ "Can't do setegid!\n");
3122 if (PL_statbuf.st_mode & S_ISUID) {
3123 if (PL_statbuf.st_uid != PL_euid)
3125 (void)seteuid(PL_statbuf.st_uid); /* all that for this */
3128 (void)setreuid((Uid_t)-1,PL_statbuf.st_uid);
3130 #ifdef HAS_SETRESUID
3131 (void)setresuid((Uid_t)-1,PL_statbuf.st_uid,(Uid_t)-1);
3133 PerlProc_setuid(PL_statbuf.st_uid);
3137 if (PerlProc_geteuid() != PL_statbuf.st_uid)
3138 Perl_croak(aTHX_ "Can't do seteuid!\n");
3140 else if (PL_uid) { /* oops, mustn't run as root */
3142 (void)seteuid((Uid_t)PL_uid);
3145 (void)setreuid((Uid_t)-1,(Uid_t)PL_uid);
3147 #ifdef HAS_SETRESUID
3148 (void)setresuid((Uid_t)-1,(Uid_t)PL_uid,(Uid_t)-1);
3150 PerlProc_setuid((Uid_t)PL_uid);
3154 if (PerlProc_geteuid() != PL_uid)
3155 Perl_croak(aTHX_ "Can't do seteuid!\n");
3158 if (!cando(S_IXUSR,TRUE,&PL_statbuf))
3159 Perl_croak(aTHX_ "Permission denied\n"); /* they can't do this */
3162 else if (PL_preprocess)
3163 Perl_croak(aTHX_ "-P not allowed for setuid/setgid script\n");
3164 else if (fdscript >= 0)
3165 Perl_croak(aTHX_ "fd script not allowed in suidperl\n");
3167 Perl_croak(aTHX_ "Script is not setuid/setgid in suidperl\n");
3169 /* We absolutely must clear out any saved ids here, so we */
3170 /* exec the real perl, substituting fd script for scriptname. */
3171 /* (We pass script name as "subdir" of fd, which perl will grok.) */
3172 PerlIO_rewind(PL_rsfp);
3173 PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0); /* just in case rewind didn't */
3174 for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ;
3175 if (!PL_origargv[which])
3176 Perl_croak(aTHX_ "Permission denied");
3177 PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s",
3178 PerlIO_fileno(PL_rsfp), PL_origargv[which]));
3179 #if defined(HAS_FCNTL) && defined(F_SETFD)
3180 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0); /* ensure no close-on-exec */
3182 PerlProc_execv(Perl_form(aTHX_ "%s/perl"PERL_FS_VER_FMT, BIN_EXP,
3183 (int)PERL_REVISION, (int)PERL_VERSION,
3184 (int)PERL_SUBVERSION), PL_origargv);/* try again */
3185 Perl_croak(aTHX_ "Can't do setuid\n");
3186 #endif /* IAMSUID */
3188 if (PL_euid != PL_uid || PL_egid != PL_gid) { /* (suidperl doesn't exist, in fact) */
3189 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
3190 PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf); /* may be either wrapped or real suid */
3191 if ((PL_euid != PL_uid && PL_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
3193 (PL_egid != PL_gid && PL_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
3196 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
3197 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
3198 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
3199 /* not set-id, must be wrapped */
3205 S_find_beginning(pTHX)
3207 register char *s, *s2;
3209 /* skip forward in input to the real script? */
3212 #ifdef MACOS_TRADITIONAL
3213 /* Since the Mac OS does not honor #! arguments for us, we do it ourselves */
3215 while (PL_doextract || gMacPerl_AlwaysExtract) {
3216 if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
3217 if (!gMacPerl_AlwaysExtract)
3218 Perl_croak(aTHX_ "No Perl script found in input\n");
3220 if (PL_doextract) /* require explicit override ? */
3221 if (!OverrideExtract(PL_origfilename))
3222 Perl_croak(aTHX_ "User aborted script\n");
3224 PL_doextract = FALSE;
3226 /* Pater peccavi, file does not have #! */
3227 PerlIO_rewind(PL_rsfp);
3232 while (PL_doextract) {
3233 if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch)
3234 Perl_croak(aTHX_ "No Perl script found in input\n");
3237 if (*s == '#' && s[1] == '!' && ((s = instr(s,"perl")) || (s = instr(s2,"PERL")))) {
3238 PerlIO_ungetc(PL_rsfp, '\n'); /* to keep line count right */
3239 PL_doextract = FALSE;
3240 while (*s && !(isSPACE (*s) || *s == '#')) s++;
3242 while (*s == ' ' || *s == '\t') s++;
3244 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
3245 if (strnEQ(s2-4,"perl",4))
3247 while ((s = moreswitches(s)))
3250 #ifdef MACOS_TRADITIONAL
3261 PL_uid = PerlProc_getuid();
3262 PL_euid = PerlProc_geteuid();
3263 PL_gid = PerlProc_getgid();
3264 PL_egid = PerlProc_getegid();
3266 PL_uid |= PL_gid << 16;
3267 PL_euid |= PL_egid << 16;
3269 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
3273 S_forbid_setid(pTHX_ char *s)
3275 if (PL_euid != PL_uid)
3276 Perl_croak(aTHX_ "No %s allowed while running setuid", s);
3277 if (PL_egid != PL_gid)
3278 Perl_croak(aTHX_ "No %s allowed while running setgid", s);
3282 Perl_init_debugger(pTHX)
3284 HV *ostash = PL_curstash;
3286 PL_curstash = PL_debstash;
3287 PL_dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
3288 AvREAL_off(PL_dbargs);
3289 PL_DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
3290 PL_DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
3291 PL_DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
3292 sv_upgrade(GvSV(PL_DBsub), SVt_IV); /* IVX accessed if PERLDB_SUB_NN */
3293 PL_DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
3294 sv_setiv(PL_DBsingle, 0);
3295 PL_DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
3296 sv_setiv(PL_DBtrace, 0);
3297 PL_DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
3298 sv_setiv(PL_DBsignal, 0);
3299 PL_curstash = ostash;
3302 #ifndef STRESS_REALLOC
3303 #define REASONABLE(size) (size)
3305 #define REASONABLE(size) (1) /* unreasonable */
3309 Perl_init_stacks(pTHX)
3311 /* start with 128-item stack and 8K cxstack */
3312 PL_curstackinfo = new_stackinfo(REASONABLE(128),
3313 REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
3314 PL_curstackinfo->si_type = PERLSI_MAIN;
3315 PL_curstack = PL_curstackinfo->si_stack;
3316 PL_mainstack = PL_curstack; /* remember in case we switch stacks */
3318 PL_stack_base = AvARRAY(PL_curstack);
3319 PL_stack_sp = PL_stack_base;
3320 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
3322 New(50,PL_tmps_stack,REASONABLE(128),SV*);
3325 PL_tmps_max = REASONABLE(128);
3327 New(54,PL_markstack,REASONABLE(32),I32);
3328 PL_markstack_ptr = PL_markstack;
3329 PL_markstack_max = PL_markstack + REASONABLE(32);
3333 New(54,PL_scopestack,REASONABLE(32),I32);
3334 PL_scopestack_ix = 0;
3335 PL_scopestack_max = REASONABLE(32);
3337 New(54,PL_savestack,REASONABLE(128),ANY);
3338 PL_savestack_ix = 0;
3339 PL_savestack_max = REASONABLE(128);
3341 New(54,PL_retstack,REASONABLE(16),OP*);
3343 PL_retstack_max = REASONABLE(16);
3351 while (PL_curstackinfo->si_next)
3352 PL_curstackinfo = PL_curstackinfo->si_next;
3353 while (PL_curstackinfo) {
3354 PERL_SI *p = PL_curstackinfo->si_prev;
3355 /* curstackinfo->si_stack got nuked by sv_free_arenas() */
3356 Safefree(PL_curstackinfo->si_cxstack);
3357 Safefree(PL_curstackinfo);
3358 PL_curstackinfo = p;
3360 Safefree(PL_tmps_stack);
3361 Safefree(PL_markstack);
3362 Safefree(PL_scopestack);
3363 Safefree(PL_savestack);
3364 Safefree(PL_retstack);
3373 lex_start(PL_linestr);
3375 PL_subname = newSVpvn("main",4);
3379 S_init_predump_symbols(pTHX)
3384 sv_setpvn(get_sv("\"", TRUE), " ", 1);
3385 PL_stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
3386 GvMULTI_on(PL_stdingv);
3387 io = GvIOp(PL_stdingv);
3388 IoTYPE(io) = IoTYPE_RDONLY;
3389 IoIFP(io) = PerlIO_stdin();
3390 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
3392 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
3394 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
3397 IoTYPE(io) = IoTYPE_WRONLY;
3398 IoOFP(io) = IoIFP(io) = PerlIO_stdout();
3400 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
3402 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
3404 PL_stderrgv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
3405 GvMULTI_on(PL_stderrgv);
3406 io = GvIOp(PL_stderrgv);
3407 IoTYPE(io) = IoTYPE_WRONLY;
3408 IoOFP(io) = IoIFP(io) = PerlIO_stderr();
3409 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
3411 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
3413 PL_statname = NEWSV(66,0); /* last filename we did stat on */
3416 Safefree(PL_osname);
3417 PL_osname = savepv(OSNAME);
3421 Perl_init_argv_symbols(pTHX_ register int argc, register char **argv)
3424 argc--,argv++; /* skip name of script */
3425 if (PL_doswitches) {
3426 for (; argc > 0 && **argv == '-'; argc--,argv++) {
3429 if (argv[0][1] == '-' && !argv[0][2]) {
3433 if ((s = strchr(argv[0], '='))) {
3435 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
3438 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
3441 if ((PL_argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV))) {
3442 GvMULTI_on(PL_argvgv);
3443 (void)gv_AVadd(PL_argvgv);
3444 av_clear(GvAVn(PL_argvgv));
3445 for (; argc > 0; argc--,argv++) {
3446 SV *sv = newSVpv(argv[0],0);
3447 av_push(GvAVn(PL_argvgv),sv);
3448 if (PL_widesyscalls)
3449 (void)sv_utf8_decode(sv);
3454 #ifdef HAS_PROCSELFEXE
3455 /* This is a function so that we don't hold on to MAXPATHLEN
3456 bytes of stack longer than necessary
3459 S_procself_val(pTHX_ SV *sv, char *arg0)
3461 char buf[MAXPATHLEN];
3462 int len = readlink(PROCSELFEXE_PATH, buf, sizeof(buf) - 1);
3463 /* FreeBSD's implementation is acknowledged to be imperfect, sometimes
3464 returning the text "unknown" from the readlink rather than the path
3465 to the executable (or returning an error from the readlink). Any valid
3466 path has a '/' in it somewhere, so use that to validate the result.
3467 See http://www.freebsd.org/cgi/query-pr.cgi?pr=35703
3469 if (len > 0 && memchr(buf, '/', len)) {
3470 sv_setpvn(sv,buf,len);
3476 #endif /* HAS_PROCSELFEXE */
3479 S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env)
3485 PL_toptarget = NEWSV(0,0);
3486 sv_upgrade(PL_toptarget, SVt_PVFM);
3487 sv_setpvn(PL_toptarget, "", 0);
3488 PL_bodytarget = NEWSV(0,0);
3489 sv_upgrade(PL_bodytarget, SVt_PVFM);
3490 sv_setpvn(PL_bodytarget, "", 0);
3491 PL_formtarget = PL_bodytarget;
3495 init_argv_symbols(argc,argv);
3497 if ((tmpgv = gv_fetchpv("0",TRUE, SVt_PV))) {
3498 #ifdef MACOS_TRADITIONAL
3499 /* $0 is not majick on a Mac */
3500 sv_setpv(GvSV(tmpgv),MacPerl_MPWFileName(PL_origfilename));
3502 sv_setpv(GvSV(tmpgv),PL_origfilename);
3503 magicname("0", "0", 1);
3506 if ((tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))) {/* $^X */
3507 #ifdef HAS_PROCSELFEXE
3508 S_procself_val(aTHX_ GvSV(tmpgv), PL_origargv[0]);
3511 sv_setpv(GvSV(tmpgv), os2_execname(aTHX));
3513 sv_setpv(GvSV(tmpgv),PL_origargv[0]);
3517 if ((PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV))) {
3519 GvMULTI_on(PL_envgv);
3520 hv = GvHVn(PL_envgv);
3521 hv_magic(hv, Nullgv, PERL_MAGIC_env);
3522 #ifdef USE_ENVIRON_ARRAY
3523 /* Note that if the supplied env parameter is actually a copy
3524 of the global environ then it may now point to free'd memory
3525 if the environment has been modified since. To avoid this
3526 problem we treat env==NULL as meaning 'use the default'
3531 environ[0] = Nullch;
3533 for (; *env; env++) {
3534 if (!(s = strchr(*env,'=')))
3541 sv = newSVpv(s+1, 0);
3542 (void)hv_store(hv, *env, s - *env, sv, 0);
3546 #endif /* USE_ENVIRON_ARRAY */
3549 if ((tmpgv = gv_fetchpv("$",TRUE, SVt_PV))) {
3550 SvREADONLY_off(GvSV(tmpgv));
3551 sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
3552 SvREADONLY_on(GvSV(tmpgv));
3557 S_init_perllib(pTHX)
3562 s = PerlEnv_getenv("PERL5LIB");
3564 incpush(s, TRUE, TRUE);
3566 incpush(PerlEnv_getenv("PERLLIB"), FALSE, FALSE);
3568 /* Treat PERL5?LIB as a possible search list logical name -- the
3569 * "natural" VMS idiom for a Unix path string. We allow each
3570 * element to be a set of |-separated directories for compatibility.
3574 if (my_trnlnm("PERL5LIB",buf,0))
3575 do { incpush(buf,TRUE,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
3577 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE,FALSE);
3581 /* Use the ~-expanded versions of APPLLIB (undocumented),
3582 ARCHLIB PRIVLIB SITEARCH SITELIB VENDORARCH and VENDORLIB
3585 incpush(APPLLIB_EXP, TRUE, TRUE);
3589 incpush(ARCHLIB_EXP, FALSE, FALSE);
3591 #ifdef MACOS_TRADITIONAL
3593 struct stat tmpstatbuf;
3594 SV * privdir = NEWSV(55, 0);
3595 char * macperl = PerlEnv_getenv("MACPERL");
3600 Perl_sv_setpvf(aTHX_ privdir, "%slib:", macperl);
3601 if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode))
3602 incpush(SvPVX(privdir), TRUE, FALSE);
3603 Perl_sv_setpvf(aTHX_ privdir, "%ssite_perl:", macperl);
3604 if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode))
3605 incpush(SvPVX(privdir), TRUE, FALSE);
3607 SvREFCNT_dec(privdir);
3610 incpush(":", FALSE, FALSE);
3613 # define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
3616 incpush(PRIVLIB_EXP, TRUE, FALSE);
3618 incpush(PRIVLIB_EXP, FALSE, FALSE);
3622 /* sitearch is always relative to sitelib on Windows for
3623 * DLL-based path intuition to work correctly */
3624 # if !defined(WIN32)
3625 incpush(SITEARCH_EXP, FALSE, FALSE);
3631 incpush(SITELIB_EXP, TRUE, FALSE); /* this picks up sitearch as well */
3633 incpush(SITELIB_EXP, FALSE, FALSE);
3637 #ifdef SITELIB_STEM /* Search for version-specific dirs below here */
3638 incpush(SITELIB_STEM, FALSE, TRUE);
3641 #ifdef PERL_VENDORARCH_EXP
3642 /* vendorarch is always relative to vendorlib on Windows for
3643 * DLL-based path intuition to work correctly */
3644 # if !defined(WIN32)
3645 incpush(PERL_VENDORARCH_EXP, FALSE, FALSE);
3649 #ifdef PERL_VENDORLIB_EXP
3651 incpush(PERL_VENDORLIB_EXP, TRUE, FALSE); /* this picks up vendorarch as well */
3653 incpush(PERL_VENDORLIB_EXP, FALSE, FALSE);
3657 #ifdef PERL_VENDORLIB_STEM /* Search for version-specific dirs below here */
3658 incpush(PERL_VENDORLIB_STEM, FALSE, TRUE);
3661 #ifdef PERL_OTHERLIBDIRS
3662 incpush(PERL_OTHERLIBDIRS, TRUE, TRUE);
3666 incpush(".", FALSE, FALSE);
3667 #endif /* MACOS_TRADITIONAL */
3670 #if defined(DOSISH) || defined(EPOC)
3671 # define PERLLIB_SEP ';'
3674 # define PERLLIB_SEP '|'
3676 # if defined(MACOS_TRADITIONAL)
3677 # define PERLLIB_SEP ','
3679 # define PERLLIB_SEP ':'
3683 #ifndef PERLLIB_MANGLE
3684 # define PERLLIB_MANGLE(s,n) (s)
3688 S_incpush(pTHX_ char *p, int addsubdirs, int addoldvers)
3690 SV *subdir = Nullsv;
3695 if (addsubdirs || addoldvers) {
3696 subdir = sv_newmortal();
3699 /* Break at all separators */
3701 SV *libdir = NEWSV(55,0);
3704 /* skip any consecutive separators */
3705 while ( *p == PERLLIB_SEP ) {
3706 /* Uncomment the next line for PATH semantics */
3707 /* av_push(GvAVn(PL_incgv), newSVpvn(".", 1)); */
3711 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
3712 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
3717 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
3718 p = Nullch; /* break out */
3720 #ifdef MACOS_TRADITIONAL
3721 if (!strchr(SvPVX(libdir), ':'))
3722 sv_insert(libdir, 0, 0, ":", 1);
3723 if (SvPVX(libdir)[SvCUR(libdir)-1] != ':')
3724 sv_catpv(libdir, ":");
3728 * BEFORE pushing libdir onto @INC we may first push version- and
3729 * archname-specific sub-directories.
3731 if (addsubdirs || addoldvers) {
3732 #ifdef PERL_INC_VERSION_LIST
3733 /* Configure terminates PERL_INC_VERSION_LIST with a NULL */
3734 const char *incverlist[] = { PERL_INC_VERSION_LIST };
3735 const char **incver;
3737 struct stat tmpstatbuf;
3742 if ((unix = tounixspec_ts(SvPV(libdir,len),Nullch)) != Nullch) {
3744 while (unix[len-1] == '/') len--; /* Cosmetic */
3745 sv_usepvn(libdir,unix,len);
3748 PerlIO_printf(Perl_error_log,
3749 "Failed to unixify @INC element \"%s\"\n",
3753 #ifdef MACOS_TRADITIONAL
3754 #define PERL_AV_SUFFIX_FMT ""
3755 #define PERL_ARCH_FMT "%s:"
3756 #define PERL_ARCH_FMT_PATH PERL_FS_VER_FMT PERL_AV_SUFFIX_FMT
3758 #define PERL_AV_SUFFIX_FMT "/"
3759 #define PERL_ARCH_FMT "/%s"
3760 #define PERL_ARCH_FMT_PATH PERL_AV_SUFFIX_FMT PERL_FS_VER_FMT
3762 /* .../version/archname if -d .../version/archname */
3763 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PATH PERL_ARCH_FMT,
3765 (int)PERL_REVISION, (int)PERL_VERSION,
3766 (int)PERL_SUBVERSION, ARCHNAME);
3767 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3768 S_ISDIR(tmpstatbuf.st_mode))
3769 av_push(GvAVn(PL_incgv), newSVsv(subdir));
3771 /* .../version if -d .../version */
3772 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PATH, libdir,
3773 (int)PERL_REVISION, (int)PERL_VERSION,
3774 (int)PERL_SUBVERSION);
3775 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3776 S_ISDIR(tmpstatbuf.st_mode))
3777 av_push(GvAVn(PL_incgv), newSVsv(subdir));
3779 /* .../archname if -d .../archname */
3780 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, libdir, ARCHNAME);
3781 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3782 S_ISDIR(tmpstatbuf.st_mode))
3783 av_push(GvAVn(PL_incgv), newSVsv(subdir));
3786 #ifdef PERL_INC_VERSION_LIST
3788 for (incver = incverlist; *incver; incver++) {
3789 /* .../xxx if -d .../xxx */
3790 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, libdir, *incver);
3791 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3792 S_ISDIR(tmpstatbuf.st_mode))
3793 av_push(GvAVn(PL_incgv), newSVsv(subdir));
3799 /* finally push this lib directory on the end of @INC */
3800 av_push(GvAVn(PL_incgv), libdir);
3804 #ifdef USE_5005THREADS
3805 STATIC struct perl_thread *
3806 S_init_main_thread(pTHX)
3808 #if !defined(PERL_IMPLICIT_CONTEXT)
3809 struct perl_thread *thr;
3813 Newz(53, thr, 1, struct perl_thread);
3814 PL_curcop = &PL_compiling;
3815 thr->interp = PERL_GET_INTERP;
3816 thr->cvcache = newHV();
3817 thr->threadsv = newAV();
3818 /* thr->threadsvp is set when find_threadsv is called */
3819 thr->specific = newAV();
3820 thr->flags = THRf_R_JOINABLE;
3821 MUTEX_INIT(&thr->mutex);
3822 /* Handcraft thrsv similarly to mess_sv */
3823 New(53, PL_thrsv, 1, SV);
3824 Newz(53, xpv, 1, XPV);
3825 SvFLAGS(PL_thrsv) = SVt_PV;
3826 SvANY(PL_thrsv) = (void*)xpv;
3827 SvREFCNT(PL_thrsv) = 1 << 30; /* practically infinite */
3828 SvPVX(PL_thrsv) = (char*)thr;
3829 SvCUR_set(PL_thrsv, sizeof(thr));
3830 SvLEN_set(PL_thrsv, sizeof(thr));
3831 *SvEND(PL_thrsv) = '\0'; /* in the trailing_nul field */
3832 thr->oursv = PL_thrsv;
3833 PL_chopset = " \n-";
3836 MUTEX_LOCK(&PL_threads_mutex);
3842 MUTEX_UNLOCK(&PL_threads_mutex);
3844 #ifdef HAVE_THREAD_INTERN
3845 Perl_init_thread_intern(thr);
3848 #ifdef SET_THREAD_SELF
3849 SET_THREAD_SELF(thr);
3851 thr->self = pthread_self();
3852 #endif /* SET_THREAD_SELF */
3856 * These must come after the thread self setting
3857 * because sv_setpvn does SvTAINT and the taint
3858 * fields thread selfness being set.
3860 PL_toptarget = NEWSV(0,0);
3861 sv_upgrade(PL_toptarget, SVt_PVFM);
3862 sv_setpvn(PL_toptarget, "", 0);
3863 PL_bodytarget = NEWSV(0,0);
3864 sv_upgrade(PL_bodytarget, SVt_PVFM);
3865 sv_setpvn(PL_bodytarget, "", 0);
3866 PL_formtarget = PL_bodytarget;
3867 thr->errsv = newSVpvn("", 0);
3868 (void) find_threadsv("@"); /* Ensure $@ is initialised early */
3871 PL_peepp = MEMBER_TO_FPTR(Perl_peep);
3872 PL_regcompp = MEMBER_TO_FPTR(Perl_pregcomp);
3873 PL_regexecp = MEMBER_TO_FPTR(Perl_regexec_flags);
3874 PL_regint_start = MEMBER_TO_FPTR(Perl_re_intuit_start);
3875 PL_regint_string = MEMBER_TO_FPTR(Perl_re_intuit_string);
3876 PL_regfree = MEMBER_TO_FPTR(Perl_pregfree);
3878 PL_reginterp_cnt = 0;
3882 #endif /* USE_5005THREADS */
3885 Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
3888 line_t oldline = CopLINE(PL_curcop);
3894 while (AvFILL(paramList) >= 0) {
3895 cv = (CV*)av_shift(paramList);
3896 if (PL_savebegin && (paramList == PL_beginav)) {
3897 /* save PL_beginav for compiler */
3898 if (! PL_beginav_save)
3899 PL_beginav_save = newAV();
3900 av_push(PL_beginav_save, (SV*)cv);
3904 #ifdef PERL_FLEXIBLE_EXCEPTIONS
3905 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_list_body), cv);
3911 #ifndef PERL_FLEXIBLE_EXCEPTIONS
3915 (void)SvPV(atsv, len);
3918 PL_curcop = &PL_compiling;
3919 CopLINE_set(PL_curcop, oldline);
3920 if (paramList == PL_beginav)
3921 sv_catpv(atsv, "BEGIN failed--compilation aborted");
3923 Perl_sv_catpvf(aTHX_ atsv,
3924 "%s failed--call queue aborted",
3925 paramList == PL_checkav ? "CHECK"
3926 : paramList == PL_initav ? "INIT"
3928 while (PL_scopestack_ix > oldscope)
3931 Perl_croak(aTHX_ "%s", SvPVx(atsv, n_a));
3938 /* my_exit() was called */
3939 while (PL_scopestack_ix > oldscope)
3942 PL_curstash = PL_defstash;
3943 PL_curcop = &PL_compiling;
3944 CopLINE_set(PL_curcop, oldline);
3946 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED)) {
3947 if (paramList == PL_beginav)
3948 Perl_croak(aTHX_ "BEGIN failed--compilation aborted");
3950 Perl_croak(aTHX_ "%s failed--call queue aborted",
3951 paramList == PL_checkav ? "CHECK"
3952 : paramList == PL_initav ? "INIT"
3959 PL_curcop = &PL_compiling;
3960 CopLINE_set(PL_curcop, oldline);
3963 PerlIO_printf(Perl_error_log, "panic: restartop\n");
3971 #ifdef PERL_FLEXIBLE_EXCEPTIONS
3973 S_vcall_list_body(pTHX_ va_list args)
3975 CV *cv = va_arg(args, CV*);
3976 return call_list_body(cv);
3981 S_call_list_body(pTHX_ CV *cv)
3983 PUSHMARK(PL_stack_sp);
3984 call_sv((SV*)cv, G_EVAL|G_DISCARD);
3989 Perl_my_exit(pTHX_ U32 status)
3991 DEBUG_S(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
3992 thr, (unsigned long) status));
4001 STATUS_NATIVE_SET(status);
4008 Perl_my_failure_exit(pTHX)
4011 if (vaxc$errno & 1) {
4012 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
4013 STATUS_NATIVE_SET(44);
4016 if (!vaxc$errno && errno) /* unlikely */
4017 STATUS_NATIVE_SET(44);
4019 STATUS_NATIVE_SET(vaxc$errno);
4024 STATUS_POSIX_SET(errno);
4026 exitstatus = STATUS_POSIX >> 8;
4027 if (exitstatus & 255)
4028 STATUS_POSIX_SET(exitstatus);
4030 STATUS_POSIX_SET(255);
4037 S_my_exit_jump(pTHX)
4039 register PERL_CONTEXT *cx;
4044 SvREFCNT_dec(PL_e_script);
4045 PL_e_script = Nullsv;
4048 POPSTACK_TO(PL_mainstack);
4049 if (cxstack_ix >= 0) {
4052 POPBLOCK(cx,PL_curpm);
4060 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen)
4063 p = SvPVX(PL_e_script);
4064 nl = strchr(p, '\n');
4065 nl = (nl) ? nl+1 : SvEND(PL_e_script);
4067 filter_del(read_e_script);
4070 sv_catpvn(buf_sv, p, nl-p);
4071 sv_chop(PL_e_script, nl);