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 *
63 Paul Szabo - psz@maths.usyd.edu.au http://www.maths.usyd.edu.au:8000/u/psz/
64 School 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"
87 char *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
103 union 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)
123 char *getenv (char *); /* Usually in <stdlib.h> */
124 #endif
125
126 static 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
177 PerlInterpreter *
perl_alloc_using(struct IPerlMem * ipM,struct IPerlMem * ipMS,struct IPerlMem * ipMP,struct IPerlEnv * ipE,struct IPerlStdIO * ipStd,struct IPerlLIO * ipLIO,struct IPerlDir * ipD,struct IPerlSock * ipS,struct IPerlProc * ipP)178 perl_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
208 Allocates a new Perl interpreter. See L<perlembed>.
209
210 =cut
211 */
212
213 PerlInterpreter *
perl_alloc(void)214 perl_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
232 Initializes a new Perl interpreter. See L<perlembed>.
233
234 =cut
235 */
236
237 void
perl_construct(pTHXx)238 perl_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
416 Stub that provides thread hook for perl_destruct when there are
417 no threads.
418
419 =cut
420 */
421
422 int
Perl_nothreadhook(pTHX)423 Perl_nothreadhook(pTHX)
424 {
425 return 0;
426 }
427
428 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
429 void
Perl_dump_sv_child(pTHX_ SV * sv)430 Perl_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
529 Shuts down a Perl interpreter. See L<perlembed>.
530
531 =cut
532 */
533
534 int
perl_destruct(pTHXx)535 perl_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*)⌖
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
1373 Releases a Perl interpreter. See L<perlembed>.
1374
1375 =cut
1376 */
1377
1378 void
perl_free(pTHXx)1379 perl_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
1410 static void
1411 #if defined(__GNUC__)
1412 __attribute__((destructor))
1413 #endif
perl_fini(void)1414 perl_fini(void)
1415 {
1416 if (PL_curinterp)
1417 FREE_THREAD_KEY;
1418 }
1419
1420 #endif /* WIN32 */
1421 #endif /* THREADS */
1422
1423 void
Perl_call_atexit(pTHX_ ATEXIT_t fn,void * ptr)1424 Perl_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
1435 Tells a Perl interpreter to parse a Perl script. See L<perlembed>.
1436
1437 =cut
1438 */
1439
1440 int
perl_parse(pTHXx_ XSINIT_t xsinit,int argc,char ** argv,char ** env)1441 perl_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\
1456 setuid 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
1627 STATIC void *
S_vparse_body(pTHX_ va_list args)1628 S_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
1637 STATIC void *
S_parse_body(pTHX_ char ** env,XSINIT_t xsinit)1638 S_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 #ifndef __OpenBSD__
1922 #ifdef __DATE__
1923 # ifdef __TIME__
1924 Perl_sv_catpvf(aTHX_ opts_prog,
1925 ",\" Compiled at %s %s\\n\"",__DATE__,
1926 __TIME__);
1927 # else
1928 Perl_sv_catpvf(aTHX_ opts_prog,",\" Compiled on %s\\n\"",
1929 __DATE__);
1930 # endif
1931 #endif
1932 #endif
1933 sv_catpv(opts_prog, "; $\"=\"\\n \"; "
1934 "@env = map { \"$_=\\\"$ENV{$_}\\\"\" } "
1935 "sort grep {/^PERL/} keys %ENV; ");
1936 #ifdef __CYGWIN__
1937 sv_catpv(opts_prog,
1938 "push @env, \"CYGWIN=\\\"$ENV{CYGWIN}\\\"\";");
1939 #endif
1940 sv_catpv(opts_prog,
1941 "print \" \\%ENV:\\n @env\\n\" if @env;"
1942 "print \" \\@INC:\\n @INC\\n\";");
1943 }
1944 else {
1945 ++s;
1946 opts_prog = Perl_newSVpvf(aTHX_
1947 "Config::config_vars(qw%c%s%c)",
1948 0, s, 0);
1949 s += strlen(s);
1950 }
1951 av_push(PL_preambleav, opts_prog);
1952 /* don't look for script or read stdin */
1953 scriptname = BIT_BUCKET;
1954 goto reswitch;
1955 }
1956 case 'x':
1957 PL_doextract = TRUE;
1958 s++;
1959 if (*s)
1960 cddir = s;
1961 break;
1962 case 0:
1963 break;
1964 case '-':
1965 if (!*++s || isSPACE(*s)) {
1966 argc--,argv++;
1967 goto switch_end;
1968 }
1969 /* catch use of gnu style long options */
1970 if (strEQ(s, "version")) {
1971 s = (char *)"v";
1972 goto reswitch;
1973 }
1974 if (strEQ(s, "help")) {
1975 s = (char *)"h";
1976 goto reswitch;
1977 }
1978 s--;
1979 /* FALL THROUGH */
1980 default:
1981 Perl_croak(aTHX_ "Unrecognized switch: -%s (-h will show valid options)",s);
1982 }
1983 }
1984 switch_end:
1985
1986 if (
1987 #ifndef SECURE_INTERNAL_GETENV
1988 !PL_tainting &&
1989 #endif
1990 (s = PerlEnv_getenv("PERL5OPT")))
1991 {
1992 const char *popt = s;
1993 while (isSPACE(*s))
1994 s++;
1995 if (*s == '-' && *(s+1) == 'T') {
1996 CHECK_MALLOC_TOO_LATE_FOR('T');
1997 PL_tainting = TRUE;
1998 PL_taint_warn = FALSE;
1999 }
2000 else {
2001 char *popt_copy = Nullch;
2002 while (s && *s) {
2003 char *d;
2004 while (isSPACE(*s))
2005 s++;
2006 if (*s == '-') {
2007 s++;
2008 if (isSPACE(*s))
2009 continue;
2010 }
2011 d = s;
2012 if (!*s)
2013 break;
2014 if (!strchr("DIMUdmtw", *s))
2015 Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s);
2016 while (++s && *s) {
2017 if (isSPACE(*s)) {
2018 if (!popt_copy) {
2019 popt_copy = SvPVX(sv_2mortal(newSVpv(popt,0)));
2020 s = popt_copy + (s - popt);
2021 d = popt_copy + (d - popt);
2022 }
2023 *s++ = '\0';
2024 break;
2025 }
2026 }
2027 if (*d == 't') {
2028 if( !PL_tainting ) {
2029 PL_taint_warn = TRUE;
2030 PL_tainting = TRUE;
2031 }
2032 } else {
2033 moreswitches(d);
2034 }
2035 }
2036 }
2037 }
2038
2039 #ifdef USE_SITECUSTOMIZE
2040 if (!minus_f) {
2041 if (!PL_preambleav)
2042 PL_preambleav = newAV();
2043 av_unshift(PL_preambleav, 1);
2044 (void)av_store(PL_preambleav, 0, Perl_newSVpvf(aTHX_ "BEGIN { do '%s/sitecustomize.pl' }", SITELIB_EXP));
2045 }
2046 #endif
2047
2048 if (PL_taint_warn && PL_dowarn != G_WARN_ALL_OFF) {
2049 PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
2050 }
2051
2052 if (!scriptname)
2053 scriptname = argv[0];
2054 if (PL_e_script) {
2055 argc++,argv--;
2056 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
2057 }
2058 else if (scriptname == Nullch) {
2059 #ifdef MSDOS
2060 if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
2061 moreswitches("h");
2062 #endif
2063 scriptname = "-";
2064 }
2065
2066 init_perllib();
2067
2068 open_script(scriptname,dosearch,sv);
2069
2070 validate_suid(validarg, scriptname);
2071
2072 #ifndef PERL_MICRO
2073 #if defined(SIGCHLD) || defined(SIGCLD)
2074 {
2075 #ifndef SIGCHLD
2076 # define SIGCHLD SIGCLD
2077 #endif
2078 Sighandler_t sigstate = rsignal_state(SIGCHLD);
2079 if (sigstate == SIG_IGN) {
2080 if (ckWARN(WARN_SIGNAL))
2081 Perl_warner(aTHX_ packWARN(WARN_SIGNAL),
2082 "Can't ignore signal CHLD, forcing to default");
2083 (void)rsignal(SIGCHLD, (Sighandler_t)SIG_DFL);
2084 }
2085 }
2086 #endif
2087 #endif
2088
2089 #ifdef MACOS_TRADITIONAL
2090 if (PL_doextract || gMacPerl_AlwaysExtract) {
2091 #else
2092 if (PL_doextract) {
2093 #endif
2094 find_beginning();
2095 if (cddir && PerlDir_chdir( (char *)cddir ) < 0)
2096 Perl_croak(aTHX_ "Can't chdir to %s",cddir);
2097
2098 }
2099
2100 PL_main_cv = PL_compcv = (CV*)NEWSV(1104,0);
2101 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2102 CvUNIQUE_on(PL_compcv);
2103
2104 CvPADLIST(PL_compcv) = pad_new(0);
2105 #ifdef USE_5005THREADS
2106 CvOWNER(PL_compcv) = 0;
2107 Newx(CvMUTEXP(PL_compcv), 1, perl_mutex);
2108 MUTEX_INIT(CvMUTEXP(PL_compcv));
2109 #endif /* USE_5005THREADS */
2110
2111 boot_core_PerlIO();
2112 boot_core_UNIVERSAL();
2113 boot_core_xsutils();
2114
2115 if (xsinit)
2116 (*xsinit)(aTHX); /* in case linked C routines want magical variables */
2117 #ifndef PERL_MICRO
2118 #if defined(VMS) || defined(WIN32) || defined(DJGPP) || defined(__CYGWIN__) || defined(EPOC)
2119 init_os_extras();
2120 #endif
2121 #endif
2122
2123 #ifdef USE_SOCKS
2124 # ifdef HAS_SOCKS5_INIT
2125 socks5_init(argv[0]);
2126 # else
2127 SOCKSinit(argv[0]);
2128 # endif
2129 #endif
2130
2131 init_predump_symbols();
2132 /* init_postdump_symbols not currently designed to be called */
2133 /* more than once (ENV isn't cleared first, for example) */
2134 /* But running with -u leaves %ENV & @ARGV undefined! XXX */
2135 if (!PL_do_undump)
2136 init_postdump_symbols(argc,argv,env);
2137
2138 /* PL_unicode is turned on by -C, or by $ENV{PERL_UNICODE},
2139 * or explicitly in some platforms.
2140 * locale.c:Perl_init_i18nl10n() if the environment
2141 * look like the user wants to use UTF-8. */
2142 #if defined(SYMBIAN)
2143 PL_unicode = PERL_UNICODE_STD_FLAG; /* See PERL_SYMBIAN_CONSOLE_UTF8. */
2144 #endif
2145 if (PL_unicode) {
2146 /* Requires init_predump_symbols(). */
2147 if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) {
2148 IO* io;
2149 PerlIO* fp;
2150 SV* sv;
2151
2152 /* Turn on UTF-8-ness on STDIN, STDOUT, STDERR
2153 * and the default open disciplines. */
2154 if ((PL_unicode & PERL_UNICODE_STDIN_FLAG) &&
2155 PL_stdingv && (io = GvIO(PL_stdingv)) &&
2156 (fp = IoIFP(io)))
2157 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
2158 if ((PL_unicode & PERL_UNICODE_STDOUT_FLAG) &&
2159 PL_defoutgv && (io = GvIO(PL_defoutgv)) &&
2160 (fp = IoOFP(io)))
2161 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
2162 if ((PL_unicode & PERL_UNICODE_STDERR_FLAG) &&
2163 PL_stderrgv && (io = GvIO(PL_stderrgv)) &&
2164 (fp = IoOFP(io)))
2165 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
2166 if ((PL_unicode & PERL_UNICODE_INOUT_FLAG) &&
2167 (sv = GvSV(gv_fetchpv("\017PEN", TRUE, SVt_PV)))) {
2168 U32 in = PL_unicode & PERL_UNICODE_IN_FLAG;
2169 U32 out = PL_unicode & PERL_UNICODE_OUT_FLAG;
2170 if (in) {
2171 if (out)
2172 sv_setpvn(sv, ":utf8\0:utf8", 11);
2173 else
2174 sv_setpvn(sv, ":utf8\0", 6);
2175 }
2176 else if (out)
2177 sv_setpvn(sv, "\0:utf8", 6);
2178 SvSETMAGIC(sv);
2179 }
2180 }
2181 }
2182
2183 if ((s = PerlEnv_getenv("PERL_SIGNALS"))) {
2184 if (strEQ(s, "unsafe"))
2185 PL_signals |= PERL_SIGNALS_UNSAFE_FLAG;
2186 else if (strEQ(s, "safe"))
2187 PL_signals &= ~PERL_SIGNALS_UNSAFE_FLAG;
2188 else
2189 Perl_croak(aTHX_ "PERL_SIGNALS illegal: \"%s\"", s);
2190 }
2191
2192 init_lexer();
2193
2194 /* now parse the script */
2195
2196 SETERRNO(0,SS_NORMAL);
2197 PL_error_count = 0;
2198 #ifdef MACOS_TRADITIONAL
2199 if (gMacPerl_SyntaxError = (yyparse() || PL_error_count)) {
2200 if (PL_minus_c)
2201 Perl_croak(aTHX_ "%s had compilation errors.\n", MacPerl_MPWFileName(PL_origfilename));
2202 else {
2203 Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
2204 MacPerl_MPWFileName(PL_origfilename));
2205 }
2206 }
2207 #else
2208 if (yyparse() || PL_error_count) {
2209 if (PL_minus_c)
2210 Perl_croak(aTHX_ "%s had compilation errors.\n", PL_origfilename);
2211 else {
2212 Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
2213 PL_origfilename);
2214 }
2215 }
2216 #endif
2217 CopLINE_set(PL_curcop, 0);
2218 PL_curstash = PL_defstash;
2219 PL_preprocess = FALSE;
2220 if (PL_e_script) {
2221 SvREFCNT_dec(PL_e_script);
2222 PL_e_script = Nullsv;
2223 }
2224
2225 if (PL_do_undump)
2226 my_unexec();
2227
2228 if (isWARN_ONCE) {
2229 SAVECOPFILE(PL_curcop);
2230 SAVECOPLINE(PL_curcop);
2231 gv_check(PL_defstash);
2232 }
2233
2234 LEAVE;
2235 FREETMPS;
2236
2237 #ifdef MYMALLOC
2238 if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
2239 dump_mstats("after compilation:");
2240 #endif
2241
2242 ENTER;
2243 PL_restartop = 0;
2244 return NULL;
2245 }
2246
2247 /*
2248 =for apidoc perl_run
2249
2250 Tells a Perl interpreter to run. See L<perlembed>.
2251
2252 =cut
2253 */
2254
2255 int
2256 perl_run(pTHXx)
2257 {
2258 I32 oldscope;
2259 int ret = 0;
2260 dJMPENV;
2261 #ifdef USE_5005THREADS
2262 dTHX;
2263 #endif
2264
2265 PERL_UNUSED_ARG(my_perl);
2266
2267 oldscope = PL_scopestack_ix;
2268 #ifdef VMS
2269 VMSISH_HUSHED = 0;
2270 #endif
2271
2272 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2273 redo_body:
2274 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vrun_body), oldscope);
2275 #else
2276 JMPENV_PUSH(ret);
2277 #endif
2278 switch (ret) {
2279 case 1:
2280 cxstack_ix = -1; /* start context stack again */
2281 goto redo_body;
2282 case 0: /* normal completion */
2283 #ifndef PERL_FLEXIBLE_EXCEPTIONS
2284 redo_body:
2285 run_body(oldscope);
2286 #endif
2287 /* FALL THROUGH */
2288 case 2: /* my_exit() */
2289 while (PL_scopestack_ix > oldscope)
2290 LEAVE;
2291 FREETMPS;
2292 PL_curstash = PL_defstash;
2293 if (!(PL_exit_flags & PERL_EXIT_DESTRUCT_END) &&
2294 PL_endav && !PL_minus_c)
2295 call_list(oldscope, PL_endav);
2296 #ifdef MYMALLOC
2297 if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
2298 dump_mstats("after execution: ");
2299 #endif
2300 ret = STATUS_NATIVE_EXPORT;
2301 break;
2302 case 3:
2303 if (PL_restartop) {
2304 POPSTACK_TO(PL_mainstack);
2305 goto redo_body;
2306 }
2307 PerlIO_printf(Perl_error_log, "panic: restartop\n");
2308 FREETMPS;
2309 ret = 1;
2310 break;
2311 }
2312
2313 JMPENV_POP;
2314 return ret;
2315 }
2316
2317 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2318 STATIC void *
2319 S_vrun_body(pTHX_ va_list args)
2320 {
2321 I32 oldscope = va_arg(args, I32);
2322
2323 return run_body(oldscope);
2324 }
2325 #endif
2326
2327
2328 STATIC void
2329 S_run_body(pTHX_ I32 oldscope)
2330 {
2331 DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
2332 PL_sawampersand ? "Enabling" : "Omitting"));
2333
2334 if (!PL_restartop) {
2335 DEBUG_x(dump_all());
2336 #ifdef DEBUGGING
2337 PERL_DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
2338 #endif
2339 DEBUG_S(PerlIO_printf(Perl_debug_log, "main thread is 0x%"UVxf"\n",
2340 PTR2UV(thr)));
2341
2342 if (PL_minus_c) {
2343 #ifdef MACOS_TRADITIONAL
2344 PerlIO_printf(Perl_error_log, "%s%s syntax OK\n",
2345 (gMacPerl_ErrorFormat ? "# " : ""),
2346 MacPerl_MPWFileName(PL_origfilename));
2347 #else
2348 PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename);
2349 #endif
2350 my_exit(0);
2351 }
2352 if (PERLDB_SINGLE && PL_DBsingle)
2353 sv_setiv(PL_DBsingle, 1);
2354 if (PL_initav)
2355 call_list(oldscope, PL_initav);
2356 }
2357
2358 /* do it */
2359
2360 if (PL_restartop) {
2361 PL_op = PL_restartop;
2362 PL_restartop = 0;
2363 CALLRUNOPS(aTHX);
2364 }
2365 else if (PL_main_start) {
2366 CvDEPTH(PL_main_cv) = 1;
2367 PL_op = PL_main_start;
2368 CALLRUNOPS(aTHX);
2369 }
2370 my_exit(0);
2371 /* NOTREACHED */
2372 }
2373
2374 /*
2375 =head1 SV Manipulation Functions
2376
2377 =for apidoc p||get_sv
2378
2379 Returns the SV of the specified Perl scalar. If C<create> is set and the
2380 Perl variable does not exist then it will be created. If C<create> is not
2381 set and the variable does not exist then NULL is returned.
2382
2383 =cut
2384 */
2385
2386 SV*
2387 Perl_get_sv(pTHX_ const char *name, I32 create)
2388 {
2389 GV *gv;
2390 #ifdef USE_5005THREADS
2391 if (name[1] == '\0' && !isALPHA(name[0])) {
2392 PADOFFSET tmp = find_threadsv(name);
2393 if (tmp != NOT_IN_PAD)
2394 return THREADSV(tmp);
2395 }
2396 #endif /* USE_5005THREADS */
2397 gv = gv_fetchpv(name, create, SVt_PV);
2398 if (gv)
2399 return GvSV(gv);
2400 return Nullsv;
2401 }
2402
2403 /*
2404 =head1 Array Manipulation Functions
2405
2406 =for apidoc p||get_av
2407
2408 Returns the AV of the specified Perl array. If C<create> is set and the
2409 Perl variable does not exist then it will be created. If C<create> is not
2410 set and the variable does not exist then NULL is returned.
2411
2412 =cut
2413 */
2414
2415 AV*
2416 Perl_get_av(pTHX_ const char *name, I32 create)
2417 {
2418 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
2419 if (create)
2420 return GvAVn(gv);
2421 if (gv)
2422 return GvAV(gv);
2423 return Nullav;
2424 }
2425
2426 /*
2427 =head1 Hash Manipulation Functions
2428
2429 =for apidoc p||get_hv
2430
2431 Returns the HV of the specified Perl hash. If C<create> is set and the
2432 Perl variable does not exist then it will be created. If C<create> is not
2433 set and the variable does not exist then NULL is returned.
2434
2435 =cut
2436 */
2437
2438 HV*
2439 Perl_get_hv(pTHX_ const char *name, I32 create)
2440 {
2441 GV* const gv = gv_fetchpv(name, create, SVt_PVHV);
2442 if (create)
2443 return GvHVn(gv);
2444 if (gv)
2445 return GvHV(gv);
2446 return Nullhv;
2447 }
2448
2449 /*
2450 =head1 CV Manipulation Functions
2451
2452 =for apidoc p||get_cv
2453
2454 Returns the CV of the specified Perl subroutine. If C<create> is set and
2455 the Perl subroutine does not exist then it will be declared (which has the
2456 same effect as saying C<sub name;>). If C<create> is not set and the
2457 subroutine does not exist then NULL is returned.
2458
2459 =cut
2460 */
2461
2462 CV*
2463 Perl_get_cv(pTHX_ const char *name, I32 create)
2464 {
2465 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
2466 /* XXX unsafe for threads if eval_owner isn't held */
2467 /* XXX this is probably not what they think they're getting.
2468 * It has the same effect as "sub name;", i.e. just a forward
2469 * declaration! */
2470 if (create && !GvCVu(gv))
2471 return newSUB(start_subparse(FALSE, 0),
2472 newSVOP(OP_CONST, 0, newSVpv(name,0)),
2473 Nullop,
2474 Nullop);
2475 if (gv)
2476 return GvCVu(gv);
2477 return Nullcv;
2478 }
2479
2480 /* Be sure to refetch the stack pointer after calling these routines. */
2481
2482 /*
2483
2484 =head1 Callback Functions
2485
2486 =for apidoc p||call_argv
2487
2488 Performs a callback to the specified Perl sub. See L<perlcall>.
2489
2490 =cut
2491 */
2492
2493 I32
2494 Perl_call_argv(pTHX_ const char *sub_name, I32 flags, register char **argv)
2495
2496 /* See G_* flags in cop.h */
2497 /* null terminated arg list */
2498 {
2499 dSP;
2500
2501 PUSHMARK(SP);
2502 if (argv) {
2503 while (*argv) {
2504 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
2505 argv++;
2506 }
2507 PUTBACK;
2508 }
2509 return call_pv(sub_name, flags);
2510 }
2511
2512 /*
2513 =for apidoc p||call_pv
2514
2515 Performs a callback to the specified Perl sub. See L<perlcall>.
2516
2517 =cut
2518 */
2519
2520 I32
2521 Perl_call_pv(pTHX_ const char *sub_name, I32 flags)
2522 /* name of the subroutine */
2523 /* See G_* flags in cop.h */
2524 {
2525 return call_sv((SV*)get_cv(sub_name, TRUE), flags);
2526 }
2527
2528 /*
2529 =for apidoc p||call_method
2530
2531 Performs a callback to the specified Perl method. The blessed object must
2532 be on the stack. See L<perlcall>.
2533
2534 =cut
2535 */
2536
2537 I32
2538 Perl_call_method(pTHX_ const char *methname, I32 flags)
2539 /* name of the subroutine */
2540 /* See G_* flags in cop.h */
2541 {
2542 return call_sv(sv_2mortal(newSVpv(methname,0)), flags | G_METHOD);
2543 }
2544
2545 /* May be called with any of a CV, a GV, or an SV containing the name. */
2546 /*
2547 =for apidoc p||call_sv
2548
2549 Performs a callback to the Perl sub whose name is in the SV. See
2550 L<perlcall>.
2551
2552 =cut
2553 */
2554
2555 I32
2556 Perl_call_sv(pTHX_ SV *sv, I32 flags)
2557 /* See G_* flags in cop.h */
2558 {
2559 dSP;
2560 LOGOP myop; /* fake syntax tree node */
2561 UNOP method_op;
2562 I32 oldmark;
2563 volatile I32 retval = 0;
2564 I32 oldscope;
2565 bool oldcatch = CATCH_GET;
2566 int ret;
2567 OP* oldop = PL_op;
2568 dJMPENV;
2569
2570 if (flags & G_DISCARD) {
2571 ENTER;
2572 SAVETMPS;
2573 }
2574
2575 Zero(&myop, 1, LOGOP);
2576 myop.op_next = Nullop;
2577 if (!(flags & G_NOARGS))
2578 myop.op_flags |= OPf_STACKED;
2579 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
2580 (flags & G_ARRAY) ? OPf_WANT_LIST :
2581 OPf_WANT_SCALAR);
2582 SAVEOP();
2583 PL_op = (OP*)&myop;
2584
2585 EXTEND(PL_stack_sp, 1);
2586 *++PL_stack_sp = sv;
2587 oldmark = TOPMARK;
2588 oldscope = PL_scopestack_ix;
2589
2590 if (PERLDB_SUB && PL_curstash != PL_debstash
2591 /* Handle first BEGIN of -d. */
2592 && (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub)))
2593 /* Try harder, since this may have been a sighandler, thus
2594 * curstash may be meaningless. */
2595 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != PL_debstash)
2596 && !(flags & G_NODEBUG))
2597 PL_op->op_private |= OPpENTERSUB_DB;
2598
2599 if (flags & G_METHOD) {
2600 Zero(&method_op, 1, UNOP);
2601 method_op.op_next = PL_op;
2602 method_op.op_ppaddr = PL_ppaddr[OP_METHOD];
2603 myop.op_ppaddr = PL_ppaddr[OP_ENTERSUB];
2604 PL_op = (OP*)&method_op;
2605 }
2606
2607 if (!(flags & G_EVAL)) {
2608 CATCH_SET(TRUE);
2609 call_body((OP*)&myop, FALSE);
2610 retval = PL_stack_sp - (PL_stack_base + oldmark);
2611 CATCH_SET(oldcatch);
2612 }
2613 else {
2614 myop.op_other = (OP*)&myop;
2615 PL_markstack_ptr--;
2616 /* we're trying to emulate pp_entertry() here */
2617 {
2618 register PERL_CONTEXT *cx;
2619 const I32 gimme = GIMME_V;
2620
2621 ENTER;
2622 SAVETMPS;
2623
2624 push_return(Nullop);
2625 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
2626 PUSHEVAL(cx, 0, 0);
2627 PL_eval_root = PL_op; /* Only needed so that goto works right. */
2628
2629 PL_in_eval = EVAL_INEVAL;
2630 if (flags & G_KEEPERR)
2631 PL_in_eval |= EVAL_KEEPERR;
2632 else
2633 sv_setpvn(ERRSV,"",0);
2634 }
2635 PL_markstack_ptr++;
2636
2637 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2638 redo_body:
2639 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_body),
2640 (OP*)&myop, FALSE);
2641 #else
2642 JMPENV_PUSH(ret);
2643 #endif
2644 switch (ret) {
2645 case 0:
2646 #ifndef PERL_FLEXIBLE_EXCEPTIONS
2647 redo_body:
2648 call_body((OP*)&myop, FALSE);
2649 #endif
2650 retval = PL_stack_sp - (PL_stack_base + oldmark);
2651 if (!(flags & G_KEEPERR))
2652 sv_setpvn(ERRSV,"",0);
2653 break;
2654 case 1:
2655 STATUS_ALL_FAILURE;
2656 /* FALL THROUGH */
2657 case 2:
2658 /* my_exit() was called */
2659 PL_curstash = PL_defstash;
2660 FREETMPS;
2661 JMPENV_POP;
2662 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
2663 Perl_croak(aTHX_ "Callback called exit");
2664 my_exit_jump();
2665 /* NOTREACHED */
2666 case 3:
2667 if (PL_restartop) {
2668 PL_op = PL_restartop;
2669 PL_restartop = 0;
2670 goto redo_body;
2671 }
2672 PL_stack_sp = PL_stack_base + oldmark;
2673 if (flags & G_ARRAY)
2674 retval = 0;
2675 else {
2676 retval = 1;
2677 *++PL_stack_sp = &PL_sv_undef;
2678 }
2679 break;
2680 }
2681
2682 if (PL_scopestack_ix > oldscope) {
2683 SV **newsp;
2684 PMOP *newpm;
2685 I32 gimme;
2686 register PERL_CONTEXT *cx;
2687 I32 optype;
2688
2689 POPBLOCK(cx,newpm);
2690 POPEVAL(cx);
2691 pop_return();
2692 PL_curpm = newpm;
2693 LEAVE;
2694 PERL_UNUSED_VAR(newsp);
2695 PERL_UNUSED_VAR(gimme);
2696 PERL_UNUSED_VAR(optype);
2697 }
2698 JMPENV_POP;
2699 }
2700
2701 if (flags & G_DISCARD) {
2702 PL_stack_sp = PL_stack_base + oldmark;
2703 retval = 0;
2704 FREETMPS;
2705 LEAVE;
2706 }
2707 PL_op = oldop;
2708 return retval;
2709 }
2710
2711 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2712 STATIC void *
2713 S_vcall_body(pTHX_ va_list args)
2714 {
2715 OP *myop = va_arg(args, OP*);
2716 int is_eval = va_arg(args, int);
2717
2718 call_body(myop, is_eval);
2719 return NULL;
2720 }
2721 #endif
2722
2723 STATIC void
2724 S_call_body(pTHX_ const OP *myop, bool is_eval)
2725 {
2726 if (PL_op == myop) {
2727 if (is_eval)
2728 PL_op = Perl_pp_entereval(aTHX); /* this doesn't do a POPMARK */
2729 else
2730 PL_op = Perl_pp_entersub(aTHX); /* this does */
2731 }
2732 if (PL_op)
2733 CALLRUNOPS(aTHX);
2734 }
2735
2736 /* Eval a string. The G_EVAL flag is always assumed. */
2737
2738 /*
2739 =for apidoc p||eval_sv
2740
2741 Tells Perl to C<eval> the string in the SV.
2742
2743 =cut
2744 */
2745
2746 I32
2747 Perl_eval_sv(pTHX_ SV *sv, I32 flags)
2748
2749 /* See G_* flags in cop.h */
2750 {
2751 dSP;
2752 UNOP myop; /* fake syntax tree node */
2753 volatile I32 oldmark = SP - PL_stack_base;
2754 volatile I32 retval = 0;
2755 int ret;
2756 OP* oldop = PL_op;
2757 dJMPENV;
2758
2759 if (flags & G_DISCARD) {
2760 ENTER;
2761 SAVETMPS;
2762 }
2763
2764 SAVEOP();
2765 PL_op = (OP*)&myop;
2766 Zero(PL_op, 1, UNOP);
2767 EXTEND(PL_stack_sp, 1);
2768 *++PL_stack_sp = sv;
2769
2770 if (!(flags & G_NOARGS))
2771 myop.op_flags = OPf_STACKED;
2772 myop.op_next = Nullop;
2773 myop.op_type = OP_ENTEREVAL;
2774 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
2775 (flags & G_ARRAY) ? OPf_WANT_LIST :
2776 OPf_WANT_SCALAR);
2777 if (flags & G_KEEPERR)
2778 myop.op_flags |= OPf_SPECIAL;
2779
2780 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2781 redo_body:
2782 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_body),
2783 (OP*)&myop, TRUE);
2784 #else
2785 /* fail now; otherwise we could fail after the JMPENV_PUSH but
2786 * before a PUSHEVAL, which corrupts the stack after a croak */
2787 TAINT_PROPER("eval_sv()");
2788
2789 JMPENV_PUSH(ret);
2790 #endif
2791 switch (ret) {
2792 case 0:
2793 #ifndef PERL_FLEXIBLE_EXCEPTIONS
2794 redo_body:
2795 call_body((OP*)&myop,TRUE);
2796 #endif
2797 retval = PL_stack_sp - (PL_stack_base + oldmark);
2798 if (!(flags & G_KEEPERR))
2799 sv_setpvn(ERRSV,"",0);
2800 break;
2801 case 1:
2802 STATUS_ALL_FAILURE;
2803 /* FALL THROUGH */
2804 case 2:
2805 /* my_exit() was called */
2806 PL_curstash = PL_defstash;
2807 FREETMPS;
2808 JMPENV_POP;
2809 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
2810 Perl_croak(aTHX_ "Callback called exit");
2811 my_exit_jump();
2812 /* NOTREACHED */
2813 case 3:
2814 if (PL_restartop) {
2815 PL_op = PL_restartop;
2816 PL_restartop = 0;
2817 goto redo_body;
2818 }
2819 PL_stack_sp = PL_stack_base + oldmark;
2820 if (flags & G_ARRAY)
2821 retval = 0;
2822 else {
2823 retval = 1;
2824 *++PL_stack_sp = &PL_sv_undef;
2825 }
2826 break;
2827 }
2828
2829 JMPENV_POP;
2830 if (flags & G_DISCARD) {
2831 PL_stack_sp = PL_stack_base + oldmark;
2832 retval = 0;
2833 FREETMPS;
2834 LEAVE;
2835 }
2836 PL_op = oldop;
2837 return retval;
2838 }
2839
2840 /*
2841 =for apidoc p||eval_pv
2842
2843 Tells Perl to C<eval> the given string and return an SV* result.
2844
2845 =cut
2846 */
2847
2848 SV*
2849 Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
2850 {
2851 dSP;
2852 SV* sv = newSVpv(p, 0);
2853
2854 eval_sv(sv, G_SCALAR);
2855 SvREFCNT_dec(sv);
2856
2857 SPAGAIN;
2858 sv = POPs;
2859 PUTBACK;
2860
2861 if (croak_on_error && SvTRUE(ERRSV)) {
2862 Perl_croak(aTHX_ SvPVx_nolen_const(ERRSV));
2863 }
2864
2865 return sv;
2866 }
2867
2868 /* Require a module. */
2869
2870 /*
2871 =head1 Embedding Functions
2872
2873 =for apidoc p||require_pv
2874
2875 Tells Perl to C<require> the file named by the string argument. It is
2876 analogous to the Perl code C<eval "require '$file'">. It's even
2877 implemented that way; consider using load_module instead.
2878
2879 =cut */
2880
2881 void
2882 Perl_require_pv(pTHX_ const char *pv)
2883 {
2884 SV* sv;
2885 dSP;
2886 PUSHSTACKi(PERLSI_REQUIRE);
2887 PUTBACK;
2888 sv = Perl_newSVpvf(aTHX_ "require q%c%s%c", 0, pv, 0);
2889 eval_sv(sv_2mortal(sv), G_DISCARD);
2890 SPAGAIN;
2891 POPSTACK;
2892 }
2893
2894 void
2895 Perl_magicname(pTHX_ char *sym, char *name, I32 namlen)
2896 {
2897 register GV *gv;
2898
2899 if ((gv = gv_fetchpv(sym,TRUE, SVt_PV)))
2900 sv_magic(GvSV(gv), (SV*)gv, PERL_MAGIC_sv, name, namlen);
2901 }
2902
2903 STATIC void
2904 S_usage(pTHX_ const char *name) /* XXX move this out into a module ? */
2905 {
2906 /* This message really ought to be max 23 lines.
2907 * Removed -h because the user already knows that option. Others? */
2908
2909 static const char * const usage_msg[] = {
2910 "-0[octal] specify record separator (\\0, if no argument)",
2911 "-a autosplit mode with -n or -p (splits $_ into @F)",
2912 "-C[number/list] enables the listed Unicode features",
2913 "-c check syntax only (runs BEGIN and CHECK blocks)",
2914 "-d[:debugger] run program under debugger",
2915 "-D[number/list] set debugging flags (argument is a bit mask or alphabets)",
2916 "-e program one line of program (several -e's allowed, omit programfile)",
2917 "-f don't do $sitelib/sitecustomize.pl at startup",
2918 "-F/pattern/ split() pattern for -a switch (//'s are optional)",
2919 "-i[extension] edit <> files in place (makes backup if extension supplied)",
2920 "-Idirectory specify @INC/#include directory (several -I's allowed)",
2921 "-l[octal] enable line ending processing, specifies line terminator",
2922 "-[mM][-]module execute \"use/no module...\" before executing program",
2923 "-n assume \"while (<>) { ... }\" loop around program",
2924 "-p assume loop like -n but print line also, like sed",
2925 "-P run program through C preprocessor before compilation",
2926 "-s enable rudimentary parsing for switches after programfile",
2927 "-S look for programfile using PATH environment variable",
2928 "-t enable tainting warnings",
2929 "-T enable tainting checks",
2930 "-u dump core after parsing program",
2931 "-U allow unsafe operations",
2932 "-v print version, subversion (includes VERY IMPORTANT perl info)",
2933 "-V[:variable] print configuration summary (or a single Config.pm variable)",
2934 "-w enable many useful warnings (RECOMMENDED)",
2935 "-W enable all warnings",
2936 "-x[directory] strip off text before #!perl line and perhaps cd to directory",
2937 "-X disable all warnings",
2938 "\n",
2939 NULL
2940 };
2941 const char * const *p = usage_msg;
2942
2943 PerlIO_printf(PerlIO_stdout(),
2944 "\nUsage: %s [switches] [--] [programfile] [arguments]",
2945 name);
2946 while (*p)
2947 PerlIO_printf(PerlIO_stdout(), "\n %s", *p++);
2948 }
2949
2950 /* convert a string of -D options (or digits) into an int.
2951 * sets *s to point to the char after the options */
2952
2953 #ifdef DEBUGGING
2954 int
2955 Perl_get_debug_opts(pTHX_ char **s)
2956 {
2957 return get_debug_opts_flags(s, 1);
2958 }
2959
2960 int
2961 Perl_get_debug_opts_flags(pTHX_ char **s, int flags)
2962 {
2963 static const char * const usage_msgd[] = {
2964 " Debugging flag values: (see also -d)",
2965 " p Tokenizing and parsing (with v, displays parse stack)",
2966 " s Stack snapshots (with v, displays all stacks)",
2967 " l Context (loop) stack processing",
2968 " t Trace execution",
2969 " o Method and overloading resolution",
2970 " c String/numeric conversions",
2971 " P Print profiling info, preprocessor command for -P, source file input state",
2972 " m Memory allocation",
2973 " f Format processing",
2974 " r Regular expression parsing and execution",
2975 " x Syntax tree dump",
2976 " u Tainting checks",
2977 " H Hash dump -- usurps values()",
2978 " X Scratchpad allocation",
2979 " D Cleaning up",
2980 " S Thread synchronization",
2981 " T Tokenising",
2982 " R Include reference counts of dumped variables (eg when using -Ds)",
2983 " J Do not s,t,P-debug (Jump over) opcodes within package DB",
2984 " v Verbose: use in conjunction with other flags",
2985 " C Copy On Write",
2986 " A Consistency checks on internal structures",
2987 " q quiet - currently only suppresses the 'EXECUTING' message",
2988 NULL
2989 };
2990 int i = 0;
2991 if (isALPHA(**s)) {
2992 /* if adding extra options, remember to update DEBUG_MASK */
2993 static const char debopts[] = "psltocPmfrxu HXDSTRJvC";
2994
2995 for (; isALNUM(**s); (*s)++) {
2996 const char *d = strchr(debopts,**s);
2997 if (d)
2998 i |= 1 << (d - debopts);
2999 else if (ckWARN_d(WARN_DEBUGGING))
3000 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
3001 "invalid option -D%c, use -D'' to see choices\n", **s);
3002 }
3003 }
3004 else if (isDIGIT(**s)) {
3005 i = atoi(*s);
3006 for (; isALNUM(**s); (*s)++) ;
3007 }
3008 else if (flags & 1) {
3009 /* Give help. */
3010 const char *const *p = usage_msgd;
3011 while (*p) PerlIO_printf(PerlIO_stdout(), "%s\n", *p++);
3012 }
3013 # ifdef EBCDIC
3014 if ((i & DEBUG_p_FLAG) && ckWARN_d(WARN_DEBUGGING))
3015 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
3016 "-Dp not implemented on this platform\n");
3017 # endif
3018 return i;
3019 }
3020 #endif
3021
3022 /* This routine handles any switches that can be given during run */
3023
3024 char *
3025 Perl_moreswitches(pTHX_ char *s)
3026 {
3027 UV rschar;
3028
3029 switch (*s) {
3030 case '0':
3031 {
3032 I32 flags = 0;
3033 STRLEN numlen;
3034
3035 SvREFCNT_dec(PL_rs);
3036 if (s[1] == 'x' && s[2]) {
3037 const char *e = s+=2;
3038 U8 *tmps;
3039
3040 while (*e)
3041 e++;
3042 numlen = e - s;
3043 flags = PERL_SCAN_SILENT_ILLDIGIT;
3044 rschar = (U32)grok_hex(s, &numlen, &flags, NULL);
3045 if (s + numlen < e) {
3046 rschar = 0; /* Grandfather -0xFOO as -0 -xFOO. */
3047 numlen = 0;
3048 s--;
3049 }
3050 PL_rs = newSVpvn("", 0);
3051 SvGROW(PL_rs, (STRLEN)(UNISKIP(rschar) + 1));
3052 tmps = (U8*)SvPVX(PL_rs);
3053 uvchr_to_utf8(tmps, rschar);
3054 SvCUR_set(PL_rs, UNISKIP(rschar));
3055 SvUTF8_on(PL_rs);
3056 }
3057 else {
3058 numlen = 4;
3059 rschar = (U32)grok_oct(s, &numlen, &flags, NULL);
3060 if (rschar & ~((U8)~0))
3061 PL_rs = &PL_sv_undef;
3062 else if (!rschar && numlen >= 2)
3063 PL_rs = newSVpvn("", 0);
3064 else {
3065 char ch = (char)rschar;
3066 PL_rs = newSVpvn(&ch, 1);
3067 }
3068 }
3069 sv_setsv(get_sv("/", TRUE), PL_rs);
3070 return s + numlen;
3071 }
3072 case 'C':
3073 s++;
3074 PL_unicode = parse_unicode_opts(&s);
3075 return s;
3076 case 'F':
3077 PL_minus_F = TRUE;
3078 PL_splitstr = ++s;
3079 while (*s && !isSPACE(*s)) ++s;
3080 *s = '\0';
3081 PL_splitstr = savepv(PL_splitstr);
3082 return s;
3083 case 'a':
3084 PL_minus_a = TRUE;
3085 s++;
3086 return s;
3087 case 'c':
3088 PL_minus_c = TRUE;
3089 s++;
3090 return s;
3091 case 'd':
3092 forbid_setid("-d");
3093 s++;
3094
3095 /* -dt indicates to the debugger that threads will be used */
3096 if (*s == 't' && !isALNUM(s[1])) {
3097 ++s;
3098 my_setenv("PERL5DB_THREADED", "1");
3099 }
3100
3101 /* The following permits -d:Mod to accepts arguments following an =
3102 in the fashion that -MSome::Mod does. */
3103 if (*s == ':' || *s == '=') {
3104 const char *start;
3105 SV *sv;
3106 sv = newSVpv("use Devel::", 0);
3107 start = ++s;
3108 /* We now allow -d:Module=Foo,Bar */
3109 while(isALNUM(*s) || *s==':') ++s;
3110 if (*s != '=')
3111 sv_catpv(sv, start);
3112 else {
3113 sv_catpvn(sv, start, s-start);
3114 Perl_sv_catpvf(aTHX_ sv, " split(/,/,q%c%s%c)", 0, ++s, 0);
3115 }
3116 s += strlen(s);
3117 my_setenv("PERL5DB", (char *)SvPV_nolen_const(sv));
3118 }
3119 if (!PL_perldb) {
3120 PL_perldb = PERLDB_ALL;
3121 init_debugger();
3122 }
3123 return s;
3124 case 'D':
3125 {
3126 #ifdef DEBUGGING
3127 forbid_setid("-D");
3128 s++;
3129 PL_debug = get_debug_opts_flags( &s, 1) | DEBUG_TOP_FLAG;
3130 #else /* !DEBUGGING */
3131 if (ckWARN_d(WARN_DEBUGGING))
3132 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
3133 "Recompile perl with -DDEBUGGING to use -D switch (did you mean -d ?)\n");
3134 for (s++; isALNUM(*s); s++) ;
3135 #endif
3136 return s;
3137 }
3138 case 'h':
3139 usage(PL_origargv[0]);
3140 my_exit(0);
3141 case 'i':
3142 Safefree(PL_inplace);
3143 #if defined(__CYGWIN__) /* do backup extension automagically */
3144 if (*(s+1) == '\0') {
3145 PL_inplace = savepv(".bak");
3146 return s+1;
3147 }
3148 #endif /* __CYGWIN__ */
3149 PL_inplace = savepv(s+1);
3150 for (s = PL_inplace; *s && !isSPACE(*s); s++)
3151 ;
3152 if (*s) {
3153 *s++ = '\0';
3154 if (*s == '-') /* Additional switches on #! line. */
3155 s++;
3156 }
3157 return s;
3158 case 'I': /* -I handled both here and in parse_body() */
3159 forbid_setid("-I");
3160 ++s;
3161 while (*s && isSPACE(*s))
3162 ++s;
3163 if (*s) {
3164 char *e, *p;
3165 p = s;
3166 /* ignore trailing spaces (possibly followed by other switches) */
3167 do {
3168 for (e = p; *e && !isSPACE(*e); e++) ;
3169 p = e;
3170 while (isSPACE(*p))
3171 p++;
3172 } while (*p && *p != '-');
3173 e = savepvn(s, e-s);
3174 incpush(e, TRUE, TRUE, FALSE);
3175 Safefree(e);
3176 s = p;
3177 if (*s == '-')
3178 s++;
3179 }
3180 else
3181 Perl_croak(aTHX_ "No directory specified for -I");
3182 return s;
3183 case 'l':
3184 PL_minus_l = TRUE;
3185 s++;
3186 if (PL_ors_sv) {
3187 SvREFCNT_dec(PL_ors_sv);
3188 PL_ors_sv = Nullsv;
3189 }
3190 if (isDIGIT(*s)) {
3191 I32 flags = 0;
3192 STRLEN numlen;
3193 PL_ors_sv = newSVpvn("\n",1);
3194 numlen = 3 + (*s == '0');
3195 *SvPVX(PL_ors_sv) = (char)grok_oct(s, &numlen, &flags, NULL);
3196 s += numlen;
3197 }
3198 else {
3199 if (RsPARA(PL_rs)) {
3200 PL_ors_sv = newSVpvn("\n\n",2);
3201 }
3202 else {
3203 PL_ors_sv = newSVsv(PL_rs);
3204 }
3205 }
3206 return s;
3207 case 'M':
3208 forbid_setid("-M"); /* XXX ? */
3209 /* FALL THROUGH */
3210 case 'm':
3211 forbid_setid("-m"); /* XXX ? */
3212 if (*++s) {
3213 char *start;
3214 SV *sv;
3215 const char *use = "use ";
3216 /* -M-foo == 'no foo' */
3217 /* Leading space on " no " is deliberate, to make both
3218 possibilities the same length. */
3219 if (*s == '-') { use = " no "; ++s; }
3220 sv = newSVpvn(use,4);
3221 start = s;
3222 /* We allow -M'Module qw(Foo Bar)' */
3223 while(isALNUM(*s) || *s==':') ++s;
3224 if (*s != '=') {
3225 sv_catpv(sv, start);
3226 if (*(start-1) == 'm') {
3227 if (*s != '\0')
3228 Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
3229 sv_catpv( sv, " ()");
3230 }
3231 } else {
3232 if (s == start)
3233 Perl_croak(aTHX_ "Module name required with -%c option",
3234 s[-1]);
3235 sv_catpvn(sv, start, s-start);
3236 sv_catpv(sv, " split(/,/,q");
3237 sv_catpvn(sv, "\0)", 1); /* Use NUL as q//-delimiter. */
3238 sv_catpv(sv, ++s);
3239 sv_catpvn(sv, "\0)", 2);
3240 }
3241 s += strlen(s);
3242 if (!PL_preambleav)
3243 PL_preambleav = newAV();
3244 av_push(PL_preambleav, sv);
3245 }
3246 else
3247 Perl_croak(aTHX_ "Missing argument to -%c", *(s-1));
3248 return s;
3249 case 'n':
3250 PL_minus_n = TRUE;
3251 s++;
3252 return s;
3253 case 'p':
3254 PL_minus_p = TRUE;
3255 s++;
3256 return s;
3257 case 's':
3258 forbid_setid("-s");
3259 PL_doswitches = TRUE;
3260 s++;
3261 return s;
3262 case 't':
3263 if (!PL_tainting)
3264 TOO_LATE_FOR('t');
3265 s++;
3266 return s;
3267 case 'T':
3268 if (!PL_tainting)
3269 TOO_LATE_FOR('T');
3270 s++;
3271 return s;
3272 case 'u':
3273 #ifdef MACOS_TRADITIONAL
3274 Perl_croak(aTHX_ "Believe me, you don't want to use \"-u\" on a Macintosh");
3275 #endif
3276 PL_do_undump = TRUE;
3277 s++;
3278 return s;
3279 case 'U':
3280 PL_unsafe = TRUE;
3281 s++;
3282 return s;
3283 case 'v':
3284 #if !defined(DGUX)
3285 PerlIO_printf(PerlIO_stdout(),
3286 Perl_form(aTHX_ "\nThis is perl, v%"VDf" built for %s",
3287 PL_patchlevel, ARCHNAME));
3288 #else /* DGUX */
3289 /* Adjust verbose output as in the perl that ships with the DG/UX OS from EMC */
3290 PerlIO_printf(PerlIO_stdout(),
3291 Perl_form(aTHX_ "\nThis is perl, version %vd\n", PL_patchlevel));
3292 PerlIO_printf(PerlIO_stdout(),
3293 Perl_form(aTHX_ " built under %s at %s %s\n",
3294 OSNAME, __DATE__, __TIME__));
3295 PerlIO_printf(PerlIO_stdout(),
3296 Perl_form(aTHX_ " OS Specific Release: %s\n",
3297 OSVERS));
3298 #endif /* !DGUX */
3299
3300 #if defined(LOCAL_PATCH_COUNT)
3301 if (LOCAL_PATCH_COUNT > 0)
3302 PerlIO_printf(PerlIO_stdout(),
3303 "\n(with %d registered patch%s, "
3304 "see perl -V for more detail)",
3305 (int)LOCAL_PATCH_COUNT,
3306 (LOCAL_PATCH_COUNT!=1) ? "es" : "");
3307 #endif
3308
3309 PerlIO_printf(PerlIO_stdout(),
3310 "\n\nCopyright 1987-2006, Larry Wall\n");
3311 #ifdef MACOS_TRADITIONAL
3312 PerlIO_printf(PerlIO_stdout(),
3313 "\nMac OS port Copyright 1991-2002, Matthias Neeracher;\n"
3314 "maintained by Chris Nandor\n");
3315 #endif
3316 #ifdef MSDOS
3317 PerlIO_printf(PerlIO_stdout(),
3318 "\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
3319 #endif
3320 #ifdef DJGPP
3321 PerlIO_printf(PerlIO_stdout(),
3322 "djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n"
3323 "djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
3324 #endif
3325 #ifdef OS2
3326 PerlIO_printf(PerlIO_stdout(),
3327 "\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
3328 "Version 5 port Copyright (c) 1994-2002, Andreas Kaiser, Ilya Zakharevich\n");
3329 #endif
3330 #ifdef atarist
3331 PerlIO_printf(PerlIO_stdout(),
3332 "atariST series port, ++jrb bammi@cadence.com\n");
3333 #endif
3334 #ifdef __BEOS__
3335 PerlIO_printf(PerlIO_stdout(),
3336 "BeOS port Copyright Tom Spindler, 1997-1999\n");
3337 #endif
3338 #ifdef MPE
3339 PerlIO_printf(PerlIO_stdout(),
3340 "MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-2003\n");
3341 #endif
3342 #ifdef OEMVS
3343 PerlIO_printf(PerlIO_stdout(),
3344 "MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
3345 #endif
3346 #ifdef __VOS__
3347 PerlIO_printf(PerlIO_stdout(),
3348 "Stratus VOS port by Paul.Green@stratus.com, 1997-2002\n");
3349 #endif
3350 #ifdef __OPEN_VM
3351 PerlIO_printf(PerlIO_stdout(),
3352 "VM/ESA port by Neale Ferguson, 1998-1999\n");
3353 #endif
3354 #ifdef POSIX_BC
3355 PerlIO_printf(PerlIO_stdout(),
3356 "BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
3357 #endif
3358 #ifdef __MINT__
3359 PerlIO_printf(PerlIO_stdout(),
3360 "MiNT port by Guido Flohr, 1997-1999\n");
3361 #endif
3362 #ifdef EPOC
3363 PerlIO_printf(PerlIO_stdout(),
3364 "EPOC port by Olaf Flebbe, 1999-2002\n");
3365 #endif
3366 #ifdef UNDER_CE
3367 PerlIO_printf(PerlIO_stdout(),"WINCE port by Rainer Keuchel, 2001-2002\n");
3368 PerlIO_printf(PerlIO_stdout(),"Built on " __DATE__ " " __TIME__ "\n\n");
3369 wce_hitreturn();
3370 #endif
3371 #ifdef BINARY_BUILD_NOTICE
3372 BINARY_BUILD_NOTICE;
3373 #endif
3374 PerlIO_printf(PerlIO_stdout(),
3375 "\n\
3376 Perl may be copied only under the terms of either the Artistic License or the\n\
3377 GNU General Public License, which may be found in the Perl 5 source kit.\n\n\
3378 Complete documentation for Perl, including FAQ lists, should be found on\n\
3379 this system using \"man perl\" or \"perldoc perl\". If you have access to the\n\
3380 Internet, point your browser at http://www.perl.org/, the Perl Home Page.\n\n");
3381 my_exit(0);
3382 case 'w':
3383 if (! (PL_dowarn & G_WARN_ALL_MASK))
3384 PL_dowarn |= G_WARN_ON;
3385 s++;
3386 return s;
3387 case 'W':
3388 PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
3389 if (!specialWARN(PL_compiling.cop_warnings))
3390 SvREFCNT_dec(PL_compiling.cop_warnings);
3391 PL_compiling.cop_warnings = pWARN_ALL ;
3392 s++;
3393 return s;
3394 case 'X':
3395 PL_dowarn = G_WARN_ALL_OFF;
3396 if (!specialWARN(PL_compiling.cop_warnings))
3397 SvREFCNT_dec(PL_compiling.cop_warnings);
3398 PL_compiling.cop_warnings = pWARN_NONE ;
3399 s++;
3400 return s;
3401 case '*':
3402 case ' ':
3403 if (s[1] == '-') /* Additional switches on #! line. */
3404 return s+2;
3405 break;
3406 case '-':
3407 case 0:
3408 #if defined(WIN32) || !defined(PERL_STRICT_CR)
3409 case '\r':
3410 #endif
3411 case '\n':
3412 case '\t':
3413 break;
3414 #ifdef ALTERNATE_SHEBANG
3415 case 'S': /* OS/2 needs -S on "extproc" line. */
3416 break;
3417 #endif
3418 case 'P':
3419 if (PL_preprocess)
3420 return s+1;
3421 /* FALL THROUGH */
3422 default:
3423 Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
3424 }
3425 return Nullch;
3426 }
3427
3428 /* compliments of Tom Christiansen */
3429
3430 /* unexec() can be found in the Gnu emacs distribution */
3431 /* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
3432
3433 void
3434 Perl_my_unexec(pTHX)
3435 {
3436 #ifdef UNEXEC
3437 SV* prog;
3438 SV* file;
3439 int status = 1;
3440 extern int etext;
3441
3442 prog = newSVpv(BIN_EXP, 0);
3443 sv_catpv(prog, "/perl");
3444 file = newSVpv(PL_origfilename, 0);
3445 sv_catpv(file, ".perldump");
3446
3447 unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
3448 /* unexec prints msg to stderr in case of failure */
3449 PerlProc_exit(status);
3450 #else
3451 # ifdef VMS
3452 # include <lib$routines.h>
3453 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
3454 # else
3455 ABORT(); /* for use with undump */
3456 # endif
3457 #endif
3458 }
3459
3460 /* initialize curinterp */
3461 STATIC void
3462 S_init_interp(pTHX)
3463 {
3464
3465 #ifdef MULTIPLICITY
3466 # define PERLVAR(var,type)
3467 # define PERLVARA(var,n,type)
3468 # if defined(PERL_IMPLICIT_CONTEXT)
3469 # if defined(USE_5005THREADS)
3470 # define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
3471 # define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
3472 # else /* !USE_5005THREADS */
3473 # define PERLVARI(var,type,init) aTHX->var = init;
3474 # define PERLVARIC(var,type,init) aTHX->var = init;
3475 # endif /* USE_5005THREADS */
3476 # else
3477 # define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
3478 # define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
3479 # endif
3480 # include "intrpvar.h"
3481 # ifndef USE_5005THREADS
3482 # include "thrdvar.h"
3483 # endif
3484 # undef PERLVAR
3485 # undef PERLVARA
3486 # undef PERLVARI
3487 # undef PERLVARIC
3488 #else
3489 # define PERLVAR(var,type)
3490 # define PERLVARA(var,n,type)
3491 # define PERLVARI(var,type,init) PL_##var = init;
3492 # define PERLVARIC(var,type,init) PL_##var = init;
3493 # include "intrpvar.h"
3494 # ifndef USE_5005THREADS
3495 # include "thrdvar.h"
3496 # endif
3497 # undef PERLVAR
3498 # undef PERLVARA
3499 # undef PERLVARI
3500 # undef PERLVARIC
3501 #endif
3502
3503 }
3504
3505 STATIC void
3506 S_init_main_stash(pTHX)
3507 {
3508 GV *gv;
3509
3510 PL_curstash = PL_defstash = newHV();
3511 PL_curstname = newSVpvn("main",4);
3512 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
3513 SvREFCNT_dec(GvHV(gv));
3514 GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash);
3515 SvREADONLY_on(gv);
3516 hv_name_set(PL_defstash, "main", 4, 0);
3517 PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
3518 GvMULTI_on(PL_incgv);
3519 PL_hintgv = gv_fetchpv("\010",TRUE, SVt_PV); /* ^H */
3520 GvMULTI_on(PL_hintgv);
3521 PL_defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
3522 PL_errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
3523 GvMULTI_on(PL_errgv);
3524 PL_replgv = gv_fetchpv("\022", TRUE, SVt_PV); /* ^R */
3525 GvMULTI_on(PL_replgv);
3526 (void)Perl_form(aTHX_ "%240s",""); /* Preallocate temp - for immediate signals. */
3527 #ifdef PERL_DONT_CREATE_GVSV
3528 gv_SVadd(PL_errgv);
3529 #endif
3530 sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
3531 sv_setpvn(ERRSV, "", 0);
3532 PL_curstash = PL_defstash;
3533 CopSTASH_set(&PL_compiling, PL_defstash);
3534 PL_debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
3535 PL_globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
3536 PL_nullstash = GvHV(gv_fetchpv("<none>::", GV_ADDMULTI, SVt_PVHV));
3537 /* We must init $/ before switches are processed. */
3538 sv_setpvn(get_sv("/", TRUE), "\n", 1);
3539 }
3540
3541 /* PSz 18 Nov 03 fdscript now global but do not change prototype */
3542 STATIC void
3543 S_open_script(pTHX_ const char *scriptname, bool dosearch, SV *sv)
3544 {
3545 #ifndef IAMSUID
3546 const char *quote;
3547 const char *code;
3548 const char *cpp_discard_flag;
3549 const char *perl;
3550 #endif
3551
3552 PL_fdscript = -1;
3553 PL_suidscript = -1;
3554
3555 if (PL_e_script) {
3556 PL_origfilename = savepv("-e");
3557 }
3558 else {
3559 /* if find_script() returns, it returns a malloc()-ed value */
3560 scriptname = PL_origfilename = find_script((char *)scriptname, dosearch, NULL, 1);
3561
3562 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
3563 const char *s = scriptname + 8;
3564 PL_fdscript = atoi(s);
3565 while (isDIGIT(*s))
3566 s++;
3567 if (*s) {
3568 /* PSz 18 Feb 04
3569 * Tell apart "normal" usage of fdscript, e.g.
3570 * with bash on FreeBSD:
3571 * perl <( echo '#!perl -DA'; echo 'print "$0\n"')
3572 * from usage in suidperl.
3573 * Does any "normal" usage leave garbage after the number???
3574 * Is it a mistake to use a similar /dev/fd/ construct for
3575 * suidperl?
3576 */
3577 PL_suidscript = 1;
3578 /* PSz 20 Feb 04
3579 * Be supersafe and do some sanity-checks.
3580 * Still, can we be sure we got the right thing?
3581 */
3582 if (*s != '/') {
3583 Perl_croak(aTHX_ "Wrong syntax (suid) fd script name \"%s\"\n", s);
3584 }
3585 if (! *(s+1)) {
3586 Perl_croak(aTHX_ "Missing (suid) fd script name\n");
3587 }
3588 scriptname = savepv(s + 1);
3589 Safefree(PL_origfilename);
3590 PL_origfilename = (char *)scriptname;
3591 }
3592 }
3593 }
3594
3595 CopFILE_free(PL_curcop);
3596 CopFILE_set(PL_curcop, PL_origfilename);
3597 if (*PL_origfilename == '-' && PL_origfilename[1] == '\0')
3598 scriptname = (char *)"";
3599 if (PL_fdscript >= 0) {
3600 PL_rsfp = PerlIO_fdopen(PL_fdscript,PERL_SCRIPT_MODE);
3601 # if defined(HAS_FCNTL) && defined(F_SETFD)
3602 if (PL_rsfp)
3603 /* ensure close-on-exec */
3604 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);
3605 # endif
3606 }
3607 #ifdef IAMSUID
3608 else {
3609 Perl_croak(aTHX_ "sperl needs fd script\n"
3610 "You should not call sperl directly; do you need to "
3611 "change a #! line\nfrom sperl to perl?\n");
3612
3613 /* PSz 11 Nov 03
3614 * Do not open (or do other fancy stuff) while setuid.
3615 * Perl does the open, and hands script to suidperl on a fd;
3616 * suidperl only does some checks, sets up UIDs and re-execs
3617 * perl with that fd as it has always done.
3618 */
3619 }
3620 if (PL_suidscript != 1) {
3621 Perl_croak(aTHX_ "suidperl needs (suid) fd script\n");
3622 }
3623 #else /* IAMSUID */
3624 else if (PL_preprocess) {
3625 const char *cpp_cfg = CPPSTDIN;
3626 SV *cpp = newSVpvn("",0);
3627 SV *cmd = NEWSV(0,0);
3628
3629 if (cpp_cfg[0] == 0) /* PERL_MICRO? */
3630 Perl_croak(aTHX_ "Can't run with cpp -P with CPPSTDIN undefined");
3631 if (strEQ(cpp_cfg, "cppstdin"))
3632 Perl_sv_catpvf(aTHX_ cpp, "%s/", BIN_EXP);
3633 sv_catpv(cpp, cpp_cfg);
3634
3635 # ifndef VMS
3636 sv_catpvn(sv, "-I", 2);
3637 sv_catpv(sv,PRIVLIB_EXP);
3638 # endif
3639
3640 DEBUG_P(PerlIO_printf(Perl_debug_log,
3641 "PL_preprocess: scriptname=\"%s\", cpp=\"%s\", sv=\"%s\", CPPMINUS=\"%s\"\n",
3642 scriptname, SvPVX_const (cpp), SvPVX_const (sv),
3643 CPPMINUS));
3644
3645 # if defined(MSDOS) || defined(WIN32) || defined(VMS)
3646 quote = "\"";
3647 # else
3648 quote = "'";
3649 # endif
3650
3651 # ifdef VMS
3652 cpp_discard_flag = "";
3653 # else
3654 cpp_discard_flag = "-C";
3655 # endif
3656
3657 # ifdef OS2
3658 perl = os2_execname(aTHX);
3659 # else
3660 perl = PL_origargv[0];
3661 # endif
3662
3663
3664 /* This strips off Perl comments which might interfere with
3665 the C pre-processor, including #!. #line directives are
3666 deliberately stripped to avoid confusion with Perl's version
3667 of #line. FWP played some golf with it so it will fit
3668 into VMS's 255 character buffer.
3669 */
3670 if( PL_doextract )
3671 code = "(1../^#!.*perl/i)|/^\\s*#(?!\\s*((ifn?|un)def|(el|end)?if|define|include|else|error|pragma)\\b)/||!($|=1)||print";
3672 else
3673 code = "/^\\s*#(?!\\s*((ifn?|un)def|(el|end)?if|define|include|else|error|pragma)\\b)/||!($|=1)||print";
3674
3675 Perl_sv_setpvf(aTHX_ cmd, "\
3676 %s -ne%s%s%s %s | %"SVf" %s %"SVf" %s",
3677 perl, quote, code, quote, scriptname, cpp,
3678 cpp_discard_flag, sv, CPPMINUS);
3679
3680 PL_doextract = FALSE;
3681
3682 DEBUG_P(PerlIO_printf(Perl_debug_log,
3683 "PL_preprocess: cmd=\"%s\"\n",
3684 SvPVX_const(cmd)));
3685
3686 PL_rsfp = PerlProc_popen((char *)SvPVX_const(cmd), (char *)"r");
3687 SvREFCNT_dec(cmd);
3688 SvREFCNT_dec(cpp);
3689 }
3690 else if (!*scriptname) {
3691 forbid_setid("program input from stdin");
3692 PL_rsfp = PerlIO_stdin();
3693 }
3694 else {
3695 PL_rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
3696 # if defined(HAS_FCNTL) && defined(F_SETFD)
3697 if (PL_rsfp)
3698 /* ensure close-on-exec */
3699 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);
3700 # endif
3701 }
3702 #endif /* IAMSUID */
3703 if (!PL_rsfp) {
3704 /* PSz 16 Sep 03 Keep neat error message */
3705 if (PL_e_script)
3706 Perl_croak(aTHX_ "Can't open "BIT_BUCKET": %s\n", Strerror(errno));
3707 else
3708 Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
3709 CopFILE(PL_curcop), Strerror(errno));
3710 }
3711 }
3712
3713 /* Mention
3714 * I_SYSSTATVFS HAS_FSTATVFS
3715 * I_SYSMOUNT
3716 * I_STATFS HAS_FSTATFS HAS_GETFSSTAT
3717 * I_MNTENT HAS_GETMNTENT HAS_HASMNTOPT
3718 * here so that metaconfig picks them up. */
3719
3720 #ifdef IAMSUID
3721 STATIC int
3722 S_fd_on_nosuid_fs(pTHX_ int fd)
3723 {
3724 /* PSz 27 Feb 04
3725 * We used to do this as "plain" user (after swapping UIDs with setreuid);
3726 * but is needed also on machines without setreuid.
3727 * Seems safe enough to run as root.
3728 */
3729 int check_okay = 0; /* able to do all the required sys/libcalls */
3730 int on_nosuid = 0; /* the fd is on a nosuid fs */
3731 /* PSz 12 Nov 03
3732 * Need to check noexec also: nosuid might not be set, the average
3733 * sysadmin would say that nosuid is irrelevant once he sets noexec.
3734 */
3735 int on_noexec = 0; /* the fd is on a noexec fs */
3736
3737 /*
3738 * Preferred order: fstatvfs(), fstatfs(), ustat()+getmnt(), getmntent().
3739 * fstatvfs() is UNIX98.
3740 * fstatfs() is 4.3 BSD.
3741 * ustat()+getmnt() is pre-4.3 BSD.
3742 * getmntent() is O(number-of-mounted-filesystems) and can hang on
3743 * an irrelevant filesystem while trying to reach the right one.
3744 */
3745
3746 #undef FD_ON_NOSUID_CHECK_OKAY /* found the syscalls to do the check? */
3747
3748 # if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
3749 defined(HAS_FSTATVFS)
3750 # define FD_ON_NOSUID_CHECK_OKAY
3751 struct statvfs stfs;
3752
3753 check_okay = fstatvfs(fd, &stfs) == 0;
3754 on_nosuid = check_okay && (stfs.f_flag & ST_NOSUID);
3755 #ifdef ST_NOEXEC
3756 /* ST_NOEXEC certainly absent on AIX 5.1, and doesn't seem to be documented
3757 on platforms where it is present. */
3758 on_noexec = check_okay && (stfs.f_flag & ST_NOEXEC);
3759 #endif
3760 # endif /* fstatvfs */
3761
3762 # if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
3763 defined(PERL_MOUNT_NOSUID) && \
3764 defined(PERL_MOUNT_NOEXEC) && \
3765 defined(HAS_FSTATFS) && \
3766 defined(HAS_STRUCT_STATFS) && \
3767 defined(HAS_STRUCT_STATFS_F_FLAGS)
3768 # define FD_ON_NOSUID_CHECK_OKAY
3769 struct statfs stfs;
3770
3771 check_okay = fstatfs(fd, &stfs) == 0;
3772 on_nosuid = check_okay && (stfs.f_flags & PERL_MOUNT_NOSUID);
3773 on_noexec = check_okay && (stfs.f_flags & PERL_MOUNT_NOEXEC);
3774 # endif /* fstatfs */
3775
3776 # if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
3777 defined(PERL_MOUNT_NOSUID) && \
3778 defined(PERL_MOUNT_NOEXEC) && \
3779 defined(HAS_FSTAT) && \
3780 defined(HAS_USTAT) && \
3781 defined(HAS_GETMNT) && \
3782 defined(HAS_STRUCT_FS_DATA) && \
3783 defined(NOSTAT_ONE)
3784 # define FD_ON_NOSUID_CHECK_OKAY
3785 Stat_t fdst;
3786
3787 if (fstat(fd, &fdst) == 0) {
3788 struct ustat us;
3789 if (ustat(fdst.st_dev, &us) == 0) {
3790 struct fs_data fsd;
3791 /* NOSTAT_ONE here because we're not examining fields which
3792 * vary between that case and STAT_ONE. */
3793 if (getmnt((int*)0, &fsd, (int)0, NOSTAT_ONE, us.f_fname) == 0) {
3794 size_t cmplen = sizeof(us.f_fname);
3795 if (sizeof(fsd.fd_req.path) < cmplen)
3796 cmplen = sizeof(fsd.fd_req.path);
3797 if (strnEQ(fsd.fd_req.path, us.f_fname, cmplen) &&
3798 fdst.st_dev == fsd.fd_req.dev) {
3799 check_okay = 1;
3800 on_nosuid = fsd.fd_req.flags & PERL_MOUNT_NOSUID;
3801 on_noexec = fsd.fd_req.flags & PERL_MOUNT_NOEXEC;
3802 }
3803 }
3804 }
3805 }
3806 # endif /* fstat+ustat+getmnt */
3807
3808 # if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
3809 defined(HAS_GETMNTENT) && \
3810 defined(HAS_HASMNTOPT) && \
3811 defined(MNTOPT_NOSUID) && \
3812 defined(MNTOPT_NOEXEC)
3813 # define FD_ON_NOSUID_CHECK_OKAY
3814 FILE *mtab = fopen("/etc/mtab", "r");
3815 struct mntent *entry;
3816 Stat_t stb, fsb;
3817
3818 if (mtab && (fstat(fd, &stb) == 0)) {
3819 while (entry = getmntent(mtab)) {
3820 if (stat(entry->mnt_dir, &fsb) == 0
3821 && fsb.st_dev == stb.st_dev)
3822 {
3823 /* found the filesystem */
3824 check_okay = 1;
3825 if (hasmntopt(entry, MNTOPT_NOSUID))
3826 on_nosuid = 1;
3827 if (hasmntopt(entry, MNTOPT_NOEXEC))
3828 on_noexec = 1;
3829 break;
3830 } /* A single fs may well fail its stat(). */
3831 }
3832 }
3833 if (mtab)
3834 fclose(mtab);
3835 # endif /* getmntent+hasmntopt */
3836
3837 if (!check_okay)
3838 Perl_croak(aTHX_ "Can't check filesystem of script \"%s\" for nosuid/noexec", PL_origfilename);
3839 if (on_nosuid)
3840 Perl_croak(aTHX_ "Setuid script \"%s\" on nosuid filesystem", PL_origfilename);
3841 if (on_noexec)
3842 Perl_croak(aTHX_ "Setuid script \"%s\" on noexec filesystem", PL_origfilename);
3843 return ((!check_okay) || on_nosuid || on_noexec);
3844 }
3845 #endif /* IAMSUID */
3846
3847 STATIC void
3848 S_validate_suid(pTHX_ const char *validarg, const char *scriptname)
3849 {
3850 #ifdef IAMSUID
3851 /* int which; */
3852 #endif /* IAMSUID */
3853
3854 /* do we need to emulate setuid on scripts? */
3855
3856 /* This code is for those BSD systems that have setuid #! scripts disabled
3857 * in the kernel because of a security problem. Merely defining DOSUID
3858 * in perl will not fix that problem, but if you have disabled setuid
3859 * scripts in the kernel, this will attempt to emulate setuid and setgid
3860 * on scripts that have those now-otherwise-useless bits set. The setuid
3861 * root version must be called suidperl or sperlN.NNN. If regular perl
3862 * discovers that it has opened a setuid script, it calls suidperl with
3863 * the same argv that it had. If suidperl finds that the script it has
3864 * just opened is NOT setuid root, it sets the effective uid back to the
3865 * uid. We don't just make perl setuid root because that loses the
3866 * effective uid we had before invoking perl, if it was different from the
3867 * uid.
3868 * PSz 27 Feb 04
3869 * Description/comments above do not match current workings:
3870 * suidperl must be hardlinked to sperlN.NNN (that is what we exec);
3871 * suidperl called with script open and name changed to /dev/fd/N/X;
3872 * suidperl croaks if script is not setuid;
3873 * making perl setuid would be a huge security risk (and yes, that
3874 * would lose any euid we might have had).
3875 *
3876 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
3877 * be defined in suidperl only. suidperl must be setuid root. The
3878 * Configure script will set this up for you if you want it.
3879 */
3880
3881 #ifdef DOSUID
3882 const char *s, *s2;
3883
3884 if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0) /* normal stat is insecure */
3885 Perl_croak(aTHX_ "Can't stat script \"%s\"",PL_origfilename);
3886 if (PL_statbuf.st_mode & (S_ISUID|S_ISGID)) {
3887 I32 len;
3888 const char *linestr;
3889
3890 #ifdef IAMSUID
3891 if (PL_fdscript < 0 || PL_suidscript != 1)
3892 Perl_croak(aTHX_ "Need (suid) fdscript in suidperl\n"); /* We already checked this */
3893 /* PSz 11 Nov 03
3894 * Since the script is opened by perl, not suidperl, some of these
3895 * checks are superfluous. Leaving them in probably does not lower
3896 * security(?!).
3897 */
3898 /* PSz 27 Feb 04
3899 * Do checks even for systems with no HAS_SETREUID.
3900 * We used to swap, then re-swap UIDs with
3901 #ifdef HAS_SETREUID
3902 if (setreuid(PL_euid,PL_uid) < 0
3903 || PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid)
3904 Perl_croak(aTHX_ "Can't swap uid and euid");
3905 #endif
3906 #ifdef HAS_SETREUID
3907 if (setreuid(PL_uid,PL_euid) < 0
3908 || PerlProc_getuid() != PL_uid || PerlProc_geteuid() != PL_euid)
3909 Perl_croak(aTHX_ "Can't reswap uid and euid");
3910 #endif
3911 */
3912
3913 /* On this access check to make sure the directories are readable,
3914 * there is actually a small window that the user could use to make
3915 * filename point to an accessible directory. So there is a faint
3916 * chance that someone could execute a setuid script down in a
3917 * non-accessible directory. I don't know what to do about that.
3918 * But I don't think it's too important. The manual lies when
3919 * it says access() is useful in setuid programs.
3920 *
3921 * So, access() is pretty useless... but not harmful... do anyway.
3922 */
3923 if (PerlLIO_access(CopFILE(PL_curcop),1)) { /*double check*/
3924 Perl_croak(aTHX_ "Can't access() script\n");
3925 }
3926
3927 /* If we can swap euid and uid, then we can determine access rights
3928 * with a simple stat of the file, and then compare device and
3929 * inode to make sure we did stat() on the same file we opened.
3930 * Then we just have to make sure he or she can execute it.
3931 *
3932 * PSz 24 Feb 04
3933 * As the script is opened by perl, not suidperl, we do not need to
3934 * care much about access rights.
3935 *
3936 * The 'script changed' check is needed, or we can get lied to
3937 * about $0 with e.g.
3938 * suidperl /dev/fd/4//bin/x 4<setuidscript
3939 * Without HAS_SETREUID, is it safe to stat() as root?
3940 *
3941 * Are there any operating systems that pass /dev/fd/xxx for setuid
3942 * scripts, as suggested/described in perlsec(1)? Surely they do not
3943 * pass the script name as we do, so the "script changed" test would
3944 * fail for them... but we never get here with
3945 * SETUID_SCRIPTS_ARE_SECURE_NOW defined.
3946 *
3947 * This is one place where we must "lie" about return status: not
3948 * say if the stat() failed. We are doing this as root, and could
3949 * be tricked into reporting existence or not of files that the
3950 * "plain" user cannot even see.
3951 */
3952 {
3953 Stat_t tmpstatbuf;
3954 if (PerlLIO_stat(CopFILE(PL_curcop),&tmpstatbuf) < 0 ||
3955 tmpstatbuf.st_dev != PL_statbuf.st_dev ||
3956 tmpstatbuf.st_ino != PL_statbuf.st_ino) {
3957 Perl_croak(aTHX_ "Setuid script changed\n");
3958 }
3959
3960 }
3961 if (!cando(S_IXUSR,FALSE,&PL_statbuf)) /* can real uid exec? */
3962 Perl_croak(aTHX_ "Real UID cannot exec script\n");
3963
3964 /* PSz 27 Feb 04
3965 * We used to do this check as the "plain" user (after swapping
3966 * UIDs). But the check for nosuid and noexec filesystem is needed,
3967 * and should be done even without HAS_SETREUID. (Maybe those
3968 * operating systems do not have such mount options anyway...)
3969 * Seems safe enough to do as root.
3970 */
3971 #if !defined(NO_NOSUID_CHECK)
3972 if (fd_on_nosuid_fs(PerlIO_fileno(PL_rsfp))) {
3973 Perl_croak(aTHX_ "Setuid script on nosuid or noexec filesystem\n");
3974 }
3975 #endif
3976 #endif /* IAMSUID */
3977
3978 if (!S_ISREG(PL_statbuf.st_mode)) {
3979 Perl_croak(aTHX_ "Setuid script not plain file\n");
3980 }
3981 if (PL_statbuf.st_mode & S_IWOTH)
3982 Perl_croak(aTHX_ "Setuid/gid script is writable by world");
3983 PL_doswitches = FALSE; /* -s is insecure in suid */
3984 /* PSz 13 Nov 03 But -s was caught elsewhere ... so unsetting it here is useless(?!) */
3985 CopLINE_inc(PL_curcop);
3986 if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch)
3987 Perl_croak(aTHX_ "No #! line");
3988 linestr = SvPV_nolen_const(PL_linestr);
3989 /* required even on Sys V */
3990 if (!*linestr || !linestr[1] || strnNE(linestr,"#!",2))
3991 Perl_croak(aTHX_ "No #! line");
3992 linestr += 2;
3993 s = linestr;
3994 /* PSz 27 Feb 04 */
3995 /* Sanity check on line length */
3996 if (strlen(s) < 1 || strlen(s) > 4000)
3997 Perl_croak(aTHX_ "Very long #! line");
3998 /* Allow more than a single space after #! */
3999 while (isSPACE(*s)) s++;
4000 /* Sanity check on buffer end */
4001 while ((*s) && !isSPACE(*s)) s++;
4002 for (s2 = s; (s2 > linestr &&
4003 (isDIGIT(s2[-1]) || s2[-1] == '.' || s2[-1] == '_'
4004 || s2[-1] == '-')); s2--) ;
4005 /* Sanity check on buffer start */
4006 if ( (s2-4 < linestr || strnNE(s2-4,"perl",4)) &&
4007 (s-9 < linestr || strnNE(s-9,"perl",4)) )
4008 Perl_croak(aTHX_ "Not a perl script");
4009 while (*s == ' ' || *s == '\t') s++;
4010 /*
4011 * #! arg must be what we saw above. They can invoke it by
4012 * mentioning suidperl explicitly, but they may not add any strange
4013 * arguments beyond what #! says if they do invoke suidperl that way.
4014 */
4015 /*
4016 * The way validarg was set up, we rely on the kernel to start
4017 * scripts with argv[1] set to contain all #! line switches (the
4018 * whole line).
4019 */
4020 /*
4021 * Check that we got all the arguments listed in the #! line (not
4022 * just that there are no extraneous arguments). Might not matter
4023 * much, as switches from #! line seem to be acted upon (also), and
4024 * so may be checked and trapped in perl. But, security checks must
4025 * be done in suidperl and not deferred to perl. Note that suidperl
4026 * does not get around to parsing (and checking) the switches on
4027 * the #! line (but execs perl sooner).
4028 * Allow (require) a trailing newline (which may be of two
4029 * characters on some architectures?) (but no other trailing
4030 * whitespace).
4031 */
4032 len = strlen(validarg);
4033 if (strEQ(validarg," PHOOEY ") ||
4034 strnNE(s,validarg,len) || !isSPACE(s[len]) ||
4035 !(strlen(s) == len+1 || (strlen(s) == len+2 && isSPACE(s[len+1]))))
4036 Perl_croak(aTHX_ "Args must match #! line");
4037
4038 #ifndef IAMSUID
4039 if (PL_fdscript < 0 &&
4040 PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) &&
4041 PL_euid == PL_statbuf.st_uid)
4042 if (!PL_do_undump)
4043 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
4044 FIX YOUR KERNEL, OR PUT A C WRAPPER AROUND THIS SCRIPT!\n");
4045 #endif /* IAMSUID */
4046
4047 if (PL_fdscript < 0 &&
4048 PL_euid) { /* oops, we're not the setuid root perl */
4049 /* PSz 18 Feb 04
4050 * When root runs a setuid script, we do not go through the same
4051 * steps of execing sperl and then perl with fd scripts, but
4052 * simply set up UIDs within the same perl invocation; so do
4053 * not have the same checks (on options, whatever) that we have
4054 * for plain users. No problem really: would have to be a script
4055 * that does not actually work for plain users; and if root is
4056 * foolish and can be persuaded to run such an unsafe script, he
4057 * might run also non-setuid ones, and deserves what he gets.
4058 *
4059 * Or, we might drop the PL_euid check above (and rely just on
4060 * PL_fdscript to avoid loops), and do the execs
4061 * even for root.
4062 */
4063 #ifndef IAMSUID
4064 int which;
4065 /* PSz 11 Nov 03
4066 * Pass fd script to suidperl.
4067 * Exec suidperl, substituting fd script for scriptname.
4068 * Pass script name as "subdir" of fd, which perl will grok;
4069 * in fact will use that to distinguish this from "normal"
4070 * usage, see comments above.
4071 */
4072 PerlIO_rewind(PL_rsfp);
4073 PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0); /* just in case rewind didn't */
4074 /* PSz 27 Feb 04 Sanity checks on scriptname */
4075 if ((!scriptname) || (!*scriptname) ) {
4076 Perl_croak(aTHX_ "No setuid script name\n");
4077 }
4078 if (*scriptname == '-') {
4079 Perl_croak(aTHX_ "Setuid script name may not begin with dash\n");
4080 /* Or we might confuse it with an option when replacing
4081 * name in argument list, below (though we do pointer, not
4082 * string, comparisons).
4083 */
4084 }
4085 for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ;
4086 if (!PL_origargv[which]) {
4087 Perl_croak(aTHX_ "Can't change argv to have fd script\n");
4088 }
4089 PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s",
4090 PerlIO_fileno(PL_rsfp), PL_origargv[which]));
4091 #if defined(HAS_FCNTL) && defined(F_SETFD)
4092 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0); /* ensure no close-on-exec */
4093 #endif
4094 PERL_FPU_PRE_EXEC
4095 PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT, BIN_EXP,
4096 (int)PERL_REVISION, (int)PERL_VERSION,
4097 (int)PERL_SUBVERSION), PL_origargv);
4098 PERL_FPU_POST_EXEC
4099 #endif /* IAMSUID */
4100 Perl_croak(aTHX_ "Can't do setuid (cannot exec sperl)\n");
4101 }
4102
4103 if (PL_statbuf.st_mode & S_ISGID && PL_statbuf.st_gid != PL_egid) {
4104 /* PSz 26 Feb 04
4105 * This seems back to front: we try HAS_SETEGID first; if not available
4106 * then try HAS_SETREGID; as a last chance we try HAS_SETRESGID. May be OK
4107 * in the sense that we only want to set EGID; but are there any machines
4108 * with either of the latter, but not the former? Same with UID, later.
4109 */
4110 #ifdef HAS_SETEGID
4111 (void)setegid(PL_statbuf.st_gid);
4112 #else
4113 #ifdef HAS_SETREGID
4114 (void)setregid((Gid_t)-1,PL_statbuf.st_gid);
4115 #else
4116 #ifdef HAS_SETRESGID
4117 (void)setresgid((Gid_t)-1,PL_statbuf.st_gid,(Gid_t)-1);
4118 #else
4119 PerlProc_setgid(PL_statbuf.st_gid);
4120 #endif
4121 #endif
4122 #endif
4123 if (PerlProc_getegid() != PL_statbuf.st_gid)
4124 Perl_croak(aTHX_ "Can't do setegid!\n");
4125 }
4126 if (PL_statbuf.st_mode & S_ISUID) {
4127 if (PL_statbuf.st_uid != PL_euid)
4128 #ifdef HAS_SETEUID
4129 (void)seteuid(PL_statbuf.st_uid); /* all that for this */
4130 #else
4131 #ifdef HAS_SETREUID
4132 (void)setreuid((Uid_t)-1,PL_statbuf.st_uid);
4133 #else
4134 #ifdef HAS_SETRESUID
4135 (void)setresuid((Uid_t)-1,PL_statbuf.st_uid,(Uid_t)-1);
4136 #else
4137 PerlProc_setuid(PL_statbuf.st_uid);
4138 #endif
4139 #endif
4140 #endif
4141 if (PerlProc_geteuid() != PL_statbuf.st_uid)
4142 Perl_croak(aTHX_ "Can't do seteuid!\n");
4143 }
4144 else if (PL_uid) { /* oops, mustn't run as root */
4145 #ifdef HAS_SETEUID
4146 (void)seteuid((Uid_t)PL_uid);
4147 #else
4148 #ifdef HAS_SETREUID
4149 (void)setreuid((Uid_t)-1,(Uid_t)PL_uid);
4150 #else
4151 #ifdef HAS_SETRESUID
4152 (void)setresuid((Uid_t)-1,(Uid_t)PL_uid,(Uid_t)-1);
4153 #else
4154 PerlProc_setuid((Uid_t)PL_uid);
4155 #endif
4156 #endif
4157 #endif
4158 if (PerlProc_geteuid() != PL_uid)
4159 Perl_croak(aTHX_ "Can't do seteuid!\n");
4160 }
4161 init_ids();
4162 if (!cando(S_IXUSR,TRUE,&PL_statbuf))
4163 Perl_croak(aTHX_ "Effective UID cannot exec script\n"); /* they can't do this */
4164 }
4165 #ifdef IAMSUID
4166 else if (PL_preprocess) /* PSz 13 Nov 03 Caught elsewhere, useless(?!) here */
4167 Perl_croak(aTHX_ "-P not allowed for setuid/setgid script\n");
4168 else if (PL_fdscript < 0 || PL_suidscript != 1)
4169 /* PSz 13 Nov 03 Caught elsewhere, useless(?!) here */
4170 Perl_croak(aTHX_ "(suid) fdscript needed in suidperl\n");
4171 else {
4172 /* PSz 16 Sep 03 Keep neat error message */
4173 Perl_croak(aTHX_ "Script is not setuid/setgid in suidperl\n");
4174 }
4175
4176 /* We absolutely must clear out any saved ids here, so we */
4177 /* exec the real perl, substituting fd script for scriptname. */
4178 /* (We pass script name as "subdir" of fd, which perl will grok.) */
4179 /*
4180 * It might be thought that using setresgid and/or setresuid (changed to
4181 * set the saved IDs) above might obviate the need to exec, and we could
4182 * go on to "do the perl thing".
4183 *
4184 * Is there such a thing as "saved GID", and is that set for setuid (but
4185 * not setgid) execution like suidperl? Without exec, it would not be
4186 * cleared for setuid (but not setgid) scripts (or might need a dummy
4187 * setresgid).
4188 *
4189 * We need suidperl to do the exact same argument checking that perl
4190 * does. Thus it cannot be very small; while it could be significantly
4191 * smaller, it is safer (simpler?) to make it essentially the same
4192 * binary as perl (but they are not identical). - Maybe could defer that
4193 * check to the invoked perl, and suidperl be a tiny wrapper instead;
4194 * but prefer to do thorough checks in suidperl itself. Such deferral
4195 * would make suidperl security rely on perl, a design no-no.
4196 *
4197 * Setuid things should be short and simple, thus easy to understand and
4198 * verify. They should do their "own thing", without influence by
4199 * attackers. It may help if their internal execution flow is fixed,
4200 * regardless of platform: it may be best to exec anyway.
4201 *
4202 * Suidperl should at least be conceptually simple: a wrapper only,
4203 * never to do any real perl. Maybe we should put
4204 * #ifdef IAMSUID
4205 * Perl_croak(aTHX_ "Suidperl should never do real perl\n");
4206 * #endif
4207 * into the perly bits.
4208 */
4209 PerlIO_rewind(PL_rsfp);
4210 PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0); /* just in case rewind didn't */
4211 /* PSz 11 Nov 03
4212 * Keep original arguments: suidperl already has fd script.
4213 */
4214 /* for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ; */
4215 /* if (!PL_origargv[which]) { */
4216 /* errno = EPERM; */
4217 /* Perl_croak(aTHX_ "Permission denied\n"); */
4218 /* } */
4219 /* PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s", */
4220 /* PerlIO_fileno(PL_rsfp), PL_origargv[which])); */
4221 #if defined(HAS_FCNTL) && defined(F_SETFD)
4222 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0); /* ensure no close-on-exec */
4223 #endif
4224 PERL_FPU_PRE_EXEC
4225 PerlProc_execv(Perl_form(aTHX_ "%s/perl"PERL_FS_VER_FMT, BIN_EXP,
4226 (int)PERL_REVISION, (int)PERL_VERSION,
4227 (int)PERL_SUBVERSION), PL_origargv);/* try again */
4228 PERL_FPU_POST_EXEC
4229 Perl_croak(aTHX_ "Can't do setuid (suidperl cannot exec perl)\n");
4230 #endif /* IAMSUID */
4231 #else /* !DOSUID */
4232 if (PL_euid != PL_uid || PL_egid != PL_gid) { /* (suidperl doesn't exist, in fact) */
4233 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
4234 PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf); /* may be either wrapped or real suid */
4235 if ((PL_euid != PL_uid && PL_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
4236 ||
4237 (PL_egid != PL_gid && PL_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
4238 )
4239 if (!PL_do_undump)
4240 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
4241 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
4242 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
4243 /* not set-id, must be wrapped */
4244 }
4245 #endif /* DOSUID */
4246 (void)validarg;
4247 (void)scriptname;
4248 }
4249
4250 STATIC void
4251 S_find_beginning(pTHX)
4252 {
4253 register char *s;
4254 register const char *s2;
4255 #ifdef MACOS_TRADITIONAL
4256 int maclines = 0;
4257 #endif
4258
4259 /* skip forward in input to the real script? */
4260
4261 forbid_setid("-x");
4262 #ifdef MACOS_TRADITIONAL
4263 /* Since the Mac OS does not honor #! arguments for us, we do it ourselves */
4264
4265 while (PL_doextract || gMacPerl_AlwaysExtract) {
4266 if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
4267 if (!gMacPerl_AlwaysExtract)
4268 Perl_croak(aTHX_ "No Perl script found in input\n");
4269
4270 if (PL_doextract) /* require explicit override ? */
4271 if (!OverrideExtract(PL_origfilename))
4272 Perl_croak(aTHX_ "User aborted script\n");
4273 else
4274 PL_doextract = FALSE;
4275
4276 /* Pater peccavi, file does not have #! */
4277 PerlIO_rewind(PL_rsfp);
4278
4279 break;
4280 }
4281 #else
4282 while (PL_doextract) {
4283 if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch)
4284 Perl_croak(aTHX_ "No Perl script found in input\n");
4285 #endif
4286 s2 = s;
4287 if (*s == '#' && s[1] == '!' && ((s = instr(s,"perl")) || (s = instr(s2,"PERL")))) {
4288 PerlIO_ungetc(PL_rsfp, '\n'); /* to keep line count right */
4289 PL_doextract = FALSE;
4290 while (*s && !(isSPACE (*s) || *s == '#')) s++;
4291 s2 = s;
4292 while (*s == ' ' || *s == '\t') s++;
4293 if (*s++ == '-') {
4294 while (isDIGIT(s2[-1]) || s2[-1] == '-' || s2[-1] == '.'
4295 || s2[-1] == '_') s2--;
4296 if (strnEQ(s2-4,"perl",4))
4297 while ((s = moreswitches(s)))
4298 ;
4299 }
4300 #ifdef MACOS_TRADITIONAL
4301 /* We are always searching for the #!perl line in MacPerl,
4302 * so if we find it, still keep the line count correct
4303 * by counting lines we already skipped over
4304 */
4305 for (; maclines > 0 ; maclines--)
4306 PerlIO_ungetc(PL_rsfp, '\n');
4307
4308 break;
4309
4310 /* gMacPerl_AlwaysExtract is false in MPW tool */
4311 } else if (gMacPerl_AlwaysExtract) {
4312 ++maclines;
4313 #endif
4314 }
4315 }
4316 }
4317
4318
4319 STATIC void
4320 S_init_ids(pTHX)
4321 {
4322 PL_uid = PerlProc_getuid();
4323 PL_euid = PerlProc_geteuid();
4324 PL_gid = PerlProc_getgid();
4325 PL_egid = PerlProc_getegid();
4326 #ifdef VMS
4327 PL_uid |= PL_gid << 16;
4328 PL_euid |= PL_egid << 16;
4329 #endif
4330 /* Should not happen: */
4331 CHECK_MALLOC_TAINT(PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
4332 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
4333 /* BUG */
4334 /* PSz 27 Feb 04
4335 * Should go by suidscript, not uid!=euid: why disallow
4336 * system("ls") in scripts run from setuid things?
4337 * Or, is this run before we check arguments and set suidscript?
4338 * What about SETUID_SCRIPTS_ARE_SECURE_NOW: could we use fdscript then?
4339 * (We never have suidscript, can we be sure to have fdscript?)
4340 * Or must then go by UID checks? See comments in forbid_setid also.
4341 */
4342 }
4343
4344 /* This is used very early in the lifetime of the program,
4345 * before even the options are parsed, so PL_tainting has
4346 * not been initialized properly. */
4347 bool
4348 Perl_doing_taint(int argc, char *argv[], char *envp[])
4349 {
4350 #ifndef PERL_IMPLICIT_SYS
4351 /* If we have PERL_IMPLICIT_SYS we can't call getuid() et alia
4352 * before we have an interpreter-- and the whole point of this
4353 * function is to be called at such an early stage. If you are on
4354 * a system with PERL_IMPLICIT_SYS but you do have a concept of
4355 * "tainted because running with altered effective ids', you'll
4356 * have to add your own checks somewhere in here. The two most
4357 * known samples of 'implicitness' are Win32 and NetWare, neither
4358 * of which has much of concept of 'uids'. */
4359 int uid = PerlProc_getuid();
4360 int euid = PerlProc_geteuid();
4361 int gid = PerlProc_getgid();
4362 int egid = PerlProc_getegid();
4363 (void)envp;
4364
4365 #ifdef VMS
4366 uid |= gid << 16;
4367 euid |= egid << 16;
4368 #endif
4369 if (uid && (euid != uid || egid != gid))
4370 return 1;
4371 #endif /* !PERL_IMPLICIT_SYS */
4372 /* This is a really primitive check; environment gets ignored only
4373 * if -T are the first chars together; otherwise one gets
4374 * "Too late" message. */
4375 if ( argc > 1 && argv[1][0] == '-'
4376 && (argv[1][1] == 't' || argv[1][1] == 'T') )
4377 return 1;
4378 return 0;
4379 }
4380
4381 STATIC void
4382 S_forbid_setid(pTHX_ const char *s)
4383 {
4384 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
4385 if (PL_euid != PL_uid)
4386 Perl_croak(aTHX_ "No %s allowed while running setuid", s);
4387 if (PL_egid != PL_gid)
4388 Perl_croak(aTHX_ "No %s allowed while running setgid", s);
4389 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
4390 /* PSz 29 Feb 04
4391 * Checks for UID/GID above "wrong": why disallow
4392 * perl -e 'print "Hello\n"'
4393 * from within setuid things?? Simply drop them: replaced by
4394 * fdscript/suidscript and #ifdef IAMSUID checks below.
4395 *
4396 * This may be too late for command-line switches. Will catch those on
4397 * the #! line, after finding the script name and setting up
4398 * fdscript/suidscript. Note that suidperl does not get around to
4399 * parsing (and checking) the switches on the #! line, but checks that
4400 * the two sets are identical.
4401 *
4402 * With SETUID_SCRIPTS_ARE_SECURE_NOW, could we use fdscript, also or
4403 * instead, or would that be "too late"? (We never have suidscript, can
4404 * we be sure to have fdscript?)
4405 *
4406 * Catch things with suidscript (in descendant of suidperl), even with
4407 * right UID/GID. Was already checked in suidperl, with #ifdef IAMSUID,
4408 * below; but I am paranoid.
4409 *
4410 * Also see comments about root running a setuid script, elsewhere.
4411 */
4412 if (PL_suidscript >= 0)
4413 Perl_croak(aTHX_ "No %s allowed with (suid) fdscript", s);
4414 #ifdef IAMSUID
4415 /* PSz 11 Nov 03 Catch it in suidperl, always! */
4416 Perl_croak(aTHX_ "No %s allowed in suidperl", s);
4417 #endif /* IAMSUID */
4418 }
4419
4420 void
4421 Perl_init_debugger(pTHX)
4422 {
4423 HV *ostash = PL_curstash;
4424
4425 PL_curstash = PL_debstash;
4426 PL_dbargs = GvAV(gv_AVadd((gv_fetchpv("DB::args", GV_ADDMULTI, SVt_PVAV))));
4427 AvREAL_off(PL_dbargs);
4428 PL_DBgv = gv_fetchpv("DB::DB", GV_ADDMULTI, SVt_PVGV);
4429 PL_DBline = gv_fetchpv("DB::dbline", GV_ADDMULTI, SVt_PVAV);
4430 PL_DBsub = gv_HVadd(gv_fetchpv("DB::sub", GV_ADDMULTI, SVt_PVHV));
4431 PL_DBsingle = GvSV((gv_fetchpv("DB::single", GV_ADDMULTI, SVt_PV)));
4432 sv_setiv(PL_DBsingle, 0);
4433 PL_DBtrace = GvSV((gv_fetchpv("DB::trace", GV_ADDMULTI, SVt_PV)));
4434 sv_setiv(PL_DBtrace, 0);
4435 PL_DBsignal = GvSV((gv_fetchpv("DB::signal", GV_ADDMULTI, SVt_PV)));
4436 sv_setiv(PL_DBsignal, 0);
4437 PL_curstash = ostash;
4438 }
4439
4440 #ifndef STRESS_REALLOC
4441 #define REASONABLE(size) (size)
4442 #else
4443 #define REASONABLE(size) (1) /* unreasonable */
4444 #endif
4445
4446 void
4447 Perl_init_stacks(pTHX)
4448 {
4449 /* start with 128-item stack and 8K cxstack */
4450 PL_curstackinfo = new_stackinfo(REASONABLE(128),
4451 REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
4452 PL_curstackinfo->si_type = PERLSI_MAIN;
4453 PL_curstack = PL_curstackinfo->si_stack;
4454 PL_mainstack = PL_curstack; /* remember in case we switch stacks */
4455
4456 PL_stack_base = AvARRAY(PL_curstack);
4457 PL_stack_sp = PL_stack_base;
4458 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
4459
4460 Newx(PL_tmps_stack,REASONABLE(128),SV*);
4461 PL_tmps_floor = -1;
4462 PL_tmps_ix = -1;
4463 PL_tmps_max = REASONABLE(128);
4464
4465 Newx(PL_markstack,REASONABLE(32),I32);
4466 PL_markstack_ptr = PL_markstack;
4467 PL_markstack_max = PL_markstack + REASONABLE(32);
4468
4469 SET_MARK_OFFSET;
4470
4471 Newx(PL_scopestack,REASONABLE(32),I32);
4472 PL_scopestack_ix = 0;
4473 PL_scopestack_max = REASONABLE(32);
4474
4475 Newx(PL_savestack,REASONABLE(128),ANY);
4476 PL_savestack_ix = 0;
4477 PL_savestack_max = REASONABLE(128);
4478
4479 New(54,PL_retstack,REASONABLE(16),OP*);
4480 PL_retstack_ix = 0;
4481 PL_retstack_max = REASONABLE(16);
4482 }
4483
4484 #undef REASONABLE
4485
4486 STATIC void
4487 S_nuke_stacks(pTHX)
4488 {
4489 while (PL_curstackinfo->si_next)
4490 PL_curstackinfo = PL_curstackinfo->si_next;
4491 while (PL_curstackinfo) {
4492 PERL_SI *p = PL_curstackinfo->si_prev;
4493 /* curstackinfo->si_stack got nuked by sv_free_arenas() */
4494 Safefree(PL_curstackinfo->si_cxstack);
4495 Safefree(PL_curstackinfo);
4496 PL_curstackinfo = p;
4497 }
4498 Safefree(PL_tmps_stack);
4499 Safefree(PL_markstack);
4500 Safefree(PL_scopestack);
4501 Safefree(PL_savestack);
4502 Safefree(PL_retstack);
4503 }
4504
4505 STATIC void
4506 S_init_lexer(pTHX)
4507 {
4508 PerlIO *tmpfp;
4509 tmpfp = PL_rsfp;
4510 PL_rsfp = Nullfp;
4511 lex_start(PL_linestr);
4512 PL_rsfp = tmpfp;
4513 PL_subname = newSVpvn("main",4);
4514 }
4515
4516 STATIC void
4517 S_init_predump_symbols(pTHX)
4518 {
4519 GV *tmpgv;
4520 IO *io;
4521
4522 sv_setpvn(get_sv("\"", TRUE), " ", 1);
4523 PL_stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
4524 GvMULTI_on(PL_stdingv);
4525 io = GvIOp(PL_stdingv);
4526 IoTYPE(io) = IoTYPE_RDONLY;
4527 IoIFP(io) = PerlIO_stdin();
4528 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
4529 GvMULTI_on(tmpgv);
4530 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
4531
4532 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
4533 GvMULTI_on(tmpgv);
4534 io = GvIOp(tmpgv);
4535 IoTYPE(io) = IoTYPE_WRONLY;
4536 IoOFP(io) = IoIFP(io) = PerlIO_stdout();
4537 setdefout(tmpgv);
4538 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
4539 GvMULTI_on(tmpgv);
4540 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
4541
4542 PL_stderrgv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
4543 GvMULTI_on(PL_stderrgv);
4544 io = GvIOp(PL_stderrgv);
4545 IoTYPE(io) = IoTYPE_WRONLY;
4546 IoOFP(io) = IoIFP(io) = PerlIO_stderr();
4547 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
4548 GvMULTI_on(tmpgv);
4549 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
4550
4551 PL_statname = NEWSV(66,0); /* last filename we did stat on */
4552
4553 Safefree(PL_osname);
4554 PL_osname = savepv(OSNAME);
4555 }
4556
4557 void
4558 Perl_init_argv_symbols(pTHX_ register int argc, register char **argv)
4559 {
4560 argc--,argv++; /* skip name of script */
4561 if (PL_doswitches) {
4562 for (; argc > 0 && **argv == '-'; argc--,argv++) {
4563 char *s;
4564 if (!argv[0][1])
4565 break;
4566 if (argv[0][1] == '-' && !argv[0][2]) {
4567 argc--,argv++;
4568 break;
4569 }
4570 if ((s = strchr(argv[0], '='))) {
4571 *s++ = '\0';
4572 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
4573 }
4574 else
4575 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
4576 }
4577 }
4578 if ((PL_argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV))) {
4579 GvMULTI_on(PL_argvgv);
4580 (void)gv_AVadd(PL_argvgv);
4581 av_clear(GvAVn(PL_argvgv));
4582 for (; argc > 0; argc--,argv++) {
4583 SV * const sv = newSVpv(argv[0],0);
4584 av_push(GvAVn(PL_argvgv),sv);
4585 if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) {
4586 if (PL_unicode & PERL_UNICODE_ARGV_FLAG)
4587 SvUTF8_on(sv);
4588 }
4589 if (PL_unicode & PERL_UNICODE_WIDESYSCALLS_FLAG) /* Sarathy? */
4590 (void)sv_utf8_decode(sv);
4591 }
4592 }
4593 }
4594
4595 #ifdef HAS_PROCSELFEXE
4596 /* This is a function so that we don't hold on to MAXPATHLEN
4597 bytes of stack longer than necessary
4598 */
4599 STATIC void
4600 S_procself_val(pTHX_ SV *sv, char *arg0)
4601 {
4602 char buf[MAXPATHLEN];
4603 int len = readlink(PROCSELFEXE_PATH, buf, sizeof(buf) - 1);
4604
4605 /* On Playstation2 Linux V1.0 (kernel 2.2.1) readlink(/proc/self/exe)
4606 includes a spurious NUL which will cause $^X to fail in system
4607 or backticks (this will prevent extensions from being built and
4608 many tests from working). readlink is not meant to add a NUL.
4609 Normal readlink works fine.
4610 */
4611 if (len > 0 && buf[len-1] == '\0') {
4612 len--;
4613 }
4614
4615 /* FreeBSD's implementation is acknowledged to be imperfect, sometimes
4616 returning the text "unknown" from the readlink rather than the path
4617 to the executable (or returning an error from the readlink). Any valid
4618 path has a '/' in it somewhere, so use that to validate the result.
4619 See http://www.freebsd.org/cgi/query-pr.cgi?pr=35703
4620 */
4621 if (len > 0 && memchr(buf, '/', len)) {
4622 sv_setpvn(sv,buf,len);
4623 }
4624 else {
4625 sv_setpv(sv,arg0);
4626 }
4627 }
4628 #endif /* HAS_PROCSELFEXE */
4629
4630 STATIC void
4631 S_set_caret_X(pTHX) {
4632 GV* tmpgv = gv_fetchpv("\030",TRUE, SVt_PV); /* $^X */
4633 if (tmpgv) {
4634 #ifdef HAS_PROCSELFEXE
4635 S_procself_val(aTHX_ GvSV(tmpgv), PL_origargv[0]);
4636 #else
4637 #ifdef OS2
4638 sv_setpv(GvSVn(tmpgv), os2_execname(aTHX));
4639 #else
4640 sv_setpv(GvSVn(tmpgv),PL_origargv[0]);
4641 #endif
4642 #endif
4643 }
4644 }
4645
4646 STATIC void
4647 S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env)
4648 {
4649 GV* tmpgv;
4650
4651 PL_toptarget = NEWSV(0,0);
4652 sv_upgrade(PL_toptarget, SVt_PVFM);
4653 sv_setpvn(PL_toptarget, "", 0);
4654 PL_bodytarget = NEWSV(0,0);
4655 sv_upgrade(PL_bodytarget, SVt_PVFM);
4656 sv_setpvn(PL_bodytarget, "", 0);
4657 PL_formtarget = PL_bodytarget;
4658
4659 TAINT;
4660
4661 init_argv_symbols(argc,argv);
4662
4663 if ((tmpgv = gv_fetchpv("0",TRUE, SVt_PV))) {
4664 #ifdef MACOS_TRADITIONAL
4665 /* $0 is not majick on a Mac */
4666 sv_setpv(GvSV(tmpgv),MacPerl_MPWFileName(PL_origfilename));
4667 #else
4668 sv_setpv(GvSV(tmpgv),PL_origfilename);
4669 magicname("0", "0", 1);
4670 #endif
4671 }
4672 S_set_caret_X(aTHX);
4673 if ((PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV))) {
4674 HV *hv;
4675 GvMULTI_on(PL_envgv);
4676 hv = GvHVn(PL_envgv);
4677 hv_magic(hv, Nullgv, PERL_MAGIC_env);
4678 #ifndef PERL_MICRO
4679 #ifdef USE_ENVIRON_ARRAY
4680 /* Note that if the supplied env parameter is actually a copy
4681 of the global environ then it may now point to free'd memory
4682 if the environment has been modified since. To avoid this
4683 problem we treat env==NULL as meaning 'use the default'
4684 */
4685 if (!env)
4686 env = environ;
4687 if (env != environ
4688 # ifdef USE_ITHREADS
4689 && PL_curinterp == aTHX
4690 # endif
4691 )
4692 {
4693 environ[0] = Nullch;
4694 }
4695 if (env) {
4696 char** origenv = environ;
4697 char *s;
4698 SV *sv;
4699 for (; *env; env++) {
4700 if (!(s = strchr(*env,'=')) || s == *env)
4701 continue;
4702 #if defined(MSDOS) && !defined(DJGPP)
4703 *s = '\0';
4704 (void)strupr(*env);
4705 *s = '=';
4706 #endif
4707 sv = newSVpv(s+1, 0);
4708 (void)hv_store(hv, *env, s - *env, sv, 0);
4709 if (env != environ)
4710 mg_set(sv);
4711 if (origenv != environ) {
4712 /* realloc has shifted us */
4713 env = (env - origenv) + environ;
4714 origenv = environ;
4715 }
4716 }
4717 }
4718 #endif /* USE_ENVIRON_ARRAY */
4719 #endif /* !PERL_MICRO */
4720 }
4721 TAINT_NOT;
4722 if ((tmpgv = gv_fetchpv("$",TRUE, SVt_PV))) {
4723 SvREADONLY_off(GvSV(tmpgv));
4724 sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
4725 SvREADONLY_on(GvSV(tmpgv));
4726 }
4727 #ifdef THREADS_HAVE_PIDS
4728 PL_ppid = (IV)getppid();
4729 #endif
4730
4731 /* touch @F array to prevent spurious warnings 20020415 MJD */
4732 if (PL_minus_a) {
4733 (void) get_av("main::F", TRUE | GV_ADDMULTI);
4734 }
4735 /* touch @- and @+ arrays to prevent spurious warnings 20020415 MJD */
4736 (void) get_av("main::-", TRUE | GV_ADDMULTI);
4737 (void) get_av("main::+", TRUE | GV_ADDMULTI);
4738 }
4739
4740 STATIC void
4741 S_init_perllib(pTHX)
4742 {
4743 char *s;
4744 if (!PL_tainting) {
4745 #ifndef VMS
4746 s = PerlEnv_getenv("PERL5LIB");
4747 /*
4748 * It isn't possible to delete an environment variable with
4749 * PERL_USE_SAFE_PUTENV set unless unsetenv() is also available, so in that
4750 * case we treat PERL5LIB as undefined if it has a zero-length value.
4751 */
4752 #if defined(PERL_USE_SAFE_PUTENV) && ! defined(HAS_UNSETENV)
4753 if (s && *s != '\0')
4754 #else
4755 if (s)
4756 #endif
4757 incpush(s, TRUE, TRUE, TRUE);
4758 else
4759 incpush(PerlEnv_getenv("PERLLIB"), FALSE, FALSE, TRUE);
4760 #else /* VMS */
4761 /* Treat PERL5?LIB as a possible search list logical name -- the
4762 * "natural" VMS idiom for a Unix path string. We allow each
4763 * element to be a set of |-separated directories for compatibility.
4764 */
4765 char buf[256];
4766 int idx = 0;
4767 if (my_trnlnm("PERL5LIB",buf,0))
4768 do { incpush(buf,TRUE,TRUE,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
4769 else
4770 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE,FALSE,TRUE);
4771 #endif /* VMS */
4772 }
4773
4774 /* Use the ~-expanded versions of APPLLIB (undocumented),
4775 ARCHLIB PRIVLIB SITEARCH SITELIB VENDORARCH and VENDORLIB
4776 */
4777 #ifdef APPLLIB_EXP
4778 incpush(APPLLIB_EXP, TRUE, TRUE, TRUE);
4779 #endif
4780
4781 #ifdef ARCHLIB_EXP
4782 incpush(ARCHLIB_EXP, FALSE, FALSE, TRUE);
4783 #endif
4784 #ifdef MACOS_TRADITIONAL
4785 {
4786 Stat_t tmpstatbuf;
4787 SV * privdir = NEWSV(55, 0);
4788 char * macperl = PerlEnv_getenv("MACPERL");
4789
4790 if (!macperl)
4791 macperl = "";
4792
4793 Perl_sv_setpvf(aTHX_ privdir, "%slib:", macperl);
4794 if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode))
4795 incpush(SvPVX(privdir), TRUE, FALSE, TRUE);
4796 Perl_sv_setpvf(aTHX_ privdir, "%ssite_perl:", macperl);
4797 if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode))
4798 incpush(SvPVX(privdir), TRUE, FALSE, TRUE);
4799
4800 SvREFCNT_dec(privdir);
4801 }
4802 if (!PL_tainting)
4803 incpush(":", FALSE, FALSE, TRUE);
4804 #else
4805 #ifndef PRIVLIB_EXP
4806 # define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
4807 #endif
4808 #if defined(WIN32)
4809 incpush(PRIVLIB_EXP, TRUE, FALSE, TRUE);
4810 #else
4811 incpush(PRIVLIB_EXP, FALSE, FALSE, TRUE);
4812 #endif
4813
4814 #ifdef SITEARCH_EXP
4815 /* sitearch is always relative to sitelib on Windows for
4816 * DLL-based path intuition to work correctly */
4817 # if !defined(WIN32)
4818 incpush(SITEARCH_EXP, FALSE, FALSE, TRUE);
4819 # endif
4820 #endif
4821
4822 #ifdef SITELIB_EXP
4823 # if defined(WIN32)
4824 /* this picks up sitearch as well */
4825 incpush(SITELIB_EXP, TRUE, FALSE, TRUE);
4826 # else
4827 incpush(SITELIB_EXP, FALSE, FALSE, TRUE);
4828 # endif
4829 #endif
4830
4831 #ifdef SITELIB_STEM /* Search for version-specific dirs below here */
4832 incpush(SITELIB_STEM, FALSE, TRUE, TRUE);
4833 #endif
4834
4835 #ifdef PERL_VENDORARCH_EXP
4836 /* vendorarch is always relative to vendorlib on Windows for
4837 * DLL-based path intuition to work correctly */
4838 # if !defined(WIN32)
4839 incpush(PERL_VENDORARCH_EXP, FALSE, FALSE, TRUE);
4840 # endif
4841 #endif
4842
4843 #ifdef PERL_VENDORLIB_EXP
4844 # if defined(WIN32)
4845 incpush(PERL_VENDORLIB_EXP, TRUE, FALSE, TRUE); /* this picks up vendorarch as well */
4846 # else
4847 incpush(PERL_VENDORLIB_EXP, FALSE, FALSE, TRUE);
4848 # endif
4849 #endif
4850
4851 #ifdef PERL_VENDORLIB_STEM /* Search for version-specific dirs below here */
4852 incpush(PERL_VENDORLIB_STEM, FALSE, TRUE, TRUE);
4853 #endif
4854
4855 #ifdef PERL_OTHERLIBDIRS
4856 incpush(PERL_OTHERLIBDIRS, TRUE, TRUE, TRUE);
4857 #endif
4858
4859 if (!PL_tainting)
4860 incpush(".", FALSE, FALSE, TRUE);
4861 #endif /* MACOS_TRADITIONAL */
4862 }
4863
4864 #if defined(DOSISH) || defined(EPOC) || defined(SYMBIAN)
4865 # define PERLLIB_SEP ';'
4866 #else
4867 # if defined(VMS)
4868 # define PERLLIB_SEP '|'
4869 # else
4870 # if defined(MACOS_TRADITIONAL)
4871 # define PERLLIB_SEP ','
4872 # else
4873 # define PERLLIB_SEP ':'
4874 # endif
4875 # endif
4876 #endif
4877 #ifndef PERLLIB_MANGLE
4878 # define PERLLIB_MANGLE(s,n) (s)
4879 #endif
4880
4881 /* Push a directory onto @INC if it exists.
4882 Generate a new SV if we do this, to save needing to copy the SV we push
4883 onto @INC */
4884 STATIC SV *
4885 S_incpush_if_exists(pTHX_ SV *dir)
4886 {
4887 Stat_t tmpstatbuf;
4888 if (PerlLIO_stat(SvPVX_const(dir), &tmpstatbuf) >= 0 &&
4889 S_ISDIR(tmpstatbuf.st_mode)) {
4890 av_push(GvAVn(PL_incgv), dir);
4891 dir = NEWSV(0,0);
4892 }
4893 return dir;
4894 }
4895
4896 STATIC void
4897 S_incpush(pTHX_ const char *dir, bool addsubdirs, bool addoldvers, bool usesep)
4898 {
4899 SV *subdir = Nullsv;
4900 const char *p = dir;
4901
4902 if (!p || !*p)
4903 return;
4904
4905 if (addsubdirs || addoldvers) {
4906 subdir = NEWSV(0,0);
4907 }
4908
4909 /* Break at all separators */
4910 while (p && *p) {
4911 SV *libdir = NEWSV(55,0);
4912 const char *s;
4913
4914 /* skip any consecutive separators */
4915 if (usesep) {
4916 while ( *p == PERLLIB_SEP ) {
4917 /* Uncomment the next line for PATH semantics */
4918 /* av_push(GvAVn(PL_incgv), newSVpvn(".", 1)); */
4919 p++;
4920 }
4921 }
4922
4923 if ( usesep && (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
4924 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
4925 (STRLEN)(s - p));
4926 p = s + 1;
4927 }
4928 else {
4929 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
4930 p = Nullch; /* break out */
4931 }
4932 #ifdef MACOS_TRADITIONAL
4933 if (!strchr(SvPVX(libdir), ':')) {
4934 char buf[256];
4935
4936 sv_setpv(libdir, MacPerl_CanonDir(SvPVX(libdir), buf, 0));
4937 }
4938 if (SvPVX(libdir)[SvCUR(libdir)-1] != ':')
4939 sv_catpv(libdir, ":");
4940 #endif
4941
4942 /*
4943 * BEFORE pushing libdir onto @INC we may first push version- and
4944 * archname-specific sub-directories.
4945 */
4946 if (addsubdirs || addoldvers) {
4947 #ifdef PERL_INC_VERSION_LIST
4948 /* Configure terminates PERL_INC_VERSION_LIST with a NULL */
4949 const char *incverlist[] = { PERL_INC_VERSION_LIST };
4950 const char **incver;
4951 #endif
4952 #ifdef VMS
4953 char *unix;
4954 STRLEN len;
4955
4956 if ((unix = tounixspec_ts(SvPV(libdir,len),Nullch)) != Nullch) {
4957 len = strlen(unix);
4958 while (unix[len-1] == '/') len--; /* Cosmetic */
4959 sv_usepvn(libdir,unix,len);
4960 }
4961 else
4962 PerlIO_printf(Perl_error_log,
4963 "Failed to unixify @INC element \"%s\"\n",
4964 SvPV(libdir,len));
4965 #endif
4966 if (addsubdirs) {
4967 #ifdef MACOS_TRADITIONAL
4968 #define PERL_AV_SUFFIX_FMT ""
4969 #define PERL_ARCH_FMT "%s:"
4970 #define PERL_ARCH_FMT_PATH PERL_FS_VER_FMT PERL_AV_SUFFIX_FMT
4971 #else
4972 #define PERL_AV_SUFFIX_FMT "/"
4973 #define PERL_ARCH_FMT "/%s"
4974 #define PERL_ARCH_FMT_PATH PERL_AV_SUFFIX_FMT PERL_FS_VER_FMT
4975 #endif
4976 /* .../version/archname if -d .../version/archname */
4977 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PATH PERL_ARCH_FMT,
4978 libdir,
4979 (int)PERL_REVISION, (int)PERL_VERSION,
4980 (int)PERL_SUBVERSION, ARCHNAME);
4981 subdir = S_incpush_if_exists(aTHX_ subdir);
4982
4983 /* .../version if -d .../version */
4984 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PATH, libdir,
4985 (int)PERL_REVISION, (int)PERL_VERSION,
4986 (int)PERL_SUBVERSION);
4987 subdir = S_incpush_if_exists(aTHX_ subdir);
4988
4989 /* .../archname if -d .../archname */
4990 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, libdir, ARCHNAME);
4991 subdir = S_incpush_if_exists(aTHX_ subdir);
4992
4993 }
4994
4995 #ifdef PERL_INC_VERSION_LIST
4996 if (addoldvers) {
4997 for (incver = incverlist; *incver; incver++) {
4998 /* .../xxx if -d .../xxx */
4999 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, libdir, *incver);
5000 subdir = S_incpush_if_exists(aTHX_ subdir);
5001 }
5002 }
5003 #endif
5004 }
5005
5006 /* finally push this lib directory on the end of @INC */
5007 av_push(GvAVn(PL_incgv), libdir);
5008 }
5009 if (subdir) {
5010 assert (SvREFCNT(subdir) == 1);
5011 SvREFCNT_dec(subdir);
5012 }
5013 }
5014
5015 #ifdef USE_5005THREADS
5016 STATIC struct perl_thread *
5017 S_init_main_thread(pTHX)
5018 {
5019 #if !defined(PERL_IMPLICIT_CONTEXT)
5020 struct perl_thread *thr;
5021 #endif
5022 XPV *xpv;
5023
5024 Newxz(thr, 1, struct perl_thread);
5025 PL_curcop = &PL_compiling;
5026 thr->interp = PERL_GET_INTERP;
5027 thr->cvcache = newHV();
5028 thr->threadsv = newAV();
5029 /* thr->threadsvp is set when find_threadsv is called */
5030 thr->specific = newAV();
5031 thr->flags = THRf_R_JOINABLE;
5032 MUTEX_INIT(&thr->mutex);
5033 /* Handcraft thrsv similarly to mess_sv */
5034 Newx(PL_thrsv, 1, SV);
5035 Newxz(xpv, 1, XPV);
5036 SvFLAGS(PL_thrsv) = SVt_PV;
5037 SvANY(PL_thrsv) = (void*)xpv;
5038 SvREFCNT(PL_thrsv) = 1 << 30; /* practically infinite */
5039 SvPV_set(PL_thrsv, (char*)thr);
5040 SvCUR_set(PL_thrsv, sizeof(thr));
5041 SvLEN_set(PL_thrsv, sizeof(thr));
5042 *SvEND(PL_thrsv) = '\0'; /* in the trailing_nul field */
5043 thr->oursv = PL_thrsv;
5044 PL_chopset = " \n-";
5045 PL_dumpindent = 4;
5046
5047 MUTEX_LOCK(&PL_threads_mutex);
5048 PL_nthreads++;
5049 thr->tid = 0;
5050 thr->next = thr;
5051 thr->prev = thr;
5052 thr->thr_done = 0;
5053 MUTEX_UNLOCK(&PL_threads_mutex);
5054
5055 #ifdef HAVE_THREAD_INTERN
5056 Perl_init_thread_intern(thr);
5057 #endif
5058
5059 #ifdef SET_THREAD_SELF
5060 SET_THREAD_SELF(thr);
5061 #else
5062 thr->self = pthread_self();
5063 #endif /* SET_THREAD_SELF */
5064 PERL_SET_THX(thr);
5065
5066 /*
5067 * These must come after the thread self setting
5068 * because sv_setpvn does SvTAINT and the taint
5069 * fields thread selfness being set.
5070 */
5071 PL_toptarget = NEWSV(0,0);
5072 sv_upgrade(PL_toptarget, SVt_PVFM);
5073 sv_setpvn(PL_toptarget, "", 0);
5074 PL_bodytarget = NEWSV(0,0);
5075 sv_upgrade(PL_bodytarget, SVt_PVFM);
5076 sv_setpvn(PL_bodytarget, "", 0);
5077 PL_formtarget = PL_bodytarget;
5078 thr->errsv = newSVpvn("", 0);
5079 (void) find_threadsv("@"); /* Ensure $@ is initialised early */
5080
5081 PL_maxscream = -1;
5082 PL_peepp = MEMBER_TO_FPTR(Perl_peep);
5083 PL_regcompp = MEMBER_TO_FPTR(Perl_pregcomp);
5084 PL_regexecp = MEMBER_TO_FPTR(Perl_regexec_flags);
5085 PL_regint_start = MEMBER_TO_FPTR(Perl_re_intuit_start);
5086 PL_regint_string = MEMBER_TO_FPTR(Perl_re_intuit_string);
5087 PL_regfree = MEMBER_TO_FPTR(Perl_pregfree);
5088 PL_regindent = 0;
5089 PL_reginterp_cnt = 0;
5090
5091 return thr;
5092 }
5093 #endif /* USE_5005THREADS */
5094
5095 void
5096 Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
5097 {
5098 SV *atsv;
5099 const line_t oldline = CopLINE(PL_curcop);
5100 CV *cv;
5101 STRLEN len;
5102 int ret;
5103 dJMPENV;
5104
5105 while (av_len(paramList) >= 0) {
5106 cv = (CV*)av_shift(paramList);
5107 if (PL_savebegin) {
5108 if (paramList == PL_beginav) {
5109 /* save PL_beginav for compiler */
5110 if (! PL_beginav_save)
5111 PL_beginav_save = newAV();
5112 av_push(PL_beginav_save, (SV*)cv);
5113 }
5114 else if (paramList == PL_checkav) {
5115 /* save PL_checkav for compiler */
5116 if (! PL_checkav_save)
5117 PL_checkav_save = newAV();
5118 av_push(PL_checkav_save, (SV*)cv);
5119 }
5120 } else {
5121 SAVEFREESV(cv);
5122 }
5123 #ifdef PERL_FLEXIBLE_EXCEPTIONS
5124 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_list_body), cv);
5125 #else
5126 JMPENV_PUSH(ret);
5127 #endif
5128 switch (ret) {
5129 case 0:
5130 #ifndef PERL_FLEXIBLE_EXCEPTIONS
5131 call_list_body(cv);
5132 #endif
5133 atsv = ERRSV;
5134 (void)SvPV_const(atsv, len);
5135 if (len) {
5136 PL_curcop = &PL_compiling;
5137 CopLINE_set(PL_curcop, oldline);
5138 if (paramList == PL_beginav)
5139 sv_catpv(atsv, "BEGIN failed--compilation aborted");
5140 else
5141 Perl_sv_catpvf(aTHX_ atsv,
5142 "%s failed--call queue aborted",
5143 paramList == PL_checkav ? "CHECK"
5144 : paramList == PL_initav ? "INIT"
5145 : "END");
5146 while (PL_scopestack_ix > oldscope)
5147 LEAVE;
5148 JMPENV_POP;
5149 Perl_croak(aTHX_ "%"SVf"", atsv);
5150 }
5151 break;
5152 case 1:
5153 STATUS_ALL_FAILURE;
5154 /* FALL THROUGH */
5155 case 2:
5156 /* my_exit() was called */
5157 while (PL_scopestack_ix > oldscope)
5158 LEAVE;
5159 FREETMPS;
5160 PL_curstash = PL_defstash;
5161 PL_curcop = &PL_compiling;
5162 CopLINE_set(PL_curcop, oldline);
5163 JMPENV_POP;
5164 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED)) {
5165 if (paramList == PL_beginav)
5166 Perl_croak(aTHX_ "BEGIN failed--compilation aborted");
5167 else
5168 Perl_croak(aTHX_ "%s failed--call queue aborted",
5169 paramList == PL_checkav ? "CHECK"
5170 : paramList == PL_initav ? "INIT"
5171 : "END");
5172 }
5173 my_exit_jump();
5174 /* NOTREACHED */
5175 case 3:
5176 if (PL_restartop) {
5177 PL_curcop = &PL_compiling;
5178 CopLINE_set(PL_curcop, oldline);
5179 JMPENV_JUMP(3);
5180 }
5181 PerlIO_printf(Perl_error_log, "panic: restartop\n");
5182 FREETMPS;
5183 break;
5184 }
5185 JMPENV_POP;
5186 }
5187 }
5188
5189 #ifdef PERL_FLEXIBLE_EXCEPTIONS
5190 STATIC void *
5191 S_vcall_list_body(pTHX_ va_list args)
5192 {
5193 CV *cv = va_arg(args, CV*);
5194 return call_list_body(cv);
5195 }
5196 #endif
5197
5198 STATIC void *
5199 S_call_list_body(pTHX_ CV *cv)
5200 {
5201 PUSHMARK(PL_stack_sp);
5202 call_sv((SV*)cv, G_EVAL|G_DISCARD);
5203 return NULL;
5204 }
5205
5206 void
5207 Perl_my_exit(pTHX_ U32 status)
5208 {
5209 DEBUG_S(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
5210 thr, (unsigned long) status));
5211 switch (status) {
5212 case 0:
5213 STATUS_ALL_SUCCESS;
5214 break;
5215 case 1:
5216 STATUS_ALL_FAILURE;
5217 break;
5218 default:
5219 STATUS_NATIVE_SET(status);
5220 break;
5221 }
5222 my_exit_jump();
5223 }
5224
5225 void
5226 Perl_my_failure_exit(pTHX)
5227 {
5228 #ifdef VMS
5229 if (vaxc$errno & 1) {
5230 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
5231 STATUS_NATIVE_SET(44);
5232 }
5233 else {
5234 if (!vaxc$errno) /* unlikely */
5235 STATUS_NATIVE_SET(44);
5236 else
5237 STATUS_NATIVE_SET(vaxc$errno);
5238 }
5239 #else
5240 int exitstatus;
5241 if (errno & 255)
5242 STATUS_POSIX_SET(errno);
5243 else {
5244 exitstatus = STATUS_POSIX >> 8;
5245 if (exitstatus & 255)
5246 STATUS_POSIX_SET(exitstatus);
5247 else
5248 STATUS_POSIX_SET(255);
5249 }
5250 #endif
5251 my_exit_jump();
5252 }
5253
5254 STATIC void
5255 S_my_exit_jump(pTHX)
5256 {
5257 register PERL_CONTEXT *cx;
5258 I32 gimme;
5259 SV **newsp;
5260
5261 if (PL_e_script) {
5262 SvREFCNT_dec(PL_e_script);
5263 PL_e_script = Nullsv;
5264 }
5265
5266 POPSTACK_TO(PL_mainstack);
5267 if (cxstack_ix >= 0) {
5268 if (cxstack_ix > 0)
5269 dounwind(0);
5270 POPBLOCK(cx,PL_curpm);
5271 LEAVE;
5272 }
5273
5274 JMPENV_JUMP(2);
5275 PERL_UNUSED_VAR(gimme);
5276 PERL_UNUSED_VAR(newsp);
5277 }
5278
5279 static I32
5280 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen)
5281 {
5282 const char * const p = SvPVX_const(PL_e_script);
5283 const char *nl = strchr(p, '\n');
5284
5285 PERL_UNUSED_ARG(idx);
5286 PERL_UNUSED_ARG(maxlen);
5287
5288 nl = (nl) ? nl+1 : SvEND(PL_e_script);
5289 if (nl-p == 0) {
5290 filter_del(read_e_script);
5291 return 0;
5292 }
5293 sv_catpvn(buf_sv, p, nl-p);
5294 sv_chop(PL_e_script, (char *) nl);
5295 return 1;
5296 }
5297
5298 /*
5299 * Local variables:
5300 * c-indentation-style: bsd
5301 * c-basic-offset: 4
5302 * indent-tabs-mode: t
5303 * End:
5304 *
5305 * ex: set ts=8 sts=4 sw=4 noet:
5306 */
5307