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