3 * Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * "A ship then new they built for him/of mithril and of elven glass" --Bilbo
17 * Be proud that perl(1) may proclaim:
18 * Setuid Perl scripts are safer than C programs ...
19 * Do not abandon (deprecate) suidperl. Do not advocate C wrappers.
21 * The flow was: perl starts, notices script is suid, execs suidperl with same
22 * arguments; suidperl opens script, checks many things, sets itself with
23 * right UID, execs perl with similar arguments but with script pre-opened on
24 * /dev/fd/xxx; perl checks script is as should be and does work. This was
25 * insecure: see perlsec(1) for many problems with this approach.
27 * The "correct" flow should be: perl starts, opens script and notices it is
28 * suid, checks many things, execs suidperl with similar arguments but with
29 * script on /dev/fd/xxx; suidperl checks script and /dev/fd/xxx object are
30 * same, checks arguments match #! line, sets itself with right UID, execs
31 * perl with same arguments; perl checks many things and does work.
33 * (Opening the script in perl instead of suidperl, we "lose" scripts that
34 * are readable to the target UID but not to the invoker. Where did
35 * unreadable scripts work anyway?)
37 * For now, suidperl and perl are pretty much the same large and cumbersome
38 * program, so suidperl can check its argument list (see comments elsewhere).
41 * Original bug report:
42 * http://bugs.perl.org/index.html?req=bug_id&bug_id=20010322.218
43 * http://rt.perl.org/rt2/Ticket/Display.html?id=6511
44 * Comments and discussion with Debian:
45 * http://bugs.debian.org/203426
46 * http://bugs.debian.org/220486
47 * Debian Security Advisory DSA 431-1 (does not fully fix problem):
48 * http://www.debian.org/security/2004/dsa-431
50 * http://cve.mitre.org/cgi-bin/cvename.cgi?name=CAN-2003-0618
51 * Previous versions of this patch sent to perl5-porters:
52 * http://www.mail-archive.com/perl5-porters@perl.org/msg71953.html
53 * http://www.mail-archive.com/perl5-porters@perl.org/msg75245.html
54 * http://www.mail-archive.com/perl5-porters@perl.org/msg75563.html
55 * http://www.mail-archive.com/perl5-porters@perl.org/msg75635.html
57 Paul Szabo - psz@maths.usyd.edu.au http://www.maths.usyd.edu.au:8000/u/psz/
58 School of Mathematics and Statistics University of Sydney 2006 Australia
62 * Use truthful, neat, specific error messages.
63 * Cannot always hide the truth; security must not depend on doing so.
67 * Use global(?), thread-local fdscript for easier checks.
68 * (I do not understand how we could possibly get a thread race:
69 * do not all threads go through the same initialization? Or in
70 * fact, are not threads started only after we get the script and
71 * so know what to do? Oh well, make things super-safe...)
75 #define PERL_IN_PERL_C
77 #include "patchlevel.h" /* for local_patches */
81 char *nw_get_sitelib(const char *pl);
84 /* XXX If this causes problems, set i_unistd=undef in the hint file. */
101 #if !defined(STANDARD_C) && !defined(HAS_GETENV_PROTOTYPE) && !defined(PERL_MICRO)
102 char *getenv (char *); /* Usually in <stdlib.h> */
105 static I32 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen);
113 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
119 #if defined(USE_ITHREADS)
120 # define INIT_TLS_AND_INTERP \
122 if (!PL_curinterp) { \
123 PERL_SET_INTERP(my_perl); \
126 PERL_SET_THX(my_perl); \
128 MUTEX_INIT(&PL_dollarzero_mutex); \
131 PERL_SET_THX(my_perl); \
135 # define INIT_TLS_AND_INTERP \
137 if (!PL_curinterp) { \
138 PERL_SET_INTERP(my_perl); \
140 PERL_SET_THX(my_perl); \
144 #ifdef PERL_IMPLICIT_SYS
146 perl_alloc_using(struct IPerlMem* ipM, struct IPerlMem* ipMS,
147 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
148 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
149 struct IPerlDir* ipD, struct IPerlSock* ipS,
150 struct IPerlProc* ipP)
152 PerlInterpreter *my_perl;
153 /* New() needs interpreter, so call malloc() instead */
154 my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
156 Zero(my_perl, 1, PerlInterpreter);
172 =head1 Embedding Functions
174 =for apidoc perl_alloc
176 Allocates a new Perl interpreter. See L<perlembed>.
184 PerlInterpreter *my_perl;
185 #ifdef USE_5005THREADS
189 /* New() needs interpreter, so call malloc() instead */
190 my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
193 Zero(my_perl, 1, PerlInterpreter);
196 #endif /* PERL_IMPLICIT_SYS */
199 =for apidoc perl_construct
201 Initializes a new Perl interpreter. See L<perlembed>.
207 perl_construct(pTHXx)
211 PL_perl_destruct_level = 1;
213 if (PL_perl_destruct_level > 0)
216 /* Init the real globals (and main thread)? */
218 #ifdef PERL_FLEXIBLE_EXCEPTIONS
219 PL_protect = MEMBER_TO_FPTR(Perl_default_protect); /* for exceptions */
222 PL_curcop = &PL_compiling; /* needed by ckWARN, right away */
224 PL_linestr = NEWSV(65,79);
225 sv_upgrade(PL_linestr,SVt_PVIV);
227 if (!SvREADONLY(&PL_sv_undef)) {
228 /* set read-only and try to insure than we wont see REFCNT==0
231 SvREADONLY_on(&PL_sv_undef);
232 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
234 sv_setpv(&PL_sv_no,PL_No);
236 SvREADONLY_on(&PL_sv_no);
237 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
239 sv_setpv(&PL_sv_yes,PL_Yes);
241 SvREADONLY_on(&PL_sv_yes);
242 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
244 SvREADONLY_on(&PL_sv_placeholder);
245 SvREFCNT(&PL_sv_placeholder) = (~(U32)0)/2;
248 PL_sighandlerp = Perl_sighandler;
249 PL_pidstatus = newHV();
252 PL_rs = newSVpvn("\n", 1);
257 PL_lex_state = LEX_NOTPARSING;
263 SET_NUMERIC_STANDARD();
267 PL_patchlevel = NEWSV(0,4);
268 (void)SvUPGRADE(PL_patchlevel, SVt_PVNV);
269 if (PERL_REVISION > 127 || PERL_VERSION > 127 || PERL_SUBVERSION > 127)
270 SvGROW(PL_patchlevel, UTF8_MAXLEN*3+1);
271 s = (U8*)SvPVX(PL_patchlevel);
272 /* Build version strings using "native" characters */
273 s = uvchr_to_utf8(s, (UV)PERL_REVISION);
274 s = uvchr_to_utf8(s, (UV)PERL_VERSION);
275 s = uvchr_to_utf8(s, (UV)PERL_SUBVERSION);
277 SvCUR_set(PL_patchlevel, s - (U8*)SvPVX(PL_patchlevel));
278 SvPOK_on(PL_patchlevel);
279 SvNVX(PL_patchlevel) = (NV)PERL_REVISION +
280 ((NV)PERL_VERSION / (NV)1000) +
281 ((NV)PERL_SUBVERSION / (NV)1000000);
282 SvNOK_on(PL_patchlevel); /* dual valued */
283 SvUTF8_on(PL_patchlevel);
284 SvREADONLY_on(PL_patchlevel);
287 #if defined(LOCAL_PATCH_COUNT)
288 PL_localpatches = local_patches; /* For possible -v */
291 #ifdef HAVE_INTERP_INTERN
295 PerlIO_init(aTHX); /* Hook to IO system */
297 PL_fdpid = newAV(); /* for remembering popen pids by fd */
298 PL_modglobal = newHV(); /* pointers to per-interpreter module globals */
299 PL_errors = newSVpvn("",0);
300 sv_setpvn(PERL_DEBUG_PAD(0), "", 0); /* For regex debugging. */
301 sv_setpvn(PERL_DEBUG_PAD(1), "", 0); /* ext/re needs these */
302 sv_setpvn(PERL_DEBUG_PAD(2), "", 0); /* even without DEBUGGING. */
304 PL_regex_padav = newAV();
305 av_push(PL_regex_padav,(SV*)newAV()); /* First entry is an array of empty elements */
306 PL_regex_pad = AvARRAY(PL_regex_padav);
308 #ifdef USE_REENTRANT_API
309 Perl_reentrant_init(aTHX);
312 /* Note that strtab is a rather special HV. Assumptions are made
313 about not iterating on it, and not adding tie magic to it.
314 It is properly deallocated in perl_destruct() */
317 HvSHAREKEYS_off(PL_strtab); /* mandatory */
318 hv_ksplit(PL_strtab, 512);
320 #if defined(__DYNAMIC__) && (defined(NeXT) || defined(__NeXT__))
321 _dyld_lookup_and_bind
322 ("__environ", (unsigned long *) &environ_pointer, NULL);
326 # ifdef USE_ENVIRON_ARRAY
327 PL_origenviron = environ;
331 /* Use sysconf(_SC_CLK_TCK) if available, if not
332 * available or if the sysconf() fails, use the HZ. */
333 #if defined(HAS_SYSCONF) && defined(_SC_CLK_TCK)
334 PL_clocktick = sysconf(_SC_CLK_TCK);
335 if (PL_clocktick <= 0)
339 PL_stashcache = newHV();
345 =for apidoc nothreadhook
347 Stub that provides thread hook for perl_destruct when there are
354 Perl_nothreadhook(pTHX)
360 =for apidoc perl_destruct
362 Shuts down a Perl interpreter. See L<perlembed>.
370 volatile int destruct_level; /* 0=none, 1=full, 2=full with checks */
372 #ifdef USE_5005THREADS
374 #endif /* USE_5005THREADS */
376 /* wait for all pseudo-forked children to finish */
377 PERL_WAIT_FOR_CHILDREN;
379 destruct_level = PL_perl_destruct_level;
383 if ((s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL"))) {
385 if (destruct_level < i)
392 if(PL_exit_flags & PERL_EXIT_DESTRUCT_END) {
397 if (PL_endav && !PL_minus_c)
398 call_list(PL_scopestack_ix, PL_endav);
404 /* Need to flush since END blocks can produce output */
407 if (CALL_FPTR(PL_threadhook)(aTHX)) {
408 /* Threads hook has vetoed further cleanup */
409 return STATUS_NATIVE_EXPORT;
412 /* We must account for everything. */
414 /* Destroy the main CV and syntax tree */
416 /* ensure comppad/curpad to refer to main's pad */
417 if (CvPADLIST(PL_main_cv)) {
418 PAD_SET_CUR_NOSAVE(CvPADLIST(PL_main_cv), 1);
420 op_free(PL_main_root);
421 PL_main_root = Nullop;
423 PL_curcop = &PL_compiling;
424 PL_main_start = Nullop;
425 SvREFCNT_dec(PL_main_cv);
429 /* Tell PerlIO we are about to tear things apart in case
430 we have layers which are using resources that should
434 PerlIO_destruct(aTHX);
436 if (PL_sv_objcount) {
438 * Try to destruct global references. We do this first so that the
439 * destructors and destructees still exist. Some sv's might remain.
440 * Non-referenced objects are on their own.
446 /* unhook hooks which will soon be, or use, destroyed data */
447 SvREFCNT_dec(PL_warnhook);
448 PL_warnhook = Nullsv;
449 SvREFCNT_dec(PL_diehook);
452 /* call exit list functions */
453 while (PL_exitlistlen-- > 0)
454 PL_exitlist[PL_exitlistlen].fn(aTHX_ PL_exitlist[PL_exitlistlen].ptr);
456 Safefree(PL_exitlist);
461 if (destruct_level == 0){
463 DEBUG_P(debprofdump());
465 #if defined(PERLIO_LAYERS)
466 /* No more IO - including error messages ! */
467 PerlIO_cleanup(aTHX);
470 /* The exit() function will do everything that needs doing. */
471 return STATUS_NATIVE_EXPORT;
474 /* jettison our possibly duplicated environment */
475 /* if PERL_USE_SAFE_PUTENV is defined environ will not have been copied
476 * so we certainly shouldn't free it here
479 #if defined(USE_ENVIRON_ARRAY) && !defined(PERL_USE_SAFE_PUTENV)
480 if (environ != PL_origenviron
482 /* only main thread can free environ[0] contents */
483 && PL_curinterp == aTHX
489 for (i = 0; environ[i]; i++)
490 safesysfree(environ[i]);
492 /* Must use safesysfree() when working with environ. */
493 safesysfree(environ);
495 environ = PL_origenviron;
498 #endif /* !PERL_MICRO */
501 /* the syntax tree is shared between clones
502 * so op_free(PL_main_root) only ReREFCNT_dec's
503 * REGEXPs in the parent interpreter
504 * we need to manually ReREFCNT_dec for the clones
507 I32 i = AvFILLp(PL_regex_padav) + 1;
508 SV **ary = AvARRAY(PL_regex_padav);
512 REGEXP *re = INT2PTR(REGEXP *,SvIVX(resv));
514 if (SvFLAGS(resv) & SVf_BREAK) {
515 /* this is PL_reg_curpm, already freed
516 * flag is set in regexec.c:S_regtry
518 SvFLAGS(resv) &= ~SVf_BREAK;
520 else if(SvREPADTMP(resv)) {
521 SvREPADTMP_off(resv);
528 SvREFCNT_dec(PL_regex_padav);
529 PL_regex_padav = Nullav;
533 SvREFCNT_dec((SV*) PL_stashcache);
534 PL_stashcache = NULL;
536 /* loosen bonds of global variables */
539 (void)PerlIO_close(PL_rsfp);
543 /* Filters for program text */
544 SvREFCNT_dec(PL_rsfp_filters);
545 PL_rsfp_filters = Nullav;
548 PL_preprocess = FALSE;
554 PL_doswitches = FALSE;
555 PL_dowarn = G_WARN_OFF;
556 PL_doextract = FALSE;
557 PL_sawampersand = FALSE; /* must save all match strings */
560 Safefree(PL_inplace);
562 SvREFCNT_dec(PL_patchlevel);
565 SvREFCNT_dec(PL_e_script);
566 PL_e_script = Nullsv;
571 /* magical thingies */
573 SvREFCNT_dec(PL_ofs_sv); /* $, */
576 SvREFCNT_dec(PL_ors_sv); /* $\ */
579 SvREFCNT_dec(PL_rs); /* $/ */
582 PL_multiline = 0; /* $* */
583 Safefree(PL_osname); /* $^O */
586 SvREFCNT_dec(PL_statname);
587 PL_statname = Nullsv;
590 /* defgv, aka *_ should be taken care of elsewhere */
592 /* clean up after study() */
593 SvREFCNT_dec(PL_lastscream);
594 PL_lastscream = Nullsv;
595 Safefree(PL_screamfirst);
597 Safefree(PL_screamnext);
601 Safefree(PL_efloatbuf);
602 PL_efloatbuf = Nullch;
605 /* startup and shutdown function lists */
606 SvREFCNT_dec(PL_beginav);
607 SvREFCNT_dec(PL_beginav_save);
608 SvREFCNT_dec(PL_endav);
609 SvREFCNT_dec(PL_checkav);
610 SvREFCNT_dec(PL_checkav_save);
611 SvREFCNT_dec(PL_initav);
613 PL_beginav_save = Nullav;
616 PL_checkav_save = Nullav;
619 /* shortcuts just get cleared */
625 PL_argvoutgv = Nullgv;
627 PL_stderrgv = Nullgv;
628 PL_last_in_gv = Nullgv;
633 PL_DBsingle = Nullsv;
635 PL_DBsignal = Nullsv;
636 PL_DBassertion = Nullsv;
639 PL_debstash = Nullhv;
641 /* reset so print() ends up where we expect */
644 SvREFCNT_dec(PL_argvout_stack);
645 PL_argvout_stack = Nullav;
647 SvREFCNT_dec(PL_modglobal);
648 PL_modglobal = Nullhv;
649 SvREFCNT_dec(PL_preambleav);
650 PL_preambleav = Nullav;
651 SvREFCNT_dec(PL_subname);
653 SvREFCNT_dec(PL_linestr);
655 SvREFCNT_dec(PL_pidstatus);
656 PL_pidstatus = Nullhv;
657 SvREFCNT_dec(PL_toptarget);
658 PL_toptarget = Nullsv;
659 SvREFCNT_dec(PL_bodytarget);
660 PL_bodytarget = Nullsv;
661 PL_formtarget = Nullsv;
663 /* free locale stuff */
664 #ifdef USE_LOCALE_COLLATE
665 Safefree(PL_collation_name);
666 PL_collation_name = Nullch;
669 #ifdef USE_LOCALE_NUMERIC
670 Safefree(PL_numeric_name);
671 PL_numeric_name = Nullch;
672 SvREFCNT_dec(PL_numeric_radix_sv);
673 PL_numeric_radix_sv = Nullsv;
676 /* clear utf8 character classes */
677 SvREFCNT_dec(PL_utf8_alnum);
678 SvREFCNT_dec(PL_utf8_alnumc);
679 SvREFCNT_dec(PL_utf8_ascii);
680 SvREFCNT_dec(PL_utf8_alpha);
681 SvREFCNT_dec(PL_utf8_space);
682 SvREFCNT_dec(PL_utf8_cntrl);
683 SvREFCNT_dec(PL_utf8_graph);
684 SvREFCNT_dec(PL_utf8_digit);
685 SvREFCNT_dec(PL_utf8_upper);
686 SvREFCNT_dec(PL_utf8_lower);
687 SvREFCNT_dec(PL_utf8_print);
688 SvREFCNT_dec(PL_utf8_punct);
689 SvREFCNT_dec(PL_utf8_xdigit);
690 SvREFCNT_dec(PL_utf8_mark);
691 SvREFCNT_dec(PL_utf8_toupper);
692 SvREFCNT_dec(PL_utf8_totitle);
693 SvREFCNT_dec(PL_utf8_tolower);
694 SvREFCNT_dec(PL_utf8_tofold);
695 SvREFCNT_dec(PL_utf8_idstart);
696 SvREFCNT_dec(PL_utf8_idcont);
697 PL_utf8_alnum = Nullsv;
698 PL_utf8_alnumc = Nullsv;
699 PL_utf8_ascii = Nullsv;
700 PL_utf8_alpha = Nullsv;
701 PL_utf8_space = Nullsv;
702 PL_utf8_cntrl = Nullsv;
703 PL_utf8_graph = Nullsv;
704 PL_utf8_digit = Nullsv;
705 PL_utf8_upper = Nullsv;
706 PL_utf8_lower = Nullsv;
707 PL_utf8_print = Nullsv;
708 PL_utf8_punct = Nullsv;
709 PL_utf8_xdigit = Nullsv;
710 PL_utf8_mark = Nullsv;
711 PL_utf8_toupper = Nullsv;
712 PL_utf8_totitle = Nullsv;
713 PL_utf8_tolower = Nullsv;
714 PL_utf8_tofold = Nullsv;
715 PL_utf8_idstart = Nullsv;
716 PL_utf8_idcont = Nullsv;
718 if (!specialWARN(PL_compiling.cop_warnings))
719 SvREFCNT_dec(PL_compiling.cop_warnings);
720 PL_compiling.cop_warnings = Nullsv;
721 if (!specialCopIO(PL_compiling.cop_io))
722 SvREFCNT_dec(PL_compiling.cop_io);
723 PL_compiling.cop_io = Nullsv;
724 CopFILE_free(&PL_compiling);
725 CopSTASH_free(&PL_compiling);
727 /* Prepare to destruct main symbol table. */
732 SvREFCNT_dec(PL_curstname);
733 PL_curstname = Nullsv;
735 /* clear queued errors */
736 SvREFCNT_dec(PL_errors);
740 if (destruct_level >= 2 && ckWARN_d(WARN_INTERNAL)) {
741 if (PL_scopestack_ix != 0)
742 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
743 "Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
744 (long)PL_scopestack_ix);
745 if (PL_savestack_ix != 0)
746 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
747 "Unbalanced saves: %ld more saves than restores\n",
748 (long)PL_savestack_ix);
749 if (PL_tmps_floor != -1)
750 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced tmps: %ld more allocs than frees\n",
751 (long)PL_tmps_floor + 1);
752 if (cxstack_ix != -1)
753 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced context: %ld more PUSHes than POPs\n",
754 (long)cxstack_ix + 1);
757 /* Now absolutely destruct everything, somehow or other, loops or no. */
758 SvFLAGS(PL_fdpid) |= SVTYPEMASK; /* don't clean out pid table now */
759 SvFLAGS(PL_strtab) |= SVTYPEMASK; /* don't clean out strtab now */
761 /* the 2 is for PL_fdpid and PL_strtab */
762 while (PL_sv_count > 2 && sv_clean_all())
765 SvFLAGS(PL_fdpid) &= ~SVTYPEMASK;
766 SvFLAGS(PL_fdpid) |= SVt_PVAV;
767 SvFLAGS(PL_strtab) &= ~SVTYPEMASK;
768 SvFLAGS(PL_strtab) |= SVt_PVHV;
770 AvREAL_off(PL_fdpid); /* no surviving entries */
771 SvREFCNT_dec(PL_fdpid); /* needed in io_close() */
774 #ifdef HAVE_INTERP_INTERN
778 /* Destruct the global string table. */
780 /* Yell and reset the HeVAL() slots that are still holding refcounts,
781 * so that sv_free() won't fail on them.
789 max = HvMAX(PL_strtab);
790 array = HvARRAY(PL_strtab);
793 if (hent && ckWARN_d(WARN_INTERNAL)) {
794 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
795 "Unbalanced string table refcount: (%d) for \"%s\"",
796 HeVAL(hent) - Nullsv, HeKEY(hent));
797 HeVAL(hent) = Nullsv;
807 SvREFCNT_dec(PL_strtab);
810 /* free the pointer table used for cloning */
811 ptr_table_free(PL_ptr_table);
812 PL_ptr_table = (PTR_TBL_t*)NULL;
815 /* free special SVs */
817 SvREFCNT(&PL_sv_yes) = 0;
818 sv_clear(&PL_sv_yes);
819 SvANY(&PL_sv_yes) = NULL;
820 SvFLAGS(&PL_sv_yes) = 0;
822 SvREFCNT(&PL_sv_no) = 0;
824 SvANY(&PL_sv_no) = NULL;
825 SvFLAGS(&PL_sv_no) = 0;
829 for (i=0; i<=2; i++) {
830 SvREFCNT(PERL_DEBUG_PAD(i)) = 0;
831 sv_clear(PERL_DEBUG_PAD(i));
832 SvANY(PERL_DEBUG_PAD(i)) = NULL;
833 SvFLAGS(PERL_DEBUG_PAD(i)) = 0;
837 if (PL_sv_count != 0 && ckWARN_d(WARN_INTERNAL))
838 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Scalars leaked: %ld\n", (long)PL_sv_count);
840 #ifdef DEBUG_LEAKING_SCALARS
841 if (PL_sv_count != 0) {
846 for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) {
847 svend = &sva[SvREFCNT(sva)];
848 for (sv = sva + 1; sv < svend; ++sv) {
849 if (SvTYPE(sv) != SVTYPEMASK) {
850 PerlIO_printf(Perl_debug_log, "leaked: 0x%p\n", sv);
859 #if defined(PERLIO_LAYERS)
860 /* No more IO - including error messages ! */
861 PerlIO_cleanup(aTHX);
864 /* sv_undef needs to stay immortal until after PerlIO_cleanup
865 as currently layers use it rather than Nullsv as a marker
866 for no arg - and will try and SvREFCNT_dec it.
868 SvREFCNT(&PL_sv_undef) = 0;
869 SvREADONLY_off(&PL_sv_undef);
871 Safefree(PL_origfilename);
872 PL_origfilename = Nullch;
873 Safefree(PL_reg_start_tmp);
874 PL_reg_start_tmp = (char**)NULL;
875 PL_reg_start_tmpl = 0;
877 Safefree(PL_reg_curpm);
878 Safefree(PL_reg_poscache);
880 Safefree(PL_op_mask);
881 Safefree(PL_psig_ptr);
882 PL_psig_ptr = (SV**)NULL;
883 Safefree(PL_psig_name);
884 PL_psig_name = (SV**)NULL;
885 Safefree(PL_bitcount);
886 PL_bitcount = Nullch;
887 Safefree(PL_psig_pend);
888 PL_psig_pend = (int*)NULL;
889 PL_formfeed = Nullsv;
894 PL_taint_warn = FALSE;
895 PL_hints = 0; /* Reset hints. Should hints be per-interpreter ? */
898 DEBUG_P(debprofdump());
900 #ifdef USE_REENTRANT_API
901 Perl_reentrant_free(aTHX);
906 /* As the absolutely last thing, free the non-arena SV for mess() */
909 /* it could have accumulated taint magic */
910 if (SvTYPE(PL_mess_sv) >= SVt_PVMG) {
913 for (mg = SvMAGIC(PL_mess_sv); mg; mg = moremagic) {
914 moremagic = mg->mg_moremagic;
915 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global
917 Safefree(mg->mg_ptr);
921 /* we know that type >= SVt_PV */
922 (void)SvOOK_off(PL_mess_sv);
923 Safefree(SvPVX(PL_mess_sv));
924 Safefree(SvANY(PL_mess_sv));
925 Safefree(PL_mess_sv);
928 return STATUS_NATIVE_EXPORT;
932 =for apidoc perl_free
934 Releases a Perl interpreter. See L<perlembed>.
942 #if defined(WIN32) || defined(NETWARE)
943 # if defined(PERL_IMPLICIT_SYS)
945 void *host = nw_internal_host;
947 void *host = w32_internal_host;
951 nw_delete_internal_host(host);
953 win32_delete_internal_host(host);
964 Perl_call_atexit(pTHX_ ATEXIT_t fn, void *ptr)
966 Renew(PL_exitlist, PL_exitlistlen+1, PerlExitListEntry);
967 PL_exitlist[PL_exitlistlen].fn = fn;
968 PL_exitlist[PL_exitlistlen].ptr = ptr;
973 =for apidoc perl_parse
975 Tells a Perl interpreter to parse a Perl script. See L<perlembed>.
981 perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env)
986 #ifdef USE_5005THREADS
990 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
993 Perl_croak(aTHX_ "suidperl is no longer needed since the kernel can now execute\n\
994 setuid perl scripts securely.\n");
998 #if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT)
999 /* [perl #22371] Algorimic Complexity Attack on Perl 5.6.1, 5.8.0
1000 * This MUST be done before any hash stores or fetches take place.
1001 * If you set PL_rehash_seed (and assumedly also PL_rehash_seed_set)
1002 * yourself, it is your responsibility to provide a good random seed!
1003 * You can also define PERL_HASH_SEED in compile time, see hv.h. */
1004 if (!PL_rehash_seed_set)
1005 PL_rehash_seed = get_hash_seed();
1007 char *s = PerlEnv_getenv("PERL_HASH_SEED_DEBUG");
1013 PerlIO_printf(Perl_debug_log, "HASH_SEED = %"UVuf"\n",
1017 #endif /* #if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT) */
1023 /* Set PL_origalen be the sum of the contiguous argv[]
1024 * elements plus the size of the env in case that it is
1025 * contiguous with the argv[]. This is used in mg.c:Perl_magic_set()
1026 * as the maximum modifiable length of $0. In the worst case
1027 * the area we are able to modify is limited to the size of
1028 * the original argv[0]. (See below for 'contiguous', though.)
1033 ~(UV)(PTRSIZE == 4 ? 3 : PTRSIZE == 8 ? 7 : PTRSIZE == 16 ? 15 : 0);
1034 /* Do the mask check only if the args seem like aligned. */
1036 (mask < ~(UV)0) && ((PTR2UV(argv[0]) & mask) == PTR2UV(argv[0]));
1038 /* See if all the arguments are contiguous in memory. Note
1039 * that 'contiguous' is a loose term because some platforms
1040 * align the argv[] and the envp[]. If the arguments look
1041 * like non-aligned, assume that they are 'strictly' or
1042 * 'traditionally' contiguous. If the arguments look like
1043 * aligned, we just check that they are within aligned
1044 * PTRSIZE bytes. As long as no system has something bizarre
1045 * like the argv[] interleaved with some other data, we are
1046 * fine. (Did I just evoke Murphy's Law?) --jhi */
1047 if (PL_origargv && PL_origargc >= 1 && (s = PL_origargv[0])) {
1049 for (i = 1; i < PL_origargc; i++) {
1050 if ((PL_origargv[i] == s + 1
1052 || PL_origargv[i] == s + 2
1057 (PL_origargv[i] > s &&
1059 INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask)))
1069 /* Can we grab env area too to be used as the area for $0? */
1070 if (PL_origenviron) {
1071 if ((PL_origenviron[0] == s + 1
1073 || (PL_origenviron[0] == s + 9 && (s += 8))
1078 (PL_origenviron[0] > s &&
1079 PL_origenviron[0] <=
1080 INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask)))
1084 s = PL_origenviron[0];
1087 my_setenv("NoNe SuCh", Nullch);
1088 /* Force copy of environment. */
1089 for (i = 1; PL_origenviron[i]; i++) {
1090 if (PL_origenviron[i] == s + 1
1093 (PL_origenviron[i] > s &&
1094 PL_origenviron[i] <=
1095 INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask)))
1098 s = PL_origenviron[i];
1106 PL_origalen = s - PL_origargv[0] + 1;
1111 /* Come here if running an undumped a.out. */
1113 PL_origfilename = savepv(argv[0]);
1114 PL_do_undump = FALSE;
1115 cxstack_ix = -1; /* start label stack again */
1117 init_postdump_symbols(argc,argv,env);
1122 op_free(PL_main_root);
1123 PL_main_root = Nullop;
1125 PL_main_start = Nullop;
1126 SvREFCNT_dec(PL_main_cv);
1127 PL_main_cv = Nullcv;
1130 oldscope = PL_scopestack_ix;
1131 PL_dowarn = G_WARN_OFF;
1133 #ifdef PERL_FLEXIBLE_EXCEPTIONS
1134 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vparse_body), env, xsinit);
1140 #ifndef PERL_FLEXIBLE_EXCEPTIONS
1141 parse_body(env,xsinit);
1144 call_list(oldscope, PL_checkav);
1151 /* my_exit() was called */
1152 while (PL_scopestack_ix > oldscope)
1155 PL_curstash = PL_defstash;
1157 call_list(oldscope, PL_checkav);
1158 ret = STATUS_NATIVE_EXPORT;
1161 PerlIO_printf(Perl_error_log, "panic: top_env\n");
1169 #ifdef PERL_FLEXIBLE_EXCEPTIONS
1171 S_vparse_body(pTHX_ va_list args)
1173 char **env = va_arg(args, char**);
1174 XSINIT_t xsinit = va_arg(args, XSINIT_t);
1176 return parse_body(env, xsinit);
1181 S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
1183 int argc = PL_origargc;
1184 char **argv = PL_origargv;
1185 char *scriptname = NULL;
1186 VOL bool dosearch = FALSE;
1187 char *validarg = "";
1190 char *cddir = Nullch;
1194 sv_setpvn(PL_linestr,"",0);
1195 sv = newSVpvn("",0); /* first used for -I flags */
1199 for (argc--,argv++; argc > 0; argc--,argv++) {
1200 if (argv[0][0] != '-' || !argv[0][1])
1204 validarg = " PHOOEY ";
1208 * Can we rely on the kernel to start scripts with argv[1] set to
1209 * contain all #! line switches (the whole line)? (argv[0] is set to
1210 * the interpreter name, argv[2] to the script name; argv[3] and
1211 * above may contain other arguments.)
1218 #ifndef PERL_STRICT_CR
1243 if ((s = moreswitches(s)))
1248 CHECK_MALLOC_TOO_LATE_FOR('t');
1249 if( !PL_tainting ) {
1250 PL_taint_warn = TRUE;
1256 CHECK_MALLOC_TOO_LATE_FOR('T');
1258 PL_taint_warn = FALSE;
1263 #ifdef MACOS_TRADITIONAL
1264 /* ignore -e for Dev:Pseudo argument */
1265 if (argv[1] && !strcmp(argv[1], "Dev:Pseudo"))
1270 PL_e_script = newSVpvn("",0);
1271 filter_add(read_e_script, NULL);
1274 sv_catpv(PL_e_script, s);
1276 sv_catpv(PL_e_script, argv[1]);
1280 Perl_croak(aTHX_ "No code specified for -e");
1281 sv_catpv(PL_e_script, "\n");
1284 case 'I': /* -I handled both here and in moreswitches() */
1286 if (!*++s && (s=argv[1]) != Nullch) {
1291 STRLEN len = strlen(s);
1292 p = savepvn(s, len);
1293 incpush(p, TRUE, TRUE, FALSE);
1294 sv_catpvn(sv, "-I", 2);
1295 sv_catpvn(sv, p, len);
1296 sv_catpvn(sv, " ", 1);
1300 Perl_croak(aTHX_ "No directory specified for -I");
1304 PL_preprocess = TRUE;
1314 PL_preambleav = newAV();
1315 av_push(PL_preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
1317 PL_Sv = newSVpv("print myconfig();",0);
1319 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
1321 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
1323 sv_catpv(PL_Sv,"\" Compile-time options:");
1325 sv_catpv(PL_Sv," DEBUGGING");
1327 # ifdef MULTIPLICITY
1328 sv_catpv(PL_Sv," MULTIPLICITY");
1330 # ifdef USE_5005THREADS
1331 sv_catpv(PL_Sv," USE_5005THREADS");
1333 # ifdef USE_ITHREADS
1334 sv_catpv(PL_Sv," USE_ITHREADS");
1336 # ifdef USE_64_BIT_INT
1337 sv_catpv(PL_Sv," USE_64_BIT_INT");
1339 # ifdef USE_64_BIT_ALL
1340 sv_catpv(PL_Sv," USE_64_BIT_ALL");
1342 # ifdef USE_LONG_DOUBLE
1343 sv_catpv(PL_Sv," USE_LONG_DOUBLE");
1345 # ifdef USE_LARGE_FILES
1346 sv_catpv(PL_Sv," USE_LARGE_FILES");
1349 sv_catpv(PL_Sv," USE_SOCKS");
1351 # ifdef PERL_IMPLICIT_CONTEXT
1352 sv_catpv(PL_Sv," PERL_IMPLICIT_CONTEXT");
1354 # ifdef PERL_IMPLICIT_SYS
1355 sv_catpv(PL_Sv," PERL_IMPLICIT_SYS");
1357 sv_catpv(PL_Sv,"\\n\",");
1359 #if defined(LOCAL_PATCH_COUNT)
1360 if (LOCAL_PATCH_COUNT > 0) {
1362 sv_catpv(PL_Sv,"\" Locally applied patches:\\n\",");
1363 for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
1364 if (PL_localpatches[i])
1365 Perl_sv_catpvf(aTHX_ PL_Sv,"q\" \t%s\n\",",PL_localpatches[i]);
1369 Perl_sv_catpvf(aTHX_ PL_Sv,"\" Built under %s\\n\"",OSNAME);
1372 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
1374 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled on %s\\n\"",__DATE__);
1377 sv_catpv(PL_Sv, "; \
1379 @env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; ");
1382 push @env, \"CYGWIN=\\\"$ENV{CYGWIN}\\\"\";");
1385 print \" \\%ENV:\\n @env\\n\" if @env; \
1386 print \" \\@INC:\\n @INC\\n\";");
1389 PL_Sv = newSVpv("config_vars(qw(",0);
1390 sv_catpv(PL_Sv, ++s);
1391 sv_catpv(PL_Sv, "))");
1394 av_push(PL_preambleav, PL_Sv);
1395 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
1398 PL_doextract = TRUE;
1406 if (!*++s || isSPACE(*s)) {
1410 /* catch use of gnu style long options */
1411 if (strEQ(s, "version")) {
1415 if (strEQ(s, "help")) {
1422 Perl_croak(aTHX_ "Unrecognized switch: -%s (-h will show valid options)",s);
1428 #ifndef SECURE_INTERNAL_GETENV
1431 (s = PerlEnv_getenv("PERL5OPT")))
1436 if (*s == '-' && *(s+1) == 'T') {
1437 CHECK_MALLOC_TOO_LATE_FOR('T');
1439 PL_taint_warn = FALSE;
1442 char *popt_copy = Nullch;
1455 if (!strchr("DIMUdmtwA", *s))
1456 Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s);
1460 popt_copy = SvPVX(sv_2mortal(newSVpv(popt,0)));
1461 s = popt_copy + (s - popt);
1462 d = popt_copy + (d - popt);
1469 if( !PL_tainting ) {
1470 PL_taint_warn = TRUE;
1480 if (PL_taint_warn && PL_dowarn != G_WARN_ALL_OFF) {
1481 PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
1485 scriptname = argv[0];
1488 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
1490 else if (scriptname == Nullch) {
1492 if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
1500 open_script(scriptname,dosearch,sv);
1502 validate_suid(validarg, scriptname);
1505 #if defined(SIGCHLD) || defined(SIGCLD)
1508 # define SIGCHLD SIGCLD
1510 Sighandler_t sigstate = rsignal_state(SIGCHLD);
1511 if (sigstate == SIG_IGN) {
1512 if (ckWARN(WARN_SIGNAL))
1513 Perl_warner(aTHX_ packWARN(WARN_SIGNAL),
1514 "Can't ignore signal CHLD, forcing to default");
1515 (void)rsignal(SIGCHLD, (Sighandler_t)SIG_DFL);
1521 #ifdef MACOS_TRADITIONAL
1522 if (PL_doextract || gMacPerl_AlwaysExtract) {
1527 if (cddir && PerlDir_chdir(cddir) < 0)
1528 Perl_croak(aTHX_ "Can't chdir to %s",cddir);
1532 PL_main_cv = PL_compcv = (CV*)NEWSV(1104,0);
1533 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
1534 CvUNIQUE_on(PL_compcv);
1536 CvPADLIST(PL_compcv) = pad_new(0);
1537 #ifdef USE_5005THREADS
1538 CvOWNER(PL_compcv) = 0;
1539 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
1540 MUTEX_INIT(CvMUTEXP(PL_compcv));
1541 #endif /* USE_5005THREADS */
1544 boot_core_UNIVERSAL();
1545 boot_core_xsutils();
1548 (*xsinit)(aTHX); /* in case linked C routines want magical variables */
1550 #if defined(VMS) || defined(WIN32) || defined(DJGPP) || defined(__CYGWIN__) || defined(EPOC)
1556 # ifdef HAS_SOCKS5_INIT
1557 socks5_init(argv[0]);
1563 init_predump_symbols();
1564 /* init_postdump_symbols not currently designed to be called */
1565 /* more than once (ENV isn't cleared first, for example) */
1566 /* But running with -u leaves %ENV & @ARGV undefined! XXX */
1568 init_postdump_symbols(argc,argv,env);
1570 /* PL_unicode is turned on by -C or by $ENV{PERL_UNICODE}.
1571 * PL_utf8locale is conditionally turned on by
1572 * locale.c:Perl_init_i18nl10n() if the environment
1573 * look like the user wants to use UTF-8. */
1575 /* Requires init_predump_symbols(). */
1576 if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) {
1581 /* Turn on UTF-8-ness on STDIN, STDOUT, STDERR
1582 * and the default open disciplines. */
1583 if ((PL_unicode & PERL_UNICODE_STDIN_FLAG) &&
1584 PL_stdingv && (io = GvIO(PL_stdingv)) &&
1586 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
1587 if ((PL_unicode & PERL_UNICODE_STDOUT_FLAG) &&
1588 PL_defoutgv && (io = GvIO(PL_defoutgv)) &&
1590 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
1591 if ((PL_unicode & PERL_UNICODE_STDERR_FLAG) &&
1592 PL_stderrgv && (io = GvIO(PL_stderrgv)) &&
1594 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
1595 if ((PL_unicode & PERL_UNICODE_INOUT_FLAG) &&
1596 (sv = GvSV(gv_fetchpv("\017PEN", TRUE, SVt_PV)))) {
1597 U32 in = PL_unicode & PERL_UNICODE_IN_FLAG;
1598 U32 out = PL_unicode & PERL_UNICODE_OUT_FLAG;
1601 sv_setpvn(sv, ":utf8\0:utf8", 11);
1603 sv_setpvn(sv, ":utf8\0", 6);
1606 sv_setpvn(sv, "\0:utf8", 6);
1612 if ((s = PerlEnv_getenv("PERL_SIGNALS"))) {
1613 if (strEQ(s, "unsafe"))
1614 PL_signals |= PERL_SIGNALS_UNSAFE_FLAG;
1615 else if (strEQ(s, "safe"))
1616 PL_signals &= ~PERL_SIGNALS_UNSAFE_FLAG;
1618 Perl_croak(aTHX_ "PERL_SIGNALS illegal: \"%s\"", s);
1623 /* now parse the script */
1625 SETERRNO(0,SS_NORMAL);
1627 #ifdef MACOS_TRADITIONAL
1628 if (gMacPerl_SyntaxError = (yyparse() || PL_error_count)) {
1630 Perl_croak(aTHX_ "%s had compilation errors.\n", MacPerl_MPWFileName(PL_origfilename));
1632 Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
1633 MacPerl_MPWFileName(PL_origfilename));
1637 if (yyparse() || PL_error_count) {
1639 Perl_croak(aTHX_ "%s had compilation errors.\n", PL_origfilename);
1641 Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
1646 CopLINE_set(PL_curcop, 0);
1647 PL_curstash = PL_defstash;
1648 PL_preprocess = FALSE;
1650 SvREFCNT_dec(PL_e_script);
1651 PL_e_script = Nullsv;
1658 SAVECOPFILE(PL_curcop);
1659 SAVECOPLINE(PL_curcop);
1660 gv_check(PL_defstash);
1667 if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
1668 dump_mstats("after compilation:");
1677 =for apidoc perl_run
1679 Tells a Perl interpreter to run. See L<perlembed>.
1690 #ifdef USE_5005THREADS
1694 oldscope = PL_scopestack_ix;
1699 #ifdef PERL_FLEXIBLE_EXCEPTIONS
1701 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vrun_body), oldscope);
1707 cxstack_ix = -1; /* start context stack again */
1709 case 0: /* normal completion */
1710 #ifndef PERL_FLEXIBLE_EXCEPTIONS
1715 case 2: /* my_exit() */
1716 while (PL_scopestack_ix > oldscope)
1719 PL_curstash = PL_defstash;
1720 if (!(PL_exit_flags & PERL_EXIT_DESTRUCT_END) &&
1721 PL_endav && !PL_minus_c)
1722 call_list(oldscope, PL_endav);
1724 if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
1725 dump_mstats("after execution: ");
1727 ret = STATUS_NATIVE_EXPORT;
1731 POPSTACK_TO(PL_mainstack);
1734 PerlIO_printf(Perl_error_log, "panic: restartop\n");
1744 #ifdef PERL_FLEXIBLE_EXCEPTIONS
1746 S_vrun_body(pTHX_ va_list args)
1748 I32 oldscope = va_arg(args, I32);
1750 return run_body(oldscope);
1756 S_run_body(pTHX_ I32 oldscope)
1758 DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
1759 PL_sawampersand ? "Enabling" : "Omitting"));
1761 if (!PL_restartop) {
1762 DEBUG_x(dump_all());
1764 PERL_DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
1765 DEBUG_S(PerlIO_printf(Perl_debug_log, "main thread is 0x%"UVxf"\n",
1769 #ifdef MACOS_TRADITIONAL
1770 PerlIO_printf(Perl_error_log, "%s%s syntax OK\n",
1771 (gMacPerl_ErrorFormat ? "# " : ""),
1772 MacPerl_MPWFileName(PL_origfilename));
1774 PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename);
1778 if (PERLDB_SINGLE && PL_DBsingle)
1779 sv_setiv(PL_DBsingle, 1);
1781 call_list(oldscope, PL_initav);
1787 PL_op = PL_restartop;
1791 else if (PL_main_start) {
1792 CvDEPTH(PL_main_cv) = 1;
1793 PL_op = PL_main_start;
1803 =head1 SV Manipulation Functions
1805 =for apidoc p||get_sv
1807 Returns the SV of the specified Perl scalar. If C<create> is set and the
1808 Perl variable does not exist then it will be created. If C<create> is not
1809 set and the variable does not exist then NULL is returned.
1815 Perl_get_sv(pTHX_ const char *name, I32 create)
1818 #ifdef USE_5005THREADS
1819 if (name[1] == '\0' && !isALPHA(name[0])) {
1820 PADOFFSET tmp = find_threadsv(name);
1821 if (tmp != NOT_IN_PAD)
1822 return THREADSV(tmp);
1824 #endif /* USE_5005THREADS */
1825 gv = gv_fetchpv(name, create, SVt_PV);
1832 =head1 Array Manipulation Functions
1834 =for apidoc p||get_av
1836 Returns the AV of the specified Perl array. If C<create> is set and the
1837 Perl variable does not exist then it will be created. If C<create> is not
1838 set and the variable does not exist then NULL is returned.
1844 Perl_get_av(pTHX_ const char *name, I32 create)
1846 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
1855 =head1 Hash Manipulation Functions
1857 =for apidoc p||get_hv
1859 Returns the HV of the specified Perl hash. If C<create> is set and the
1860 Perl variable does not exist then it will be created. If C<create> is not
1861 set and the variable does not exist then NULL is returned.
1867 Perl_get_hv(pTHX_ const char *name, I32 create)
1869 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
1878 =head1 CV Manipulation Functions
1880 =for apidoc p||get_cv
1882 Returns the CV of the specified Perl subroutine. If C<create> is set and
1883 the Perl subroutine does not exist then it will be declared (which has the
1884 same effect as saying C<sub name;>). If C<create> is not set and the
1885 subroutine does not exist then NULL is returned.
1891 Perl_get_cv(pTHX_ const char *name, I32 create)
1893 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
1894 /* XXX unsafe for threads if eval_owner isn't held */
1895 /* XXX this is probably not what they think they're getting.
1896 * It has the same effect as "sub name;", i.e. just a forward
1898 if (create && !GvCVu(gv))
1899 return newSUB(start_subparse(FALSE, 0),
1900 newSVOP(OP_CONST, 0, newSVpv(name,0)),
1908 /* Be sure to refetch the stack pointer after calling these routines. */
1912 =head1 Callback Functions
1914 =for apidoc p||call_argv
1916 Performs a callback to the specified Perl sub. See L<perlcall>.
1922 Perl_call_argv(pTHX_ const char *sub_name, I32 flags, register char **argv)
1924 /* See G_* flags in cop.h */
1925 /* null terminated arg list */
1932 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
1937 return call_pv(sub_name, flags);
1941 =for apidoc p||call_pv
1943 Performs a callback to the specified Perl sub. See L<perlcall>.
1949 Perl_call_pv(pTHX_ const char *sub_name, I32 flags)
1950 /* name of the subroutine */
1951 /* See G_* flags in cop.h */
1953 return call_sv((SV*)get_cv(sub_name, TRUE), flags);
1957 =for apidoc p||call_method
1959 Performs a callback to the specified Perl method. The blessed object must
1960 be on the stack. See L<perlcall>.
1966 Perl_call_method(pTHX_ const char *methname, I32 flags)
1967 /* name of the subroutine */
1968 /* See G_* flags in cop.h */
1970 return call_sv(sv_2mortal(newSVpv(methname,0)), flags | G_METHOD);
1973 /* May be called with any of a CV, a GV, or an SV containing the name. */
1975 =for apidoc p||call_sv
1977 Performs a callback to the Perl sub whose name is in the SV. See
1984 Perl_call_sv(pTHX_ SV *sv, I32 flags)
1985 /* See G_* flags in cop.h */
1988 LOGOP myop; /* fake syntax tree node */
1991 volatile I32 retval = 0;
1993 bool oldcatch = CATCH_GET;
1998 if (flags & G_DISCARD) {
2003 Zero(&myop, 1, LOGOP);
2004 myop.op_next = Nullop;
2005 if (!(flags & G_NOARGS))
2006 myop.op_flags |= OPf_STACKED;
2007 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
2008 (flags & G_ARRAY) ? OPf_WANT_LIST :
2013 EXTEND(PL_stack_sp, 1);
2014 *++PL_stack_sp = sv;
2016 oldscope = PL_scopestack_ix;
2018 if (PERLDB_SUB && PL_curstash != PL_debstash
2019 /* Handle first BEGIN of -d. */
2020 && (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub)))
2021 /* Try harder, since this may have been a sighandler, thus
2022 * curstash may be meaningless. */
2023 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != PL_debstash)
2024 && !(flags & G_NODEBUG))
2025 PL_op->op_private |= OPpENTERSUB_DB;
2027 if (flags & G_METHOD) {
2028 Zero(&method_op, 1, UNOP);
2029 method_op.op_next = PL_op;
2030 method_op.op_ppaddr = PL_ppaddr[OP_METHOD];
2031 myop.op_ppaddr = PL_ppaddr[OP_ENTERSUB];
2032 PL_op = (OP*)&method_op;
2035 if (!(flags & G_EVAL)) {
2037 call_body((OP*)&myop, FALSE);
2038 retval = PL_stack_sp - (PL_stack_base + oldmark);
2039 CATCH_SET(oldcatch);
2042 myop.op_other = (OP*)&myop;
2044 /* we're trying to emulate pp_entertry() here */
2046 register PERL_CONTEXT *cx;
2047 I32 gimme = GIMME_V;
2052 push_return(Nullop);
2053 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
2055 PL_eval_root = PL_op; /* Only needed so that goto works right. */
2057 PL_in_eval = EVAL_INEVAL;
2058 if (flags & G_KEEPERR)
2059 PL_in_eval |= EVAL_KEEPERR;
2065 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2067 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_body),
2074 #ifndef PERL_FLEXIBLE_EXCEPTIONS
2076 call_body((OP*)&myop, FALSE);
2078 retval = PL_stack_sp - (PL_stack_base + oldmark);
2079 if (!(flags & G_KEEPERR))
2086 /* my_exit() was called */
2087 PL_curstash = PL_defstash;
2090 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
2091 Perl_croak(aTHX_ "Callback called exit");
2096 PL_op = PL_restartop;
2100 PL_stack_sp = PL_stack_base + oldmark;
2101 if (flags & G_ARRAY)
2105 *++PL_stack_sp = &PL_sv_undef;
2110 if (PL_scopestack_ix > oldscope) {
2114 register PERL_CONTEXT *cx;
2126 if (flags & G_DISCARD) {
2127 PL_stack_sp = PL_stack_base + oldmark;
2136 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2138 S_vcall_body(pTHX_ va_list args)
2140 OP *myop = va_arg(args, OP*);
2141 int is_eval = va_arg(args, int);
2143 call_body(myop, is_eval);
2149 S_call_body(pTHX_ OP *myop, int is_eval)
2151 if (PL_op == myop) {
2153 PL_op = Perl_pp_entereval(aTHX); /* this doesn't do a POPMARK */
2155 PL_op = Perl_pp_entersub(aTHX); /* this does */
2161 /* Eval a string. The G_EVAL flag is always assumed. */
2164 =for apidoc p||eval_sv
2166 Tells Perl to C<eval> the string in the SV.
2172 Perl_eval_sv(pTHX_ SV *sv, I32 flags)
2174 /* See G_* flags in cop.h */
2177 UNOP myop; /* fake syntax tree node */
2178 volatile I32 oldmark = SP - PL_stack_base;
2179 volatile I32 retval = 0;
2185 if (flags & G_DISCARD) {
2192 Zero(PL_op, 1, UNOP);
2193 EXTEND(PL_stack_sp, 1);
2194 *++PL_stack_sp = sv;
2195 oldscope = PL_scopestack_ix;
2197 if (!(flags & G_NOARGS))
2198 myop.op_flags = OPf_STACKED;
2199 myop.op_next = Nullop;
2200 myop.op_type = OP_ENTEREVAL;
2201 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
2202 (flags & G_ARRAY) ? OPf_WANT_LIST :
2204 if (flags & G_KEEPERR)
2205 myop.op_flags |= OPf_SPECIAL;
2207 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2209 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_body),
2216 #ifndef PERL_FLEXIBLE_EXCEPTIONS
2218 call_body((OP*)&myop,TRUE);
2220 retval = PL_stack_sp - (PL_stack_base + oldmark);
2221 if (!(flags & G_KEEPERR))
2228 /* my_exit() was called */
2229 PL_curstash = PL_defstash;
2232 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
2233 Perl_croak(aTHX_ "Callback called exit");
2238 PL_op = PL_restartop;
2242 PL_stack_sp = PL_stack_base + oldmark;
2243 if (flags & G_ARRAY)
2247 *++PL_stack_sp = &PL_sv_undef;
2253 if (flags & G_DISCARD) {
2254 PL_stack_sp = PL_stack_base + oldmark;
2264 =for apidoc p||eval_pv
2266 Tells Perl to C<eval> the given string and return an SV* result.
2272 Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
2275 SV* sv = newSVpv(p, 0);
2277 eval_sv(sv, G_SCALAR);
2284 if (croak_on_error && SvTRUE(ERRSV)) {
2286 Perl_croak(aTHX_ SvPVx(ERRSV, n_a));
2292 /* Require a module. */
2295 =head1 Embedding Functions
2297 =for apidoc p||require_pv
2299 Tells Perl to C<require> the file named by the string argument. It is
2300 analogous to the Perl code C<eval "require '$file'">. It's even
2301 implemented that way; consider using load_module instead.
2306 Perl_require_pv(pTHX_ const char *pv)
2310 PUSHSTACKi(PERLSI_REQUIRE);
2312 sv = sv_newmortal();
2313 sv_setpv(sv, "require '");
2316 eval_sv(sv, G_DISCARD);
2322 Perl_magicname(pTHX_ char *sym, char *name, I32 namlen)
2326 if ((gv = gv_fetchpv(sym,TRUE, SVt_PV)))
2327 sv_magic(GvSV(gv), (SV*)gv, PERL_MAGIC_sv, name, namlen);
2331 S_usage(pTHX_ char *name) /* XXX move this out into a module ? */
2333 /* This message really ought to be max 23 lines.
2334 * Removed -h because the user already knows that option. Others? */
2336 static char *usage_msg[] = {
2337 "-0[octal] specify record separator (\\0, if no argument)",
2338 "-a autosplit mode with -n or -p (splits $_ into @F)",
2339 "-C[number/list] enables the listed Unicode features",
2340 "-c check syntax only (runs BEGIN and CHECK blocks)",
2341 "-d[:debugger] run program under debugger",
2342 "-D[number/list] set debugging flags (argument is a bit mask or alphabets)",
2343 "-e program one line of program (several -e's allowed, omit programfile)",
2344 "-F/pattern/ split() pattern for -a switch (//'s are optional)",
2345 "-i[extension] edit <> files in place (makes backup if extension supplied)",
2346 "-Idirectory specify @INC/#include directory (several -I's allowed)",
2347 "-l[octal] enable line ending processing, specifies line terminator",
2348 "-[mM][-]module execute `use/no module...' before executing program",
2349 "-n assume 'while (<>) { ... }' loop around program",
2350 "-p assume loop like -n but print line also, like sed",
2351 "-P run program through C preprocessor before compilation",
2352 "-s enable rudimentary parsing for switches after programfile",
2353 "-S look for programfile using PATH environment variable",
2354 "-t enable tainting warnings",
2355 "-T enable tainting checks",
2356 "-u dump core after parsing program",
2357 "-U allow unsafe operations",
2358 "-v print version, subversion (includes VERY IMPORTANT perl info)",
2359 "-V[:variable] print configuration summary (or a single Config.pm variable)",
2360 "-w enable many useful warnings (RECOMMENDED)",
2361 "-W enable all warnings",
2362 "-x[directory] strip off text before #!perl line and perhaps cd to directory",
2363 "-X disable all warnings",
2367 char **p = usage_msg;
2369 PerlIO_printf(PerlIO_stdout(),
2370 "\nUsage: %s [switches] [--] [programfile] [arguments]",
2373 PerlIO_printf(PerlIO_stdout(), "\n %s", *p++);
2376 /* convert a string of -D options (or digits) into an int.
2377 * sets *s to point to the char after the options */
2381 Perl_get_debug_opts(pTHX_ char **s)
2385 /* if adding extra options, remember to update DEBUG_MASK */
2386 static char debopts[] = "psltocPmfrxu HXDSTRJvCAq";
2388 for (; isALNUM(**s); (*s)++) {
2389 char *d = strchr(debopts,**s);
2391 i |= 1 << (d - debopts);
2392 else if (ckWARN_d(WARN_DEBUGGING))
2393 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
2394 "invalid option -D%c\n", **s);
2399 for (; isALNUM(**s); (*s)++) ;
2402 if ((i & DEBUG_p_FLAG) && ckWARN_d(WARN_DEBUGGING))
2403 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
2404 "-Dp not implemented on this platform\n");
2410 /* This routine handles any switches that can be given during run */
2413 Perl_moreswitches(pTHX_ char *s)
2423 SvREFCNT_dec(PL_rs);
2424 if (s[1] == 'x' && s[2]) {
2428 for (s += 2, e = s; *e; e++);
2430 flags = PERL_SCAN_SILENT_ILLDIGIT;
2431 rschar = (U32)grok_hex(s, &numlen, &flags, NULL);
2432 if (s + numlen < e) {
2433 rschar = 0; /* Grandfather -0xFOO as -0 -xFOO. */
2437 PL_rs = newSVpvn("", 0);
2438 SvGROW(PL_rs, (STRLEN)(UNISKIP(rschar) + 1));
2439 tmps = (U8*)SvPVX(PL_rs);
2440 uvchr_to_utf8(tmps, rschar);
2441 SvCUR_set(PL_rs, UNISKIP(rschar));
2446 rschar = (U32)grok_oct(s, &numlen, &flags, NULL);
2447 if (rschar & ~((U8)~0))
2448 PL_rs = &PL_sv_undef;
2449 else if (!rschar && numlen >= 2)
2450 PL_rs = newSVpvn("", 0);
2452 char ch = (char)rschar;
2453 PL_rs = newSVpvn(&ch, 1);
2456 sv_setsv(get_sv("/", TRUE), PL_rs);
2461 PL_unicode = parse_unicode_opts(&s);
2466 while (*s && !isSPACE(*s)) ++s;
2468 PL_splitstr = savepv(PL_splitstr);
2481 /* The following permits -d:Mod to accepts arguments following an =
2482 in the fashion that -MSome::Mod does. */
2483 if (*s == ':' || *s == '=') {
2486 sv = newSVpv("use Devel::", 0);
2488 /* We now allow -d:Module=Foo,Bar */
2489 while(isALNUM(*s) || *s==':') ++s;
2491 sv_catpv(sv, start);
2493 sv_catpvn(sv, start, s-start);
2494 sv_catpv(sv, " split(/,/,q{");
2499 my_setenv("PERL5DB", SvPV(sv, PL_na));
2502 PL_perldb = PERLDB_ALL;
2511 PL_debug = get_debug_opts(&s) | DEBUG_TOP_FLAG;
2512 #else /* !DEBUGGING */
2513 if (ckWARN_d(WARN_DEBUGGING))
2514 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
2515 "Recompile perl with -DDEBUGGING to use -D switch\n");
2516 for (s++; isALNUM(*s); s++) ;
2522 usage(PL_origargv[0]);
2526 Safefree(PL_inplace);
2527 #if defined(__CYGWIN__) /* do backup extension automagically */
2528 if (*(s+1) == '\0') {
2529 PL_inplace = savepv(".bak");
2532 #endif /* __CYGWIN__ */
2533 PL_inplace = savepv(s+1);
2535 for (s = PL_inplace; *s && !isSPACE(*s); s++) ;
2538 if (*s == '-') /* Additional switches on #! line. */
2542 case 'I': /* -I handled both here and in parse_body() */
2545 while (*s && isSPACE(*s))
2550 /* ignore trailing spaces (possibly followed by other switches) */
2552 for (e = p; *e && !isSPACE(*e); e++) ;
2556 } while (*p && *p != '-');
2557 e = savepvn(s, e-s);
2558 incpush(e, TRUE, TRUE, FALSE);
2565 Perl_croak(aTHX_ "No directory specified for -I");
2571 SvREFCNT_dec(PL_ors_sv);
2576 PL_ors_sv = newSVpvn("\n",1);
2577 numlen = 3 + (*s == '0');
2578 *SvPVX(PL_ors_sv) = (char)grok_oct(s, &numlen, &flags, NULL);
2582 if (RsPARA(PL_rs)) {
2583 PL_ors_sv = newSVpvn("\n\n",2);
2586 PL_ors_sv = newSVsv(PL_rs);
2593 PL_preambleav = newAV();
2595 SV *sv = newSVpv("use assertions::activate split(/,/,q", 0);
2596 sv_catpvn(sv, "\0", 1); /* Use NUL as q//-delimiter. */
2598 sv_catpvn(sv, "\0)", 2);
2600 av_push(PL_preambleav, sv);
2603 av_push(PL_preambleav, newSVpvn("use assertions::activate",24));
2606 forbid_setid("-M"); /* XXX ? */
2609 forbid_setid("-m"); /* XXX ? */
2614 /* -M-foo == 'no foo' */
2615 if (*s == '-') { use = "no "; ++s; }
2616 sv = newSVpv(use,0);
2618 /* We allow -M'Module qw(Foo Bar)' */
2619 while(isALNUM(*s) || *s==':') ++s;
2621 sv_catpv(sv, start);
2622 if (*(start-1) == 'm') {
2624 Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
2625 sv_catpv( sv, " ()");
2629 Perl_croak(aTHX_ "Module name required with -%c option",
2631 sv_catpvn(sv, start, s-start);
2632 sv_catpv(sv, " split(/,/,q");
2633 sv_catpvn(sv, "\0)", 1); /* Use NUL as q//-delimiter. */
2635 sv_catpvn(sv, "\0)", 2);
2639 PL_preambleav = newAV();
2640 av_push(PL_preambleav, sv);
2643 Perl_croak(aTHX_ "No space allowed after -%c", *(s-1));
2655 PL_doswitches = TRUE;
2669 #ifdef MACOS_TRADITIONAL
2670 Perl_croak(aTHX_ "Believe me, you don't want to use \"-u\" on a Macintosh");
2672 PL_do_undump = TRUE;
2681 PerlIO_printf(PerlIO_stdout(),
2682 Perl_form(aTHX_ "\nThis is perl, v%"VDf" built for %s",
2683 PL_patchlevel, ARCHNAME));
2685 /* Adjust verbose output as in the perl that ships with the DG/UX OS from EMC */
2686 PerlIO_printf(PerlIO_stdout(),
2687 Perl_form(aTHX_ "\nThis is perl, version %vd\n", PL_patchlevel));
2688 PerlIO_printf(PerlIO_stdout(),
2689 Perl_form(aTHX_ " built under %s at %s %s\n",
2690 OSNAME, __DATE__, __TIME__));
2691 PerlIO_printf(PerlIO_stdout(),
2692 Perl_form(aTHX_ " OS Specific Release: %s\n",
2696 #if defined(LOCAL_PATCH_COUNT)
2697 if (LOCAL_PATCH_COUNT > 0)
2698 PerlIO_printf(PerlIO_stdout(),
2699 "\n(with %d registered patch%s, "
2700 "see perl -V for more detail)",
2701 (int)LOCAL_PATCH_COUNT,
2702 (LOCAL_PATCH_COUNT!=1) ? "es" : "");
2705 PerlIO_printf(PerlIO_stdout(),
2706 "\n\nCopyright 1987-2004, Larry Wall\n");
2707 #ifdef MACOS_TRADITIONAL
2708 PerlIO_printf(PerlIO_stdout(),
2709 "\nMac OS port Copyright 1991-2002, Matthias Neeracher;\n"
2710 "maintained by Chris Nandor\n");
2713 PerlIO_printf(PerlIO_stdout(),
2714 "\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
2717 PerlIO_printf(PerlIO_stdout(),
2718 "djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n"
2719 "djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
2722 PerlIO_printf(PerlIO_stdout(),
2723 "\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
2724 "Version 5 port Copyright (c) 1994-2002, Andreas Kaiser, Ilya Zakharevich\n");
2727 PerlIO_printf(PerlIO_stdout(),
2728 "atariST series port, ++jrb bammi@cadence.com\n");
2731 PerlIO_printf(PerlIO_stdout(),
2732 "BeOS port Copyright Tom Spindler, 1997-1999\n");
2735 PerlIO_printf(PerlIO_stdout(),
2736 "MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-2003\n");
2739 PerlIO_printf(PerlIO_stdout(),
2740 "MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
2743 PerlIO_printf(PerlIO_stdout(),
2744 "Stratus VOS port by Paul.Green@stratus.com, 1997-2002\n");
2747 PerlIO_printf(PerlIO_stdout(),
2748 "VM/ESA port by Neale Ferguson, 1998-1999\n");
2751 PerlIO_printf(PerlIO_stdout(),
2752 "BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
2755 PerlIO_printf(PerlIO_stdout(),
2756 "MiNT port by Guido Flohr, 1997-1999\n");
2759 PerlIO_printf(PerlIO_stdout(),
2760 "EPOC port by Olaf Flebbe, 1999-2002\n");
2763 PerlIO_printf(PerlIO_stdout(),"WINCE port by Rainer Keuchel, 2001-2002\n");
2764 PerlIO_printf(PerlIO_stdout(),"Built on " __DATE__ " " __TIME__ "\n\n");
2767 #ifdef BINARY_BUILD_NOTICE
2768 BINARY_BUILD_NOTICE;
2770 PerlIO_printf(PerlIO_stdout(),
2772 Perl may be copied only under the terms of either the Artistic License or the\n\
2773 GNU General Public License, which may be found in the Perl 5 source kit.\n\n\
2774 Complete documentation for Perl, including FAQ lists, should be found on\n\
2775 this system using `man perl' or `perldoc perl'. If you have access to the\n\
2776 Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n");
2779 if (! (PL_dowarn & G_WARN_ALL_MASK))
2780 PL_dowarn |= G_WARN_ON;
2784 PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
2785 if (!specialWARN(PL_compiling.cop_warnings))
2786 SvREFCNT_dec(PL_compiling.cop_warnings);
2787 PL_compiling.cop_warnings = pWARN_ALL ;
2791 PL_dowarn = G_WARN_ALL_OFF;
2792 if (!specialWARN(PL_compiling.cop_warnings))
2793 SvREFCNT_dec(PL_compiling.cop_warnings);
2794 PL_compiling.cop_warnings = pWARN_NONE ;
2799 if (s[1] == '-') /* Additional switches on #! line. */
2804 #if defined(WIN32) || !defined(PERL_STRICT_CR)
2810 #ifdef ALTERNATE_SHEBANG
2811 case 'S': /* OS/2 needs -S on "extproc" line. */
2819 Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
2824 /* compliments of Tom Christiansen */
2826 /* unexec() can be found in the Gnu emacs distribution */
2827 /* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
2830 Perl_my_unexec(pTHX)
2838 prog = newSVpv(BIN_EXP, 0);
2839 sv_catpv(prog, "/perl");
2840 file = newSVpv(PL_origfilename, 0);
2841 sv_catpv(file, ".perldump");
2843 unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
2844 /* unexec prints msg to stderr in case of failure */
2845 PerlProc_exit(status);
2848 # include <lib$routines.h>
2849 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
2851 ABORT(); /* for use with undump */
2856 /* initialize curinterp */
2862 # define PERLVAR(var,type)
2863 # define PERLVARA(var,n,type)
2864 # if defined(PERL_IMPLICIT_CONTEXT)
2865 # if defined(USE_5005THREADS)
2866 # define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
2867 # define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
2868 # else /* !USE_5005THREADS */
2869 # define PERLVARI(var,type,init) aTHX->var = init;
2870 # define PERLVARIC(var,type,init) aTHX->var = init;
2871 # endif /* USE_5005THREADS */
2873 # define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
2874 # define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
2876 # include "intrpvar.h"
2877 # ifndef USE_5005THREADS
2878 # include "thrdvar.h"
2885 # define PERLVAR(var,type)
2886 # define PERLVARA(var,n,type)
2887 # define PERLVARI(var,type,init) PL_##var = init;
2888 # define PERLVARIC(var,type,init) PL_##var = init;
2889 # include "intrpvar.h"
2890 # ifndef USE_5005THREADS
2891 # include "thrdvar.h"
2902 S_init_main_stash(pTHX)
2906 PL_curstash = PL_defstash = newHV();
2907 PL_curstname = newSVpvn("main",4);
2908 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
2909 SvREFCNT_dec(GvHV(gv));
2910 GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash);
2912 HvNAME(PL_defstash) = savepv("main");
2913 PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
2914 GvMULTI_on(PL_incgv);
2915 PL_hintgv = gv_fetchpv("\010",TRUE, SVt_PV); /* ^H */
2916 GvMULTI_on(PL_hintgv);
2917 PL_defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
2918 PL_errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
2919 GvMULTI_on(PL_errgv);
2920 PL_replgv = gv_fetchpv("\022", TRUE, SVt_PV); /* ^R */
2921 GvMULTI_on(PL_replgv);
2922 (void)Perl_form(aTHX_ "%240s",""); /* Preallocate temp - for immediate signals. */
2923 sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
2924 sv_setpvn(ERRSV, "", 0);
2925 PL_curstash = PL_defstash;
2926 CopSTASH_set(&PL_compiling, PL_defstash);
2927 PL_debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
2928 PL_globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
2929 /* We must init $/ before switches are processed. */
2930 sv_setpvn(get_sv("/", TRUE), "\n", 1);
2933 /* PSz 18 Nov 03 fdscript now global but do not change prototype */
2935 S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv)
2940 char *cpp_discard_flag;
2948 PL_origfilename = savepv("-e");
2951 /* if find_script() returns, it returns a malloc()-ed value */
2952 PL_origfilename = scriptname = find_script(scriptname, dosearch, NULL, 1);
2954 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
2955 char *s = scriptname + 8;
2956 PL_fdscript = atoi(s);
2961 * Tell apart "normal" usage of fdscript, e.g.
2962 * with bash on FreeBSD:
2963 * perl <( echo '#!perl -DA'; echo 'print "$0\n"')
2964 * from usage in suidperl.
2965 * Does any "normal" usage leave garbage after the number???
2966 * Is it a mistake to use a similar /dev/fd/ construct for
2971 * Be supersafe and do some sanity-checks.
2972 * Still, can we be sure we got the right thing?
2975 Perl_croak(aTHX_ "Wrong syntax (suid) fd script name \"%s\"\n", s);
2978 Perl_croak(aTHX_ "Missing (suid) fd script name\n");
2980 scriptname = savepv(s + 1);
2981 Safefree(PL_origfilename);
2982 PL_origfilename = scriptname;
2987 CopFILE_free(PL_curcop);
2988 CopFILE_set(PL_curcop, PL_origfilename);
2989 if (strEQ(PL_origfilename,"-"))
2991 if (PL_fdscript >= 0) {
2992 PL_rsfp = PerlIO_fdopen(PL_fdscript,PERL_SCRIPT_MODE);
2993 # if defined(HAS_FCNTL) && defined(F_SETFD)
2995 /* ensure close-on-exec */
2996 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);
3001 Perl_croak(aTHX_ "suidperl needs fd script\n");
3003 * Do not open (or do other fancy stuff) while setuid.
3004 * Perl does the open, and hands script to suidperl on a fd;
3005 * suidperl only does some checks, sets up UIDs and re-execs
3006 * perl with that fd as it has always done.
3009 if (PL_suidscript != 1) {
3010 Perl_croak(aTHX_ "suidperl needs (suid) fd script\n");
3013 else if (PL_preprocess) {
3014 char *cpp_cfg = CPPSTDIN;
3015 SV *cpp = newSVpvn("",0);
3016 SV *cmd = NEWSV(0,0);
3018 if (cpp_cfg[0] == 0) /* PERL_MICRO? */
3019 Perl_croak(aTHX_ "Can't run with cpp -P with CPPSTDIN undefined");
3020 if (strEQ(cpp_cfg, "cppstdin"))
3021 Perl_sv_catpvf(aTHX_ cpp, "%s/", BIN_EXP);
3022 sv_catpv(cpp, cpp_cfg);
3025 sv_catpvn(sv, "-I", 2);
3026 sv_catpv(sv,PRIVLIB_EXP);
3029 DEBUG_P(PerlIO_printf(Perl_debug_log,
3030 "PL_preprocess: scriptname=\"%s\", cpp=\"%s\", sv=\"%s\", CPPMINUS=\"%s\"\n",
3031 scriptname, SvPVX (cpp), SvPVX (sv), CPPMINUS));
3033 # if defined(MSDOS) || defined(WIN32) || defined(VMS)
3040 cpp_discard_flag = "";
3042 cpp_discard_flag = "-C";
3046 perl = os2_execname(aTHX);
3048 perl = PL_origargv[0];
3052 /* This strips off Perl comments which might interfere with
3053 the C pre-processor, including #!. #line directives are
3054 deliberately stripped to avoid confusion with Perl's version
3055 of #line. FWP played some golf with it so it will fit
3056 into VMS's 255 character buffer.
3059 code = "(1../^#!.*perl/i)|/^\\s*#(?!\\s*((ifn?|un)def|(el|end)?if|define|include|else|error|pragma)\\b)/||!($|=1)||print";
3061 code = "/^\\s*#(?!\\s*((ifn?|un)def|(el|end)?if|define|include|else|error|pragma)\\b)/||!($|=1)||print";
3063 Perl_sv_setpvf(aTHX_ cmd, "\
3064 %s -ne%s%s%s %s | %"SVf" %s %"SVf" %s",
3065 perl, quote, code, quote, scriptname, cpp,
3066 cpp_discard_flag, sv, CPPMINUS);
3068 PL_doextract = FALSE;
3070 DEBUG_P(PerlIO_printf(Perl_debug_log,
3071 "PL_preprocess: cmd=\"%s\"\n",
3074 PL_rsfp = PerlProc_popen(SvPVX(cmd), "r");
3078 else if (!*scriptname) {
3079 forbid_setid("program input from stdin");
3080 PL_rsfp = PerlIO_stdin();
3083 PL_rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
3084 # if defined(HAS_FCNTL) && defined(F_SETFD)
3086 /* ensure close-on-exec */
3087 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);
3090 #endif /* IAMSUID */
3092 /* PSz 16 Sep 03 Keep neat error message */
3093 Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
3094 CopFILE(PL_curcop), Strerror(errno));
3099 * I_SYSSTATVFS HAS_FSTATVFS
3101 * I_STATFS HAS_FSTATFS HAS_GETFSSTAT
3102 * I_MNTENT HAS_GETMNTENT HAS_HASMNTOPT
3103 * here so that metaconfig picks them up. */
3107 S_fd_on_nosuid_fs(pTHX_ int fd)
3110 * We used to do this as "plain" user (after swapping UIDs with setreuid);
3111 * but is needed also on machines without setreuid.
3112 * Seems safe enough to run as root.
3114 int check_okay = 0; /* able to do all the required sys/libcalls */
3115 int on_nosuid = 0; /* the fd is on a nosuid fs */
3117 * Need to check noexec also: nosuid might not be set, the average
3118 * sysadmin would say that nosuid is irrelevant once he sets noexec.
3120 int on_noexec = 0; /* the fd is on a noexec fs */
3123 * Preferred order: fstatvfs(), fstatfs(), ustat()+getmnt(), getmntent().
3124 * fstatvfs() is UNIX98.
3125 * fstatfs() is 4.3 BSD.
3126 * ustat()+getmnt() is pre-4.3 BSD.
3127 * getmntent() is O(number-of-mounted-filesystems) and can hang on
3128 * an irrelevant filesystem while trying to reach the right one.
3131 #undef FD_ON_NOSUID_CHECK_OKAY /* found the syscalls to do the check? */
3133 # if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
3134 defined(HAS_FSTATVFS)
3135 # define FD_ON_NOSUID_CHECK_OKAY
3136 struct statvfs stfs;
3138 check_okay = fstatvfs(fd, &stfs) == 0;
3139 on_nosuid = check_okay && (stfs.f_flag & ST_NOSUID);
3141 /* ST_NOEXEC certainly absent on AIX 5.1, and doesn't seem to be documented
3142 on platforms where it is present. */
3143 on_noexec = check_okay && (stfs.f_flag & ST_NOEXEC);
3145 # endif /* fstatvfs */
3147 # if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
3148 defined(PERL_MOUNT_NOSUID) && \
3149 defined(PERL_MOUNT_NOEXEC) && \
3150 defined(HAS_FSTATFS) && \
3151 defined(HAS_STRUCT_STATFS) && \
3152 defined(HAS_STRUCT_STATFS_F_FLAGS)
3153 # define FD_ON_NOSUID_CHECK_OKAY
3156 check_okay = fstatfs(fd, &stfs) == 0;
3157 on_nosuid = check_okay && (stfs.f_flags & PERL_MOUNT_NOSUID);
3158 on_noexec = check_okay && (stfs.f_flags & PERL_MOUNT_NOEXEC);
3159 # endif /* fstatfs */
3161 # if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
3162 defined(PERL_MOUNT_NOSUID) && \
3163 defined(PERL_MOUNT_NOEXEC) && \
3164 defined(HAS_FSTAT) && \
3165 defined(HAS_USTAT) && \
3166 defined(HAS_GETMNT) && \
3167 defined(HAS_STRUCT_FS_DATA) && \
3169 # define FD_ON_NOSUID_CHECK_OKAY
3172 if (fstat(fd, &fdst) == 0) {
3174 if (ustat(fdst.st_dev, &us) == 0) {
3176 /* NOSTAT_ONE here because we're not examining fields which
3177 * vary between that case and STAT_ONE. */
3178 if (getmnt((int*)0, &fsd, (int)0, NOSTAT_ONE, us.f_fname) == 0) {
3179 size_t cmplen = sizeof(us.f_fname);
3180 if (sizeof(fsd.fd_req.path) < cmplen)
3181 cmplen = sizeof(fsd.fd_req.path);
3182 if (strnEQ(fsd.fd_req.path, us.f_fname, cmplen) &&
3183 fdst.st_dev == fsd.fd_req.dev) {
3185 on_nosuid = fsd.fd_req.flags & PERL_MOUNT_NOSUID;
3186 on_noexec = fsd.fd_req.flags & PERL_MOUNT_NOEXEC;
3192 # endif /* fstat+ustat+getmnt */
3194 # if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
3195 defined(HAS_GETMNTENT) && \
3196 defined(HAS_HASMNTOPT) && \
3197 defined(MNTOPT_NOSUID) && \
3198 defined(MNTOPT_NOEXEC)
3199 # define FD_ON_NOSUID_CHECK_OKAY
3200 FILE *mtab = fopen("/etc/mtab", "r");
3201 struct mntent *entry;
3204 if (mtab && (fstat(fd, &stb) == 0)) {
3205 while (entry = getmntent(mtab)) {
3206 if (stat(entry->mnt_dir, &fsb) == 0
3207 && fsb.st_dev == stb.st_dev)
3209 /* found the filesystem */
3211 if (hasmntopt(entry, MNTOPT_NOSUID))
3213 if (hasmntopt(entry, MNTOPT_NOEXEC))
3216 } /* A single fs may well fail its stat(). */
3221 # endif /* getmntent+hasmntopt */
3224 Perl_croak(aTHX_ "Can't check filesystem of script \"%s\" for nosuid/noexec", PL_origfilename);
3226 Perl_croak(aTHX_ "Setuid script \"%s\" on nosuid filesystem", PL_origfilename);
3228 Perl_croak(aTHX_ "Setuid script \"%s\" on noexec filesystem", PL_origfilename);
3229 return ((!check_okay) || on_nosuid || on_noexec);
3231 #endif /* IAMSUID */
3234 S_validate_suid(pTHX_ char *validarg, char *scriptname)
3238 #endif /* IAMSUID */
3240 /* do we need to emulate setuid on scripts? */
3242 /* This code is for those BSD systems that have setuid #! scripts disabled
3243 * in the kernel because of a security problem. Merely defining DOSUID
3244 * in perl will not fix that problem, but if you have disabled setuid
3245 * scripts in the kernel, this will attempt to emulate setuid and setgid
3246 * on scripts that have those now-otherwise-useless bits set. The setuid
3247 * root version must be called suidperl or sperlN.NNN. If regular perl
3248 * discovers that it has opened a setuid script, it calls suidperl with
3249 * the same argv that it had. If suidperl finds that the script it has
3250 * just opened is NOT setuid root, it sets the effective uid back to the
3251 * uid. We don't just make perl setuid root because that loses the
3252 * effective uid we had before invoking perl, if it was different from the
3255 * Description/comments above do not match current workings:
3256 * suidperl must be hardlinked to sperlN.NNN (that is what we exec);
3257 * suidperl called with script open and name changed to /dev/fd/N/X;
3258 * suidperl croaks if script is not setuid;
3259 * making perl setuid would be a huge security risk (and yes, that
3260 * would lose any euid we might have had).
3262 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
3263 * be defined in suidperl only. suidperl must be setuid root. The
3264 * Configure script will set this up for you if you want it.
3270 if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0) /* normal stat is insecure */
3271 Perl_croak(aTHX_ "Can't stat script \"%s\"",PL_origfilename);
3272 if (PL_statbuf.st_mode & (S_ISUID|S_ISGID)) {
3277 if (PL_fdscript < 0 || PL_suidscript != 1)
3278 Perl_croak(aTHX_ "Need (suid) fdscript in suidperl\n"); /* We already checked this */
3280 * Since the script is opened by perl, not suidperl, some of these
3281 * checks are superfluous. Leaving them in probably does not lower
3285 * Do checks even for systems with no HAS_SETREUID.
3286 * We used to swap, then re-swap UIDs with
3288 if (setreuid(PL_euid,PL_uid) < 0
3289 || PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid)
3290 Perl_croak(aTHX_ "Can't swap uid and euid");
3293 if (setreuid(PL_uid,PL_euid) < 0
3294 || PerlProc_getuid() != PL_uid || PerlProc_geteuid() != PL_euid)
3295 Perl_croak(aTHX_ "Can't reswap uid and euid");
3299 /* On this access check to make sure the directories are readable,
3300 * there is actually a small window that the user could use to make
3301 * filename point to an accessible directory. So there is a faint
3302 * chance that someone could execute a setuid script down in a
3303 * non-accessible directory. I don't know what to do about that.
3304 * But I don't think it's too important. The manual lies when
3305 * it says access() is useful in setuid programs.
3307 * So, access() is pretty useless... but not harmful... do anyway.
3309 if (PerlLIO_access(CopFILE(PL_curcop),1)) { /*double check*/
3310 Perl_croak(aTHX_ "Can't access() script\n");
3313 /* If we can swap euid and uid, then we can determine access rights
3314 * with a simple stat of the file, and then compare device and
3315 * inode to make sure we did stat() on the same file we opened.
3316 * Then we just have to make sure he or she can execute it.
3319 * As the script is opened by perl, not suidperl, we do not need to
3320 * care much about access rights.
3322 * The 'script changed' check is needed, or we can get lied to
3323 * about $0 with e.g.
3324 * suidperl /dev/fd/4//bin/x 4<setuidscript
3325 * Without HAS_SETREUID, is it safe to stat() as root?
3327 * Are there any operating systems that pass /dev/fd/xxx for setuid
3328 * scripts, as suggested/described in perlsec(1)? Surely they do not
3329 * pass the script name as we do, so the "script changed" test would
3330 * fail for them... but we never get here with
3331 * SETUID_SCRIPTS_ARE_SECURE_NOW defined.
3333 * This is one place where we must "lie" about return status: not
3334 * say if the stat() failed. We are doing this as root, and could
3335 * be tricked into reporting existence or not of files that the
3336 * "plain" user cannot even see.
3340 if (PerlLIO_stat(CopFILE(PL_curcop),&tmpstatbuf) < 0 ||
3341 tmpstatbuf.st_dev != PL_statbuf.st_dev ||
3342 tmpstatbuf.st_ino != PL_statbuf.st_ino) {
3343 Perl_croak(aTHX_ "Setuid script changed\n");
3347 if (!cando(S_IXUSR,FALSE,&PL_statbuf)) /* can real uid exec? */
3348 Perl_croak(aTHX_ "Real UID cannot exec script\n");
3351 * We used to do this check as the "plain" user (after swapping
3352 * UIDs). But the check for nosuid and noexec filesystem is needed,
3353 * and should be done even without HAS_SETREUID. (Maybe those
3354 * operating systems do not have such mount options anyway...)
3355 * Seems safe enough to do as root.
3357 #if !defined(NO_NOSUID_CHECK)
3358 if (fd_on_nosuid_fs(PerlIO_fileno(PL_rsfp))) {
3359 Perl_croak(aTHX_ "Setuid script on nosuid or noexec filesystem\n");
3362 #endif /* IAMSUID */
3364 if (!S_ISREG(PL_statbuf.st_mode)) {
3365 Perl_croak(aTHX_ "Setuid script not plain file\n");
3367 if (PL_statbuf.st_mode & S_IWOTH)
3368 Perl_croak(aTHX_ "Setuid/gid script is writable by world");
3369 PL_doswitches = FALSE; /* -s is insecure in suid */
3370 /* PSz 13 Nov 03 But -s was caught elsewhere ... so unsetting it here is useless(?!) */
3371 CopLINE_inc(PL_curcop);
3372 if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch ||
3373 strnNE(SvPV(PL_linestr,n_a),"#!",2) ) /* required even on Sys V */
3374 Perl_croak(aTHX_ "No #! line");
3375 s = SvPV(PL_linestr,n_a)+2;
3377 /* Sanity check on line length */
3378 if (strlen(s) < 1 || strlen(s) > 4000)
3379 Perl_croak(aTHX_ "Very long #! line");
3380 /* Allow more than a single space after #! */
3381 while (isSPACE(*s)) s++;
3382 /* Sanity check on buffer end */
3383 while ((*s) && !isSPACE(*s)) s++;
3384 for (s2 = s; (s2 > SvPV(PL_linestr,n_a)+2 &&
3385 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
3386 /* Sanity check on buffer start */
3387 if ( (s2-4 < SvPV(PL_linestr,n_a)+2 || strnNE(s2-4,"perl",4)) &&
3388 (s-9 < SvPV(PL_linestr,n_a)+2 || strnNE(s-9,"perl",4)) )
3389 Perl_croak(aTHX_ "Not a perl script");
3390 while (*s == ' ' || *s == '\t') s++;
3392 * #! arg must be what we saw above. They can invoke it by
3393 * mentioning suidperl explicitly, but they may not add any strange
3394 * arguments beyond what #! says if they do invoke suidperl that way.
3397 * The way validarg was set up, we rely on the kernel to start
3398 * scripts with argv[1] set to contain all #! line switches (the
3402 * Check that we got all the arguments listed in the #! line (not
3403 * just that there are no extraneous arguments). Might not matter
3404 * much, as switches from #! line seem to be acted upon (also), and
3405 * so may be checked and trapped in perl. But, security checks must
3406 * be done in suidperl and not deferred to perl. Note that suidperl
3407 * does not get around to parsing (and checking) the switches on
3408 * the #! line (but execs perl sooner).
3409 * Allow (require) a trailing newline (which may be of two
3410 * characters on some architectures?) (but no other trailing
3413 len = strlen(validarg);
3414 if (strEQ(validarg," PHOOEY ") ||
3415 strnNE(s,validarg,len) || !isSPACE(s[len]) ||
3416 !(strlen(s) == len+1 || (strlen(s) == len+2 && isSPACE(s[len+1]))))
3417 Perl_croak(aTHX_ "Args must match #! line");
3420 if (PL_fdscript < 0 &&
3421 PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) &&
3422 PL_euid == PL_statbuf.st_uid)
3424 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
3425 FIX YOUR KERNEL, OR PUT A C WRAPPER AROUND THIS SCRIPT!\n");
3426 #endif /* IAMSUID */
3428 if (PL_fdscript < 0 &&
3429 PL_euid) { /* oops, we're not the setuid root perl */
3431 * When root runs a setuid script, we do not go through the same
3432 * steps of execing sperl and then perl with fd scripts, but
3433 * simply set up UIDs within the same perl invocation; so do
3434 * not have the same checks (on options, whatever) that we have
3435 * for plain users. No problem really: would have to be a script
3436 * that does not actually work for plain users; and if root is
3437 * foolish and can be persuaded to run such an unsafe script, he
3438 * might run also non-setuid ones, and deserves what he gets.
3440 * Or, we might drop the PL_euid check above (and rely just on
3441 * PL_fdscript to avoid loops), and do the execs
3447 * Pass fd script to suidperl.
3448 * Exec suidperl, substituting fd script for scriptname.
3449 * Pass script name as "subdir" of fd, which perl will grok;
3450 * in fact will use that to distinguish this from "normal"
3451 * usage, see comments above.
3453 PerlIO_rewind(PL_rsfp);
3454 PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0); /* just in case rewind didn't */
3455 /* PSz 27 Feb 04 Sanity checks on scriptname */
3456 if ((!scriptname) || (!*scriptname) ) {
3457 Perl_croak(aTHX_ "No setuid script name\n");
3459 if (*scriptname == '-') {
3460 Perl_croak(aTHX_ "Setuid script name may not begin with dash\n");
3461 /* Or we might confuse it with an option when replacing
3462 * name in argument list, below (though we do pointer, not
3463 * string, comparisons).
3466 for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ;
3467 if (!PL_origargv[which]) {
3468 Perl_croak(aTHX_ "Can't change argv to have fd script\n");
3470 PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s",
3471 PerlIO_fileno(PL_rsfp), PL_origargv[which]));
3472 #if defined(HAS_FCNTL) && defined(F_SETFD)
3473 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0); /* ensure no close-on-exec */
3476 PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT, BIN_EXP,
3477 (int)PERL_REVISION, (int)PERL_VERSION,
3478 (int)PERL_SUBVERSION), PL_origargv);
3480 #endif /* IAMSUID */
3481 Perl_croak(aTHX_ "Can't do setuid (cannot exec sperl)\n");
3484 if (PL_statbuf.st_mode & S_ISGID && PL_statbuf.st_gid != PL_egid) {
3486 * This seems back to front: we try HAS_SETEGID first; if not available
3487 * then try HAS_SETREGID; as a last chance we try HAS_SETRESGID. May be OK
3488 * in the sense that we only want to set EGID; but are there any machines
3489 * with either of the latter, but not the former? Same with UID, later.
3492 (void)setegid(PL_statbuf.st_gid);
3495 (void)setregid((Gid_t)-1,PL_statbuf.st_gid);
3497 #ifdef HAS_SETRESGID
3498 (void)setresgid((Gid_t)-1,PL_statbuf.st_gid,(Gid_t)-1);
3500 PerlProc_setgid(PL_statbuf.st_gid);
3504 if (PerlProc_getegid() != PL_statbuf.st_gid)
3505 Perl_croak(aTHX_ "Can't do setegid!\n");
3507 if (PL_statbuf.st_mode & S_ISUID) {
3508 if (PL_statbuf.st_uid != PL_euid)
3510 (void)seteuid(PL_statbuf.st_uid); /* all that for this */
3513 (void)setreuid((Uid_t)-1,PL_statbuf.st_uid);
3515 #ifdef HAS_SETRESUID
3516 (void)setresuid((Uid_t)-1,PL_statbuf.st_uid,(Uid_t)-1);
3518 PerlProc_setuid(PL_statbuf.st_uid);
3522 if (PerlProc_geteuid() != PL_statbuf.st_uid)
3523 Perl_croak(aTHX_ "Can't do seteuid!\n");
3525 else if (PL_uid) { /* oops, mustn't run as root */
3527 (void)seteuid((Uid_t)PL_uid);
3530 (void)setreuid((Uid_t)-1,(Uid_t)PL_uid);
3532 #ifdef HAS_SETRESUID
3533 (void)setresuid((Uid_t)-1,(Uid_t)PL_uid,(Uid_t)-1);
3535 PerlProc_setuid((Uid_t)PL_uid);
3539 if (PerlProc_geteuid() != PL_uid)
3540 Perl_croak(aTHX_ "Can't do seteuid!\n");
3543 if (!cando(S_IXUSR,TRUE,&PL_statbuf))
3544 Perl_croak(aTHX_ "Effective UID cannot exec script\n"); /* they can't do this */
3547 else if (PL_preprocess) /* PSz 13 Nov 03 Caught elsewhere, useless(?!) here */
3548 Perl_croak(aTHX_ "-P not allowed for setuid/setgid script\n");
3549 else if (PL_fdscript < 0 || PL_suidscript != 1)
3550 /* PSz 13 Nov 03 Caught elsewhere, useless(?!) here */
3551 Perl_croak(aTHX_ "(suid) fdscript needed in suidperl\n");
3553 /* PSz 16 Sep 03 Keep neat error message */
3554 Perl_croak(aTHX_ "Script is not setuid/setgid in suidperl\n");
3557 /* We absolutely must clear out any saved ids here, so we */
3558 /* exec the real perl, substituting fd script for scriptname. */
3559 /* (We pass script name as "subdir" of fd, which perl will grok.) */
3561 * It might be thought that using setresgid and/or setresuid (changed to
3562 * set the saved IDs) above might obviate the need to exec, and we could
3563 * go on to "do the perl thing".
3565 * Is there such a thing as "saved GID", and is that set for setuid (but
3566 * not setgid) execution like suidperl? Without exec, it would not be
3567 * cleared for setuid (but not setgid) scripts (or might need a dummy
3570 * We need suidperl to do the exact same argument checking that perl
3571 * does. Thus it cannot be very small; while it could be significantly
3572 * smaller, it is safer (simpler?) to make it essentially the same
3573 * binary as perl (but they are not identical). - Maybe could defer that
3574 * check to the invoked perl, and suidperl be a tiny wrapper instead;
3575 * but prefer to do thorough checks in suidperl itself. Such deferral
3576 * would make suidperl security rely on perl, a design no-no.
3578 * Setuid things should be short and simple, thus easy to understand and
3579 * verify. They should do their "own thing", without influence by
3580 * attackers. It may help if their internal execution flow is fixed,
3581 * regardless of platform: it may be best to exec anyway.
3583 * Suidperl should at least be conceptually simple: a wrapper only,
3584 * never to do any real perl. Maybe we should put
3586 * Perl_croak(aTHX_ "Suidperl should never do real perl\n");
3588 * into the perly bits.
3590 PerlIO_rewind(PL_rsfp);
3591 PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0); /* just in case rewind didn't */
3593 * Keep original arguments: suidperl already has fd script.
3595 /* for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ; */
3596 /* if (!PL_origargv[which]) { */
3597 /* errno = EPERM; */
3598 /* Perl_croak(aTHX_ "Permission denied\n"); */
3600 /* PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s", */
3601 /* PerlIO_fileno(PL_rsfp), PL_origargv[which])); */
3602 #if defined(HAS_FCNTL) && defined(F_SETFD)
3603 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0); /* ensure no close-on-exec */
3606 PerlProc_execv(Perl_form(aTHX_ "%s/perl"PERL_FS_VER_FMT, BIN_EXP,
3607 (int)PERL_REVISION, (int)PERL_VERSION,
3608 (int)PERL_SUBVERSION), PL_origargv);/* try again */
3610 Perl_croak(aTHX_ "Can't do setuid (suidperl cannot exec perl)\n");
3611 #endif /* IAMSUID */
3613 if (PL_euid != PL_uid || PL_egid != PL_gid) { /* (suidperl doesn't exist, in fact) */
3614 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
3615 PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf); /* may be either wrapped or real suid */
3616 if ((PL_euid != PL_uid && PL_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
3618 (PL_egid != PL_gid && PL_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
3621 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
3622 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
3623 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
3624 /* not set-id, must be wrapped */
3630 S_find_beginning(pTHX)
3632 register char *s, *s2;
3633 #ifdef MACOS_TRADITIONAL
3637 /* skip forward in input to the real script? */
3640 #ifdef MACOS_TRADITIONAL
3641 /* Since the Mac OS does not honor #! arguments for us, we do it ourselves */
3643 while (PL_doextract || gMacPerl_AlwaysExtract) {
3644 if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
3645 if (!gMacPerl_AlwaysExtract)
3646 Perl_croak(aTHX_ "No Perl script found in input\n");
3648 if (PL_doextract) /* require explicit override ? */
3649 if (!OverrideExtract(PL_origfilename))
3650 Perl_croak(aTHX_ "User aborted script\n");
3652 PL_doextract = FALSE;
3654 /* Pater peccavi, file does not have #! */
3655 PerlIO_rewind(PL_rsfp);
3660 while (PL_doextract) {
3661 if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch)
3662 Perl_croak(aTHX_ "No Perl script found in input\n");
3665 if (*s == '#' && s[1] == '!' && ((s = instr(s,"perl")) || (s = instr(s2,"PERL")))) {
3666 PerlIO_ungetc(PL_rsfp, '\n'); /* to keep line count right */
3667 PL_doextract = FALSE;
3668 while (*s && !(isSPACE (*s) || *s == '#')) s++;
3670 while (*s == ' ' || *s == '\t') s++;
3672 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
3673 if (strnEQ(s2-4,"perl",4))
3675 while ((s = moreswitches(s)))
3678 #ifdef MACOS_TRADITIONAL
3679 /* We are always searching for the #!perl line in MacPerl,
3680 * so if we find it, still keep the line count correct
3681 * by counting lines we already skipped over
3683 for (; maclines > 0 ; maclines--)
3684 PerlIO_ungetc(PL_rsfp, '\n');
3688 /* gMacPerl_AlwaysExtract is false in MPW tool */
3689 } else if (gMacPerl_AlwaysExtract) {
3700 PL_uid = PerlProc_getuid();
3701 PL_euid = PerlProc_geteuid();
3702 PL_gid = PerlProc_getgid();
3703 PL_egid = PerlProc_getegid();
3705 PL_uid |= PL_gid << 16;
3706 PL_euid |= PL_egid << 16;
3708 /* Should not happen: */
3709 CHECK_MALLOC_TAINT(PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
3710 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
3713 * Should go by suidscript, not uid!=euid: why disallow
3714 * system("ls") in scripts run from setuid things?
3715 * Or, is this run before we check arguments and set suidscript?
3716 * What about SETUID_SCRIPTS_ARE_SECURE_NOW: could we use fdscript then?
3717 * (We never have suidscript, can we be sure to have fdscript?)
3718 * Or must then go by UID checks? See comments in forbid_setid also.
3722 /* This is used very early in the lifetime of the program,
3723 * before even the options are parsed, so PL_tainting has
3724 * not been initialized properly. */
3726 Perl_doing_taint(int argc, char *argv[], char *envp[])
3728 #ifndef PERL_IMPLICIT_SYS
3729 /* If we have PERL_IMPLICIT_SYS we can't call getuid() et alia
3730 * before we have an interpreter-- and the whole point of this
3731 * function is to be called at such an early stage. If you are on
3732 * a system with PERL_IMPLICIT_SYS but you do have a concept of
3733 * "tainted because running with altered effective ids', you'll
3734 * have to add your own checks somewhere in here. The two most
3735 * known samples of 'implicitness' are Win32 and NetWare, neither
3736 * of which has much of concept of 'uids'. */
3737 int uid = PerlProc_getuid();
3738 int euid = PerlProc_geteuid();
3739 int gid = PerlProc_getgid();
3740 int egid = PerlProc_getegid();
3746 if (uid && (euid != uid || egid != gid))
3748 #endif /* !PERL_IMPLICIT_SYS */
3749 /* This is a really primitive check; environment gets ignored only
3750 * if -T are the first chars together; otherwise one gets
3751 * "Too late" message. */
3752 if ( argc > 1 && argv[1][0] == '-'
3753 && (argv[1][1] == 't' || argv[1][1] == 'T') )
3759 S_forbid_setid(pTHX_ char *s)
3761 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
3762 if (PL_euid != PL_uid)
3763 Perl_croak(aTHX_ "No %s allowed while running setuid", s);
3764 if (PL_egid != PL_gid)
3765 Perl_croak(aTHX_ "No %s allowed while running setgid", s);
3766 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
3768 * Checks for UID/GID above "wrong": why disallow
3769 * perl -e 'print "Hello\n"'
3770 * from within setuid things?? Simply drop them: replaced by
3771 * fdscript/suidscript and #ifdef IAMSUID checks below.
3773 * This may be too late for command-line switches. Will catch those on
3774 * the #! line, after finding the script name and setting up
3775 * fdscript/suidscript. Note that suidperl does not get around to
3776 * parsing (and checking) the switches on the #! line, but checks that
3777 * the two sets are identical.
3779 * With SETUID_SCRIPTS_ARE_SECURE_NOW, could we use fdscript, also or
3780 * instead, or would that be "too late"? (We never have suidscript, can
3781 * we be sure to have fdscript?)
3783 * Catch things with suidscript (in descendant of suidperl), even with
3784 * right UID/GID. Was already checked in suidperl, with #ifdef IAMSUID,
3785 * below; but I am paranoid.
3787 * Also see comments about root running a setuid script, elsewhere.
3789 if (PL_suidscript >= 0)
3790 Perl_croak(aTHX_ "No %s allowed with (suid) fdscript", s);
3792 /* PSz 11 Nov 03 Catch it in suidperl, always! */
3793 Perl_croak(aTHX_ "No %s allowed in suidperl", s);
3794 #endif /* IAMSUID */
3798 Perl_init_debugger(pTHX)
3800 HV *ostash = PL_curstash;
3802 PL_curstash = PL_debstash;
3803 PL_dbargs = GvAV(gv_AVadd((gv_fetchpv("DB::args", GV_ADDMULTI, SVt_PVAV))));
3804 AvREAL_off(PL_dbargs);
3805 PL_DBgv = gv_fetchpv("DB::DB", GV_ADDMULTI, SVt_PVGV);
3806 PL_DBline = gv_fetchpv("DB::dbline", GV_ADDMULTI, SVt_PVAV);
3807 PL_DBsub = gv_HVadd(gv_fetchpv("DB::sub", GV_ADDMULTI, SVt_PVHV));
3808 sv_upgrade(GvSV(PL_DBsub), SVt_IV); /* IVX accessed if PERLDB_SUB_NN */
3809 PL_DBsingle = GvSV((gv_fetchpv("DB::single", GV_ADDMULTI, SVt_PV)));
3810 sv_setiv(PL_DBsingle, 0);
3811 PL_DBtrace = GvSV((gv_fetchpv("DB::trace", GV_ADDMULTI, SVt_PV)));
3812 sv_setiv(PL_DBtrace, 0);
3813 PL_DBsignal = GvSV((gv_fetchpv("DB::signal", GV_ADDMULTI, SVt_PV)));
3814 sv_setiv(PL_DBsignal, 0);
3815 PL_DBassertion = GvSV((gv_fetchpv("DB::assertion", GV_ADDMULTI, SVt_PV)));
3816 sv_setiv(PL_DBassertion, 0);
3817 PL_curstash = ostash;
3820 #ifndef STRESS_REALLOC
3821 #define REASONABLE(size) (size)
3823 #define REASONABLE(size) (1) /* unreasonable */
3827 Perl_init_stacks(pTHX)
3829 /* start with 128-item stack and 8K cxstack */
3830 PL_curstackinfo = new_stackinfo(REASONABLE(128),
3831 REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
3832 PL_curstackinfo->si_type = PERLSI_MAIN;
3833 PL_curstack = PL_curstackinfo->si_stack;
3834 PL_mainstack = PL_curstack; /* remember in case we switch stacks */
3836 PL_stack_base = AvARRAY(PL_curstack);
3837 PL_stack_sp = PL_stack_base;
3838 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
3840 New(50,PL_tmps_stack,REASONABLE(128),SV*);
3843 PL_tmps_max = REASONABLE(128);
3845 New(54,PL_markstack,REASONABLE(32),I32);
3846 PL_markstack_ptr = PL_markstack;
3847 PL_markstack_max = PL_markstack + REASONABLE(32);
3851 New(54,PL_scopestack,REASONABLE(32),I32);
3852 PL_scopestack_ix = 0;
3853 PL_scopestack_max = REASONABLE(32);
3855 New(54,PL_savestack,REASONABLE(128),ANY);
3856 PL_savestack_ix = 0;
3857 PL_savestack_max = REASONABLE(128);
3859 New(54,PL_retstack,REASONABLE(16),OP*);
3861 PL_retstack_max = REASONABLE(16);
3869 while (PL_curstackinfo->si_next)
3870 PL_curstackinfo = PL_curstackinfo->si_next;
3871 while (PL_curstackinfo) {
3872 PERL_SI *p = PL_curstackinfo->si_prev;
3873 /* curstackinfo->si_stack got nuked by sv_free_arenas() */
3874 Safefree(PL_curstackinfo->si_cxstack);
3875 Safefree(PL_curstackinfo);
3876 PL_curstackinfo = p;
3878 Safefree(PL_tmps_stack);
3879 Safefree(PL_markstack);
3880 Safefree(PL_scopestack);
3881 Safefree(PL_savestack);
3882 Safefree(PL_retstack);
3891 lex_start(PL_linestr);
3893 PL_subname = newSVpvn("main",4);
3897 S_init_predump_symbols(pTHX)
3902 sv_setpvn(get_sv("\"", TRUE), " ", 1);
3903 PL_stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
3904 GvMULTI_on(PL_stdingv);
3905 io = GvIOp(PL_stdingv);
3906 IoTYPE(io) = IoTYPE_RDONLY;
3907 IoIFP(io) = PerlIO_stdin();
3908 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
3910 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
3912 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
3915 IoTYPE(io) = IoTYPE_WRONLY;
3916 IoOFP(io) = IoIFP(io) = PerlIO_stdout();
3918 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
3920 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
3922 PL_stderrgv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
3923 GvMULTI_on(PL_stderrgv);
3924 io = GvIOp(PL_stderrgv);
3925 IoTYPE(io) = IoTYPE_WRONLY;
3926 IoOFP(io) = IoIFP(io) = PerlIO_stderr();
3927 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
3929 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
3931 PL_statname = NEWSV(66,0); /* last filename we did stat on */
3934 Safefree(PL_osname);
3935 PL_osname = savepv(OSNAME);
3939 Perl_init_argv_symbols(pTHX_ register int argc, register char **argv)
3942 argc--,argv++; /* skip name of script */
3943 if (PL_doswitches) {
3944 for (; argc > 0 && **argv == '-'; argc--,argv++) {
3947 if (argv[0][1] == '-' && !argv[0][2]) {
3951 if ((s = strchr(argv[0], '='))) {
3953 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
3956 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
3959 if ((PL_argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV))) {
3960 GvMULTI_on(PL_argvgv);
3961 (void)gv_AVadd(PL_argvgv);
3962 av_clear(GvAVn(PL_argvgv));
3963 for (; argc > 0; argc--,argv++) {
3964 SV *sv = newSVpv(argv[0],0);
3965 av_push(GvAVn(PL_argvgv),sv);
3966 if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) {
3967 if (PL_unicode & PERL_UNICODE_ARGV_FLAG)
3970 if (PL_unicode & PERL_UNICODE_WIDESYSCALLS_FLAG) /* Sarathy? */
3971 (void)sv_utf8_decode(sv);
3976 #ifdef HAS_PROCSELFEXE
3977 /* This is a function so that we don't hold on to MAXPATHLEN
3978 bytes of stack longer than necessary
3981 S_procself_val(pTHX_ SV *sv, char *arg0)
3983 char buf[MAXPATHLEN];
3984 int len = readlink(PROCSELFEXE_PATH, buf, sizeof(buf) - 1);
3986 /* On Playstation2 Linux V1.0 (kernel 2.2.1) readlink(/proc/self/exe)
3987 includes a spurious NUL which will cause $^X to fail in system
3988 or backticks (this will prevent extensions from being built and
3989 many tests from working). readlink is not meant to add a NUL.
3990 Normal readlink works fine.
3992 if (len > 0 && buf[len-1] == '\0') {
3996 /* FreeBSD's implementation is acknowledged to be imperfect, sometimes
3997 returning the text "unknown" from the readlink rather than the path
3998 to the executable (or returning an error from the readlink). Any valid
3999 path has a '/' in it somewhere, so use that to validate the result.
4000 See http://www.freebsd.org/cgi/query-pr.cgi?pr=35703
4002 if (len > 0 && memchr(buf, '/', len)) {
4003 sv_setpvn(sv,buf,len);
4009 #endif /* HAS_PROCSELFEXE */
4012 S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env)
4018 PL_toptarget = NEWSV(0,0);
4019 sv_upgrade(PL_toptarget, SVt_PVFM);
4020 sv_setpvn(PL_toptarget, "", 0);
4021 PL_bodytarget = NEWSV(0,0);
4022 sv_upgrade(PL_bodytarget, SVt_PVFM);
4023 sv_setpvn(PL_bodytarget, "", 0);
4024 PL_formtarget = PL_bodytarget;
4028 init_argv_symbols(argc,argv);
4030 if ((tmpgv = gv_fetchpv("0",TRUE, SVt_PV))) {
4031 #ifdef MACOS_TRADITIONAL
4032 /* $0 is not majick on a Mac */
4033 sv_setpv(GvSV(tmpgv),MacPerl_MPWFileName(PL_origfilename));
4035 sv_setpv(GvSV(tmpgv),PL_origfilename);
4036 magicname("0", "0", 1);
4039 if ((tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))) {/* $^X */
4040 #ifdef HAS_PROCSELFEXE
4041 S_procself_val(aTHX_ GvSV(tmpgv), PL_origargv[0]);
4044 sv_setpv(GvSV(tmpgv), os2_execname(aTHX));
4046 sv_setpv(GvSV(tmpgv),PL_origargv[0]);
4050 if ((PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV))) {
4052 GvMULTI_on(PL_envgv);
4053 hv = GvHVn(PL_envgv);
4054 hv_magic(hv, Nullgv, PERL_MAGIC_env);
4056 #ifdef USE_ENVIRON_ARRAY
4057 /* Note that if the supplied env parameter is actually a copy
4058 of the global environ then it may now point to free'd memory
4059 if the environment has been modified since. To avoid this
4060 problem we treat env==NULL as meaning 'use the default'
4065 # ifdef USE_ITHREADS
4066 && PL_curinterp == aTHX
4070 environ[0] = Nullch;
4073 for (; *env; env++) {
4074 if (!(s = strchr(*env,'=')))
4076 #if defined(MSDOS) && !defined(DJGPP)
4081 sv = newSVpv(s+1, 0);
4082 (void)hv_store(hv, *env, s - *env, sv, 0);
4086 #endif /* USE_ENVIRON_ARRAY */
4087 #endif /* !PERL_MICRO */
4090 if ((tmpgv = gv_fetchpv("$",TRUE, SVt_PV))) {
4091 SvREADONLY_off(GvSV(tmpgv));
4092 sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
4093 SvREADONLY_on(GvSV(tmpgv));
4095 #ifdef THREADS_HAVE_PIDS
4096 PL_ppid = (IV)getppid();
4099 /* touch @F array to prevent spurious warnings 20020415 MJD */
4101 (void) get_av("main::F", TRUE | GV_ADDMULTI);
4103 /* touch @- and @+ arrays to prevent spurious warnings 20020415 MJD */
4104 (void) get_av("main::-", TRUE | GV_ADDMULTI);
4105 (void) get_av("main::+", TRUE | GV_ADDMULTI);
4109 S_init_perllib(pTHX)
4114 s = PerlEnv_getenv("PERL5LIB");
4116 incpush(s, TRUE, TRUE, TRUE);
4118 incpush(PerlEnv_getenv("PERLLIB"), FALSE, FALSE, TRUE);
4120 /* Treat PERL5?LIB as a possible search list logical name -- the
4121 * "natural" VMS idiom for a Unix path string. We allow each
4122 * element to be a set of |-separated directories for compatibility.
4126 if (my_trnlnm("PERL5LIB",buf,0))
4127 do { incpush(buf,TRUE,TRUE,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
4129 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE,FALSE,TRUE);
4133 /* Use the ~-expanded versions of APPLLIB (undocumented),
4134 ARCHLIB PRIVLIB SITEARCH SITELIB VENDORARCH and VENDORLIB
4137 incpush(APPLLIB_EXP, TRUE, TRUE, TRUE);
4141 incpush(ARCHLIB_EXP, FALSE, FALSE, TRUE);
4143 #ifdef MACOS_TRADITIONAL
4146 SV * privdir = NEWSV(55, 0);
4147 char * macperl = PerlEnv_getenv("MACPERL");
4152 Perl_sv_setpvf(aTHX_ privdir, "%slib:", macperl);
4153 if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode))
4154 incpush(SvPVX(privdir), TRUE, FALSE, TRUE);
4155 Perl_sv_setpvf(aTHX_ privdir, "%ssite_perl:", macperl);
4156 if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode))
4157 incpush(SvPVX(privdir), TRUE, FALSE, TRUE);
4159 SvREFCNT_dec(privdir);
4162 incpush(":", FALSE, FALSE, TRUE);
4165 # define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
4168 incpush(PRIVLIB_EXP, TRUE, FALSE, TRUE);
4170 incpush(PRIVLIB_EXP, FALSE, FALSE, TRUE);
4174 /* sitearch is always relative to sitelib on Windows for
4175 * DLL-based path intuition to work correctly */
4176 # if !defined(WIN32)
4177 incpush(SITEARCH_EXP, FALSE, FALSE, TRUE);
4183 /* this picks up sitearch as well */
4184 incpush(SITELIB_EXP, TRUE, FALSE, TRUE);
4186 incpush(SITELIB_EXP, FALSE, FALSE, TRUE);
4190 #ifdef SITELIB_STEM /* Search for version-specific dirs below here */
4191 incpush(SITELIB_STEM, FALSE, TRUE, TRUE);
4194 #ifdef PERL_VENDORARCH_EXP
4195 /* vendorarch is always relative to vendorlib on Windows for
4196 * DLL-based path intuition to work correctly */
4197 # if !defined(WIN32)
4198 incpush(PERL_VENDORARCH_EXP, FALSE, FALSE, TRUE);
4202 #ifdef PERL_VENDORLIB_EXP
4204 incpush(PERL_VENDORLIB_EXP, TRUE, FALSE, TRUE); /* this picks up vendorarch as well */
4206 incpush(PERL_VENDORLIB_EXP, FALSE, FALSE, TRUE);
4210 #ifdef PERL_VENDORLIB_STEM /* Search for version-specific dirs below here */
4211 incpush(PERL_VENDORLIB_STEM, FALSE, TRUE, TRUE);
4214 #ifdef PERL_OTHERLIBDIRS
4215 incpush(PERL_OTHERLIBDIRS, TRUE, TRUE, TRUE);
4219 incpush(".", FALSE, FALSE, TRUE);
4220 #endif /* MACOS_TRADITIONAL */
4223 #if defined(DOSISH) || defined(EPOC)
4224 # define PERLLIB_SEP ';'
4227 # define PERLLIB_SEP '|'
4229 # if defined(MACOS_TRADITIONAL)
4230 # define PERLLIB_SEP ','
4232 # define PERLLIB_SEP ':'
4236 #ifndef PERLLIB_MANGLE
4237 # define PERLLIB_MANGLE(s,n) (s)
4241 S_incpush(pTHX_ char *p, int addsubdirs, int addoldvers, int usesep)
4243 SV *subdir = Nullsv;
4248 if (addsubdirs || addoldvers) {
4249 subdir = sv_newmortal();
4252 /* Break at all separators */
4254 SV *libdir = NEWSV(55,0);
4257 /* skip any consecutive separators */
4259 while ( *p == PERLLIB_SEP ) {
4260 /* Uncomment the next line for PATH semantics */
4261 /* av_push(GvAVn(PL_incgv), newSVpvn(".", 1)); */
4266 if ( usesep && (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
4267 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
4272 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
4273 p = Nullch; /* break out */
4275 #ifdef MACOS_TRADITIONAL
4276 if (!strchr(SvPVX(libdir), ':')) {
4279 sv_setpv(libdir, MacPerl_CanonDir(SvPVX(libdir), buf, 0));
4281 if (SvPVX(libdir)[SvCUR(libdir)-1] != ':')
4282 sv_catpv(libdir, ":");
4286 * BEFORE pushing libdir onto @INC we may first push version- and
4287 * archname-specific sub-directories.
4289 if (addsubdirs || addoldvers) {
4290 #ifdef PERL_INC_VERSION_LIST
4291 /* Configure terminates PERL_INC_VERSION_LIST with a NULL */
4292 const char *incverlist[] = { PERL_INC_VERSION_LIST };
4293 const char **incver;
4300 if ((unix = tounixspec_ts(SvPV(libdir,len),Nullch)) != Nullch) {
4302 while (unix[len-1] == '/') len--; /* Cosmetic */
4303 sv_usepvn(libdir,unix,len);
4306 PerlIO_printf(Perl_error_log,
4307 "Failed to unixify @INC element \"%s\"\n",
4311 #ifdef MACOS_TRADITIONAL
4312 #define PERL_AV_SUFFIX_FMT ""
4313 #define PERL_ARCH_FMT "%s:"
4314 #define PERL_ARCH_FMT_PATH PERL_FS_VER_FMT PERL_AV_SUFFIX_FMT
4316 #define PERL_AV_SUFFIX_FMT "/"
4317 #define PERL_ARCH_FMT "/%s"
4318 #define PERL_ARCH_FMT_PATH PERL_AV_SUFFIX_FMT PERL_FS_VER_FMT
4320 /* .../version/archname if -d .../version/archname */
4321 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PATH PERL_ARCH_FMT,
4323 (int)PERL_REVISION, (int)PERL_VERSION,
4324 (int)PERL_SUBVERSION, ARCHNAME);
4325 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
4326 S_ISDIR(tmpstatbuf.st_mode))
4327 av_push(GvAVn(PL_incgv), newSVsv(subdir));
4329 /* .../version if -d .../version */
4330 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PATH, libdir,
4331 (int)PERL_REVISION, (int)PERL_VERSION,
4332 (int)PERL_SUBVERSION);
4333 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
4334 S_ISDIR(tmpstatbuf.st_mode))
4335 av_push(GvAVn(PL_incgv), newSVsv(subdir));
4337 /* .../archname if -d .../archname */
4338 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, libdir, ARCHNAME);
4339 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
4340 S_ISDIR(tmpstatbuf.st_mode))
4341 av_push(GvAVn(PL_incgv), newSVsv(subdir));
4344 #ifdef PERL_INC_VERSION_LIST
4346 for (incver = incverlist; *incver; incver++) {
4347 /* .../xxx if -d .../xxx */
4348 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, libdir, *incver);
4349 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
4350 S_ISDIR(tmpstatbuf.st_mode))
4351 av_push(GvAVn(PL_incgv), newSVsv(subdir));
4357 /* finally push this lib directory on the end of @INC */
4358 av_push(GvAVn(PL_incgv), libdir);
4362 #ifdef USE_5005THREADS
4363 STATIC struct perl_thread *
4364 S_init_main_thread(pTHX)
4366 #if !defined(PERL_IMPLICIT_CONTEXT)
4367 struct perl_thread *thr;
4371 Newz(53, thr, 1, struct perl_thread);
4372 PL_curcop = &PL_compiling;
4373 thr->interp = PERL_GET_INTERP;
4374 thr->cvcache = newHV();
4375 thr->threadsv = newAV();
4376 /* thr->threadsvp is set when find_threadsv is called */
4377 thr->specific = newAV();
4378 thr->flags = THRf_R_JOINABLE;
4379 MUTEX_INIT(&thr->mutex);
4380 /* Handcraft thrsv similarly to mess_sv */
4381 New(53, PL_thrsv, 1, SV);
4382 Newz(53, xpv, 1, XPV);
4383 SvFLAGS(PL_thrsv) = SVt_PV;
4384 SvANY(PL_thrsv) = (void*)xpv;
4385 SvREFCNT(PL_thrsv) = 1 << 30; /* practically infinite */
4386 SvPVX(PL_thrsv) = (char*)thr;
4387 SvCUR_set(PL_thrsv, sizeof(thr));
4388 SvLEN_set(PL_thrsv, sizeof(thr));
4389 *SvEND(PL_thrsv) = '\0'; /* in the trailing_nul field */
4390 thr->oursv = PL_thrsv;
4391 PL_chopset = " \n-";
4394 MUTEX_LOCK(&PL_threads_mutex);
4400 MUTEX_UNLOCK(&PL_threads_mutex);
4402 #ifdef HAVE_THREAD_INTERN
4403 Perl_init_thread_intern(thr);
4406 #ifdef SET_THREAD_SELF
4407 SET_THREAD_SELF(thr);
4409 thr->self = pthread_self();
4410 #endif /* SET_THREAD_SELF */
4414 * These must come after the thread self setting
4415 * because sv_setpvn does SvTAINT and the taint
4416 * fields thread selfness being set.
4418 PL_toptarget = NEWSV(0,0);
4419 sv_upgrade(PL_toptarget, SVt_PVFM);
4420 sv_setpvn(PL_toptarget, "", 0);
4421 PL_bodytarget = NEWSV(0,0);
4422 sv_upgrade(PL_bodytarget, SVt_PVFM);
4423 sv_setpvn(PL_bodytarget, "", 0);
4424 PL_formtarget = PL_bodytarget;
4425 thr->errsv = newSVpvn("", 0);
4426 (void) find_threadsv("@"); /* Ensure $@ is initialised early */
4429 PL_peepp = MEMBER_TO_FPTR(Perl_peep);
4430 PL_regcompp = MEMBER_TO_FPTR(Perl_pregcomp);
4431 PL_regexecp = MEMBER_TO_FPTR(Perl_regexec_flags);
4432 PL_regint_start = MEMBER_TO_FPTR(Perl_re_intuit_start);
4433 PL_regint_string = MEMBER_TO_FPTR(Perl_re_intuit_string);
4434 PL_regfree = MEMBER_TO_FPTR(Perl_pregfree);
4436 PL_reginterp_cnt = 0;
4440 #endif /* USE_5005THREADS */
4443 Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
4446 line_t oldline = CopLINE(PL_curcop);
4452 while (AvFILL(paramList) >= 0) {
4453 cv = (CV*)av_shift(paramList);
4455 if (paramList == PL_beginav) {
4456 /* save PL_beginav for compiler */
4457 if (! PL_beginav_save)
4458 PL_beginav_save = newAV();
4459 av_push(PL_beginav_save, (SV*)cv);
4461 else if (paramList == PL_checkav) {
4462 /* save PL_checkav for compiler */
4463 if (! PL_checkav_save)
4464 PL_checkav_save = newAV();
4465 av_push(PL_checkav_save, (SV*)cv);
4470 #ifdef PERL_FLEXIBLE_EXCEPTIONS
4471 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_list_body), cv);
4477 #ifndef PERL_FLEXIBLE_EXCEPTIONS
4481 (void)SvPV(atsv, len);
4483 PL_curcop = &PL_compiling;
4484 CopLINE_set(PL_curcop, oldline);
4485 if (paramList == PL_beginav)
4486 sv_catpv(atsv, "BEGIN failed--compilation aborted");
4488 Perl_sv_catpvf(aTHX_ atsv,
4489 "%s failed--call queue aborted",
4490 paramList == PL_checkav ? "CHECK"
4491 : paramList == PL_initav ? "INIT"
4493 while (PL_scopestack_ix > oldscope)
4496 Perl_croak(aTHX_ "%"SVf"", atsv);
4503 /* my_exit() was called */
4504 while (PL_scopestack_ix > oldscope)
4507 PL_curstash = PL_defstash;
4508 PL_curcop = &PL_compiling;
4509 CopLINE_set(PL_curcop, oldline);
4511 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED)) {
4512 if (paramList == PL_beginav)
4513 Perl_croak(aTHX_ "BEGIN failed--compilation aborted");
4515 Perl_croak(aTHX_ "%s failed--call queue aborted",
4516 paramList == PL_checkav ? "CHECK"
4517 : paramList == PL_initav ? "INIT"
4524 PL_curcop = &PL_compiling;
4525 CopLINE_set(PL_curcop, oldline);
4528 PerlIO_printf(Perl_error_log, "panic: restartop\n");
4536 #ifdef PERL_FLEXIBLE_EXCEPTIONS
4538 S_vcall_list_body(pTHX_ va_list args)
4540 CV *cv = va_arg(args, CV*);
4541 return call_list_body(cv);
4546 S_call_list_body(pTHX_ CV *cv)
4548 PUSHMARK(PL_stack_sp);
4549 call_sv((SV*)cv, G_EVAL|G_DISCARD);
4554 Perl_my_exit(pTHX_ U32 status)
4556 DEBUG_S(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
4557 thr, (unsigned long) status));
4566 STATUS_NATIVE_SET(status);
4573 Perl_my_failure_exit(pTHX)
4576 if (vaxc$errno & 1) {
4577 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
4578 STATUS_NATIVE_SET(44);
4581 if (!vaxc$errno && errno) /* unlikely */
4582 STATUS_NATIVE_SET(44);
4584 STATUS_NATIVE_SET(vaxc$errno);
4589 STATUS_POSIX_SET(errno);
4591 exitstatus = STATUS_POSIX >> 8;
4592 if (exitstatus & 255)
4593 STATUS_POSIX_SET(exitstatus);
4595 STATUS_POSIX_SET(255);
4602 S_my_exit_jump(pTHX)
4604 register PERL_CONTEXT *cx;
4609 SvREFCNT_dec(PL_e_script);
4610 PL_e_script = Nullsv;
4613 POPSTACK_TO(PL_mainstack);
4614 if (cxstack_ix >= 0) {
4617 POPBLOCK(cx,PL_curpm);
4625 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen)
4628 p = SvPVX(PL_e_script);
4629 nl = strchr(p, '\n');
4630 nl = (nl) ? nl+1 : SvEND(PL_e_script);
4632 filter_del(read_e_script);
4635 sv_catpvn(buf_sv, p, nl-p);
4636 sv_chop(PL_e_script, nl);