source: vendor/perl/5.8.8/perl.c

Last change on this file was 3181, checked in by bird, 18 years ago

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