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