This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Builds C++ Borland, MSVC++ (Win32) and GCC++ (Solaris)
[perl5.git] / perl.c
1 /*    perl.c
2  *
3  *    Copyright (c) 1987-1997 Larry Wall
4  *
5  *    You may distribute under the terms of either the GNU General Public
6  *    License or the Artistic License, as specified in the README file.
7  *
8  */
9
10 /*
11  * "A ship then new they built for him/of mithril and of elven glass" --Bilbo
12  */
13
14 #include "EXTERN.h"
15 #include "perl.h"
16 #include "patchlevel.h"
17
18 /* XXX If this causes problems, set i_unistd=undef in the hint file.  */
19 #ifdef I_UNISTD
20 #include <unistd.h>
21 #endif
22
23 #if !defined(STANDARD_C) && !defined(HAS_GETENV_PROTOTYPE)
24 char *getenv _((char *)); /* Usually in <stdlib.h> */
25 #endif
26
27 dEXTCONST char rcsid[] = "perl.c\nPatch level: ###\n";
28
29 #ifdef IAMSUID
30 #ifndef DOSUID
31 #define DOSUID
32 #endif
33 #endif
34
35 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
36 #ifdef DOSUID
37 #undef DOSUID
38 #endif
39 #endif
40
41 #define I_REINIT \
42   STMT_START {                  \
43     chopset     = " \n-";       \
44     copline     = NOLINE;       \
45     curcop      = &compiling;   \
46     curcopdb    = NULL;         \
47     cxstack_ix  = -1;           \
48     cxstack_max = 128;          \
49     dbargs      = 0;            \
50     dlmax       = 128;          \
51     laststatval = -1;           \
52     laststype   = OP_STAT;      \
53     maxscream   = -1;           \
54     maxsysfd    = MAXSYSFD;     \
55     statname    = Nullsv;       \
56     tmps_floor  = -1;           \
57     tmps_ix     = -1;           \
58     op_mask     = NULL;         \
59     dlmax       = 128;          \
60     laststatval = -1;           \
61     laststype   = OP_STAT;      \
62     mess_sv     = Nullsv;       \
63   } STMT_END
64
65 static void find_beginning _((void));
66 static void forbid_setid _((char *));
67 static void incpush _((char *, int));
68 static void init_ids _((void));
69 static void init_debugger _((void));
70 static void init_lexer _((void));
71 static void init_main_stash _((void));
72 static void init_perllib _((void));
73 static void init_postdump_symbols _((int, char **, char **));
74 static void init_predump_symbols _((void));
75 static void my_exit_jump _((void)) __attribute__((noreturn));
76 static void nuke_stacks _((void));
77 static void open_script _((char *, bool, SV *));
78 static void usage _((char *));
79 static void validate_suid _((char *, char*));
80
81 static int fdscript = -1;
82
83 #if defined(DEBUGGING) && defined(USE_THREADS) && defined(__linux__)
84 #include <asm/sigcontext.h>
85 static void
86 catch_sigsegv(int signo, struct sigcontext_struct sc)
87 {
88     signal(SIGSEGV, SIG_DFL);
89     fprintf(stderr, "Segmentation fault dereferencing 0x%lx\n"
90                     "return_address = 0x%lx, eip = 0x%lx\n",
91                     sc.cr2, __builtin_return_address(0), sc.eip);
92     fprintf(stderr, "thread = 0x%lx\n", (unsigned long)THR); 
93 }
94 #endif
95
96 PerlInterpreter *
97 perl_alloc(void)
98 {
99     PerlInterpreter *sv_interp;
100
101     curinterp = 0;
102     New(53, sv_interp, 1, PerlInterpreter);
103     return sv_interp;
104 }
105
106 void
107 perl_construct(register PerlInterpreter *sv_interp)
108 {
109 #if defined(USE_THREADS) && !defined(FAKE_THREADS)
110     struct thread *thr;
111 #endif
112     
113     if (!(curinterp = sv_interp))
114         return;
115
116 #ifdef MULTIPLICITY
117     Zero(sv_interp, 1, PerlInterpreter);
118 #endif
119
120    /* Init the real globals (and main thread)? */
121     if (!linestr) {
122 #ifdef USE_THREADS
123         XPV *xpv;
124
125         INIT_THREADS;
126         Newz(53, thr, 1, struct thread);
127         MUTEX_INIT(&malloc_mutex);
128         MUTEX_INIT(&sv_mutex);
129         /* Safe to use SVs from now on */
130         MUTEX_INIT(&eval_mutex);
131         COND_INIT(&eval_cond);
132         MUTEX_INIT(&threads_mutex);
133         COND_INIT(&nthreads_cond);
134         nthreads = 1;
135         cvcache = newHV();
136         curcop = &compiling;
137         thr->flags = THRf_R_JOINABLE;
138         MUTEX_INIT(&thr->mutex);
139         thr->next = thr;
140         thr->prev = thr;
141         thr->tid = 0;
142
143         /* Handcraft thrsv similarly to mess_sv */
144         New(53, thrsv, 1, SV);
145         Newz(53, xpv, 1, XPV);
146         SvFLAGS(thrsv) = SVt_PV;
147         SvANY(thrsv) = (void*)xpv;
148         SvREFCNT(thrsv) = 1 << 30;      /* practically infinite */
149         SvPVX(thrsv) = (char*)thr;
150         SvCUR_set(thrsv, sizeof(thr));
151         SvLEN_set(thrsv, sizeof(thr));
152         *SvEND(thrsv) = '\0';           /* in the trailing_nul field */
153         oursv = thrsv;
154 #ifdef HAVE_THREAD_INTERN
155         init_thread_intern(thr);
156 #else
157         thr->self = pthread_self();
158         if (pthread_key_create(&thr_key, 0))
159             croak("panic: pthread_key_create");
160 #endif /* HAVE_THREAD_INTERN */
161         SET_THR(thr);
162 #endif /* USE_THREADS */
163
164         linestr = NEWSV(65,80);
165         sv_upgrade(linestr,SVt_PVIV);
166
167         if (!SvREADONLY(&sv_undef)) {
168             SvREADONLY_on(&sv_undef);
169
170             sv_setpv(&sv_no,No);
171             SvNV(&sv_no);
172             SvREADONLY_on(&sv_no);
173
174             sv_setpv(&sv_yes,Yes);
175             SvNV(&sv_yes);
176             SvREADONLY_on(&sv_yes);
177         }
178
179         nrs = newSVpv("\n", 1);
180         rs = SvREFCNT_inc(nrs);
181
182         sighandlerp = sighandler;
183         pidstatus = newHV();
184
185 #ifdef MSDOS
186         /*
187          * There is no way we can refer to them from Perl so close them to save
188          * space.  The other alternative would be to provide STDAUX and STDPRN
189          * filehandles.
190          */
191         (void)fclose(stdaux);
192         (void)fclose(stdprn);
193 #endif
194     }
195
196 #ifdef MULTIPLICITY
197     I_REINIT;
198     perl_destruct_level = 1; 
199 #else
200    if(perl_destruct_level > 0)
201        I_REINIT;
202 #endif
203
204     init_ids();
205     lex_state = LEX_NOTPARSING;
206
207     start_env.je_prev = NULL;
208     start_env.je_ret = -1;
209     start_env.je_mustcatch = TRUE;
210     top_env     = &start_env;
211     STATUS_ALL_SUCCESS;
212
213     SET_NUMERIC_STANDARD();
214 #if defined(SUBVERSION) && SUBVERSION > 0
215     sprintf(patchlevel, "%7.5f",   (double) 5 
216                                 + ((double) PATCHLEVEL / (double) 1000)
217                                 + ((double) SUBVERSION / (double) 100000));
218 #else
219     sprintf(patchlevel, "%5.3f", (double) 5 +
220                                 ((double) PATCHLEVEL / (double) 1000));
221 #endif
222
223 #if defined(LOCAL_PATCH_COUNT)
224     localpatches = local_patches;       /* For possible -v */
225 #endif
226
227     PerlIO_init();      /* Hook to IO system */
228
229     fdpid = newAV();    /* for remembering popen pids by fd */
230
231     init_stacks(ARGS);
232     DEBUG( {
233         New(51,debname,128,char);
234         New(52,debdelim,128,char);
235     } )
236
237     ENTER;
238 }
239
240 void
241 perl_destruct(register PerlInterpreter *sv_interp)
242 {
243     dTHR;
244     int destruct_level;  /* 0=none, 1=full, 2=full with checks */
245     I32 last_sv_count;
246     HV *hv;
247 #ifdef USE_THREADS
248     Thread t;
249 #endif /* USE_THREADS */
250
251     if (!(curinterp = sv_interp))
252         return;
253
254 #ifdef USE_THREADS
255 #ifndef FAKE_THREADS
256     /* Pass 1 on any remaining threads: detach joinables, join zombies */
257   retry_cleanup:
258     MUTEX_LOCK(&threads_mutex);
259     DEBUG_L(PerlIO_printf(PerlIO_stderr(),
260                           "perl_destruct: waiting for %d threads...\n",
261                           nthreads - 1));
262     for (t = thr->next; t != thr; t = t->next) {
263         MUTEX_LOCK(&t->mutex);
264         switch (ThrSTATE(t)) {
265             AV *av;
266         case THRf_ZOMBIE:
267             DEBUG_L(PerlIO_printf(PerlIO_stderr(),
268                                   "perl_destruct: joining zombie %p\n", t));
269             ThrSETSTATE(t, THRf_DEAD);
270             MUTEX_UNLOCK(&t->mutex);
271             nthreads--;
272             /*
273              * The SvREFCNT_dec below may take a long time (e.g. av
274              * may contain an object scalar whose destructor gets
275              * called) so we have to unlock threads_mutex and start
276              * all over again.
277              */
278             MUTEX_UNLOCK(&threads_mutex);
279             JOIN(t, &av);
280             SvREFCNT_dec((SV*)av);
281             DEBUG_L(PerlIO_printf(PerlIO_stderr(),
282                                   "perl_destruct: joined zombie %p OK\n", t));
283             goto retry_cleanup;
284         case THRf_R_JOINABLE:
285             DEBUG_L(PerlIO_printf(PerlIO_stderr(),
286                                   "perl_destruct: detaching thread %p\n", t));
287             ThrSETSTATE(t, THRf_R_DETACHED);
288             /* 
289              * We unlock threads_mutex and t->mutex in the opposite order
290              * from which we locked them just so that DETACH won't
291              * deadlock if it panics. It's only a breach of good style
292              * not a bug since they are unlocks not locks.
293              */
294             MUTEX_UNLOCK(&threads_mutex);
295             DETACH(t);
296             MUTEX_UNLOCK(&t->mutex);
297             goto retry_cleanup;
298         default:
299             DEBUG_L(PerlIO_printf(PerlIO_stderr(),
300                                   "perl_destruct: ignoring %p (state %u)\n",
301                                   t, ThrSTATE(t)));
302             MUTEX_UNLOCK(&t->mutex);
303             /* fall through and out */
304         }
305     }
306     /* We leave the above "Pass 1" loop with threads_mutex still locked */
307
308     /* Pass 2 on remaining threads: wait for the thread count to drop to one */
309     while (nthreads > 1)
310     {
311         DEBUG_L(PerlIO_printf(PerlIO_stderr(),
312                               "perl_destruct: final wait for %d threads\n",
313                               nthreads - 1));
314         COND_WAIT(&nthreads_cond, &threads_mutex);
315     }
316     /* At this point, we're the last thread */
317     MUTEX_UNLOCK(&threads_mutex);
318     DEBUG_L(PerlIO_printf(PerlIO_stderr(), "perl_destruct: armageddon has arrived\n"));
319     MUTEX_DESTROY(&threads_mutex);
320     COND_DESTROY(&nthreads_cond);
321 #endif /* !defined(FAKE_THREADS) */
322 #endif /* USE_THREADS */
323
324     destruct_level = perl_destruct_level;
325 #ifdef DEBUGGING
326     {
327         char *s;
328         if (s = getenv("PERL_DESTRUCT_LEVEL")) {
329             int i = atoi(s);
330             if (destruct_level < i)
331                 destruct_level = i;
332         }
333     }
334 #endif
335
336     LEAVE;
337     FREETMPS;
338
339     /* We must account for everything.  */
340
341     /* Destroy the main CV and syntax tree */
342     if (main_root) {
343         curpad = AvARRAY(comppad);
344         op_free(main_root);
345         main_root = Nullop;
346     }
347     main_start = Nullop;
348     SvREFCNT_dec(main_cv);
349     main_cv = Nullcv;
350
351     if (sv_objcount) {
352         /*
353          * Try to destruct global references.  We do this first so that the
354          * destructors and destructees still exist.  Some sv's might remain.
355          * Non-referenced objects are on their own.
356          */
357     
358         dirty = TRUE;
359         sv_clean_objs();
360     }
361
362     /* unhook hooks which will soon be, or use, destroyed data */
363     SvREFCNT_dec(warnhook);
364     warnhook = Nullsv;
365     SvREFCNT_dec(diehook);
366     diehook = Nullsv;
367     SvREFCNT_dec(parsehook);
368     parsehook = Nullsv;
369
370     if (destruct_level == 0){
371
372         DEBUG_P(debprofdump());
373     
374         /* The exit() function will do everything that needs doing. */
375         return;
376     }
377
378     /* loosen bonds of global variables */
379
380     if(rsfp) {
381         (void)PerlIO_close(rsfp);
382         rsfp = Nullfp;
383     }
384
385     /* Filters for program text */
386     SvREFCNT_dec(rsfp_filters);
387     rsfp_filters = Nullav;
388
389     /* switches */
390     preprocess   = FALSE;
391     minus_n      = FALSE;
392     minus_p      = FALSE;
393     minus_l      = FALSE;
394     minus_a      = FALSE;
395     minus_F      = FALSE;
396     doswitches   = FALSE;
397     dowarn       = FALSE;
398     doextract    = FALSE;
399     sawampersand = FALSE;       /* must save all match strings */
400     sawstudy     = FALSE;       /* do fbm_instr on all strings */
401     sawvec       = FALSE;
402     unsafe       = FALSE;
403
404     Safefree(inplace);
405     inplace = Nullch;
406
407     Safefree(e_tmpname);
408     e_tmpname = Nullch;
409
410     if (e_fp) {
411         PerlIO_close(e_fp);
412         e_fp = Nullfp;
413     }
414
415     /* magical thingies */
416
417     Safefree(ofs);      /* $, */
418     ofs = Nullch;
419
420     Safefree(ors);      /* $\ */
421     ors = Nullch;
422
423     SvREFCNT_dec(nrs);  /* $\ helper */
424     nrs = Nullsv;
425
426     multiline = 0;      /* $* */
427
428     SvREFCNT_dec(statname);
429     statname = Nullsv;
430     statgv = Nullgv;
431
432     /* defgv, aka *_ should be taken care of elsewhere */
433
434 #if 0  /* just about all regexp stuff, seems to be ok */
435
436     /* shortcuts to regexp stuff */
437     leftgv = Nullgv;
438     ampergv = Nullgv;
439
440     SAVEFREEOP(curpm);
441     SAVEFREEOP(oldlastpm); /* for saving regexp context during debugger */
442
443     regprecomp = NULL;  /* uncompiled string. */
444     regparse = NULL;    /* Input-scan pointer. */
445     regxend = NULL;     /* End of input for compile */
446     regnpar = 0;        /* () count. */
447     regcode = NULL;     /* Code-emit pointer; &regdummy = don't. */
448     regsize = 0;        /* Code size. */
449     regnaughty = 0;     /* How bad is this pattern? */
450     regsawback = 0;     /* Did we see \1, ...? */
451
452     reginput = NULL;            /* String-input pointer. */
453     regbol = NULL;              /* Beginning of input, for ^ check. */
454     regeol = NULL;              /* End of input, for $ check. */
455     regstartp = (char **)NULL;  /* Pointer to startp array. */
456     regendp = (char **)NULL;    /* Ditto for endp. */
457     reglastparen = 0;           /* Similarly for lastparen. */
458     regtill = NULL;             /* How far we are required to go. */
459     regflags = 0;               /* are we folding, multilining? */
460     regprev = (char)NULL;       /* char before regbol, \n if none */
461
462 #endif /* if 0 */
463
464     /* clean up after study() */
465     SvREFCNT_dec(lastscream);
466     lastscream = Nullsv;
467     Safefree(screamfirst);
468     screamfirst = 0;
469     Safefree(screamnext);
470     screamnext  = 0;
471
472     /* startup and shutdown function lists */
473     SvREFCNT_dec(beginav);
474     SvREFCNT_dec(endav);
475     SvREFCNT_dec(initav);
476     beginav = Nullav;
477     endav = Nullav;
478     initav = Nullav;
479
480     /* temp stack during pp_sort() */
481     SvREFCNT_dec(sortstack);
482     sortstack = Nullav;
483
484     /* shortcuts just get cleared */
485     envgv = Nullgv;
486     siggv = Nullgv;
487     incgv = Nullgv;
488     errgv = Nullgv;
489     argvgv = Nullgv;
490     argvoutgv = Nullgv;
491     stdingv = Nullgv;
492     last_in_gv = Nullgv;
493
494     /* reset so print() ends up where we expect */
495     setdefout(Nullgv);
496
497     /* Prepare to destruct main symbol table.  */
498
499     hv = defstash;
500     defstash = 0;
501     SvREFCNT_dec(hv);
502
503     FREETMPS;
504     if (destruct_level >= 2) {
505         if (scopestack_ix != 0)
506             warn("Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
507                  (long)scopestack_ix);
508         if (savestack_ix != 0)
509             warn("Unbalanced saves: %ld more saves than restores\n",
510                  (long)savestack_ix);
511         if (tmps_floor != -1)
512             warn("Unbalanced tmps: %ld more allocs than frees\n",
513                  (long)tmps_floor + 1);
514         if (cxstack_ix != -1)
515             warn("Unbalanced context: %ld more PUSHes than POPs\n",
516                  (long)cxstack_ix + 1);
517     }
518
519     /* Now absolutely destruct everything, somehow or other, loops or no. */
520     last_sv_count = 0;
521     SvFLAGS(strtab) |= SVTYPEMASK;              /* don't clean out strtab now */
522     while (sv_count != 0 && sv_count != last_sv_count) {
523         last_sv_count = sv_count;
524         sv_clean_all();
525     }
526     SvFLAGS(strtab) &= ~SVTYPEMASK;
527     SvFLAGS(strtab) |= SVt_PVHV;
528     
529     /* Destruct the global string table. */
530     {
531         /* Yell and reset the HeVAL() slots that are still holding refcounts,
532          * so that sv_free() won't fail on them.
533          */
534         I32 riter;
535         I32 max;
536         HE *hent;
537         HE **array;
538
539         riter = 0;
540         max = HvMAX(strtab);
541         array = HvARRAY(strtab);
542         hent = array[0];
543         for (;;) {
544             if (hent) {
545                 warn("Unbalanced string table refcount: (%d) for \"%s\"",
546                      HeVAL(hent) - Nullsv, HeKEY(hent));
547                 HeVAL(hent) = Nullsv;
548                 hent = HeNEXT(hent);
549             }
550             if (!hent) {
551                 if (++riter > max)
552                     break;
553                 hent = array[riter];
554             }
555         }
556     }
557     SvREFCNT_dec(strtab);
558
559     if (sv_count != 0)
560         warn("Scalars leaked: %ld\n", (long)sv_count);
561
562     sv_free_arenas();
563
564     /* No SVs have survived, need to clean out */
565     linestr = NULL;
566     pidstatus = Nullhv;
567     if (origfilename)
568         Safefree(origfilename);
569     nuke_stacks();
570     hints = 0;          /* Reset hints. Should hints be per-interpreter ? */
571     
572     DEBUG_P(debprofdump());
573 #ifdef USE_THREADS
574     MUTEX_DESTROY(&sv_mutex);
575     MUTEX_DESTROY(&malloc_mutex);
576     MUTEX_DESTROY(&eval_mutex);
577     COND_DESTROY(&eval_cond);
578
579     /* As the penultimate thing, free the non-arena SV for thrsv */
580     Safefree(SvPVX(thrsv));
581     Safefree(SvANY(thrsv));
582     Safefree(thrsv);
583     thrsv = Nullsv;
584 #endif /* USE_THREADS */
585     
586     /* As the absolutely last thing, free the non-arena SV for mess() */
587
588     if (mess_sv) {
589         /* we know that type >= SVt_PV */
590         SvOOK_off(mess_sv);
591         Safefree(SvPVX(mess_sv));
592         Safefree(SvANY(mess_sv));
593         Safefree(mess_sv);
594         mess_sv = Nullsv;
595     }
596 }
597
598 void
599 perl_free(PerlInterpreter *sv_interp)
600 {
601     if (!(curinterp = sv_interp))
602         return;
603     Safefree(sv_interp);
604 }
605
606 int
607 perl_parse(PerlInterpreter *sv_interp, void (*xsinit) (void), int argc, char **argv, char **env)
608 {
609     dTHR;
610     register SV *sv;
611     register char *s;
612     char *scriptname = NULL;
613     VOL bool dosearch = FALSE;
614     char *validarg = "";
615     I32 oldscope;
616     AV* comppadlist;
617     dJMPENV;
618     int ret;
619
620 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
621 #ifdef IAMSUID
622 #undef IAMSUID
623     croak("suidperl is no longer needed since the kernel can now execute\n\
624 setuid perl scripts securely.\n");
625 #endif
626 #endif
627
628     if (!(curinterp = sv_interp))
629         return 255;
630
631 #if defined(NeXT) && defined(__DYNAMIC__)
632     _dyld_lookup_and_bind
633         ("__environ", (unsigned long *) &environ_pointer, NULL);
634 #endif /* environ */
635
636     origargv = argv;
637     origargc = argc;
638 #ifndef VMS  /* VMS doesn't have environ array */
639     origenviron = environ;
640 #endif
641     e_tmpname = Nullch;
642
643     if (do_undump) {
644
645         /* Come here if running an undumped a.out. */
646
647         origfilename = savepv(argv[0]);
648         do_undump = FALSE;
649         cxstack_ix = -1;                /* start label stack again */
650         init_ids();
651         init_postdump_symbols(argc,argv,env);
652         return 0;
653     }
654
655     if (main_root) {
656         curpad = AvARRAY(comppad);
657         op_free(main_root);
658         main_root = Nullop;
659     }
660     main_start = Nullop;
661     SvREFCNT_dec(main_cv);
662     main_cv = Nullcv;
663
664     time(&basetime);
665     oldscope = scopestack_ix;
666
667     JMPENV_PUSH(ret);
668     switch (ret) {
669     case 1:
670         STATUS_ALL_FAILURE;
671         /* FALL THROUGH */
672     case 2:
673         /* my_exit() was called */
674         while (scopestack_ix > oldscope)
675             LEAVE;
676         FREETMPS;
677         curstash = defstash;
678         if (endav)
679             call_list(oldscope, endav);
680         JMPENV_POP;
681         return STATUS_NATIVE_EXPORT;
682     case 3:
683         JMPENV_POP;
684         PerlIO_printf(PerlIO_stderr(), "panic: top_env\n");
685         return 1;
686     }
687
688     sv_setpvn(linestr,"",0);
689     sv = newSVpv("",0);         /* first used for -I flags */
690     SAVEFREESV(sv);
691     init_main_stash();
692
693     for (argc--,argv++; argc > 0; argc--,argv++) {
694         if (argv[0][0] != '-' || !argv[0][1])
695             break;
696 #ifdef DOSUID
697     if (*validarg)
698         validarg = " PHOOEY ";
699     else
700         validarg = argv[0];
701 #endif
702         s = argv[0]+1;
703       reswitch:
704         switch (*s) {
705         case '0':
706         case 'F':
707         case 'a':
708         case 'c':
709         case 'd':
710         case 'D':
711         case 'h':
712         case 'i':
713         case 'l':
714         case 'M':
715         case 'm':
716         case 'n':
717         case 'p':
718         case 's':
719         case 'u':
720         case 'U':
721         case 'v':
722         case 'w':
723             if (s = moreswitches(s))
724                 goto reswitch;
725             break;
726
727         case 'T':
728             tainting = TRUE;
729             s++;
730             goto reswitch;
731
732         case 'e':
733             if (euid != uid || egid != gid)
734                 croak("No -e allowed in setuid scripts");
735             if (!e_fp) {
736                 e_tmpname = savepv(TMPPATH);
737                 (void)mktemp(e_tmpname);
738                 if (!*e_tmpname)
739                     croak("Can't mktemp()");
740                 e_fp = PerlIO_open(e_tmpname,"w");
741                 if (!e_fp)
742                     croak("Cannot open temporary file");
743             }
744             if (*++s)
745                 PerlIO_puts(e_fp,s);
746             else if (argv[1]) {
747                 PerlIO_puts(e_fp,argv[1]);
748                 argc--,argv++;
749             }
750             else
751                 croak("No code specified for -e");
752             (void)PerlIO_putc(e_fp,'\n');
753             break;
754         case 'I':       /* -I handled both here and in moreswitches() */
755             forbid_setid("-I");
756             if (!*++s && (s=argv[1]) != Nullch) {
757                 argc--,argv++;
758             }
759             while (s && isSPACE(*s))
760                 ++s;
761             if (s && *s) {
762                 char *e, *p;
763                 for (e = s; *e && !isSPACE(*e); e++) ;
764                 p = savepvn(s, e-s);
765                 incpush(p, TRUE);
766                 sv_catpv(sv,"-I");
767                 sv_catpv(sv,p);
768                 sv_catpv(sv," ");
769                 Safefree(p);
770             }   /* XXX else croak? */
771             break;
772         case 'P':
773             forbid_setid("-P");
774             preprocess = TRUE;
775             s++;
776             goto reswitch;
777         case 'S':
778             forbid_setid("-S");
779             dosearch = TRUE;
780             s++;
781             goto reswitch;
782         case 'V':
783             if (!preambleav)
784                 preambleav = newAV();
785             av_push(preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
786             if (*++s != ':')  {
787                 Sv = newSVpv("print myconfig();",0);
788 #ifdef VMS
789                 sv_catpv(Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
790 #else
791                 sv_catpv(Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
792 #endif
793 #if defined(DEBUGGING) || defined(NO_EMBED) || defined(MULTIPLICITY)
794                 sv_catpv(Sv,"\"  Compile-time options:");
795 #  ifdef DEBUGGING
796                 sv_catpv(Sv," DEBUGGING");
797 #  endif
798 #  ifdef NO_EMBED
799                 sv_catpv(Sv," NO_EMBED");
800 #  endif
801 #  ifdef MULTIPLICITY
802                 sv_catpv(Sv," MULTIPLICITY");
803 #  endif
804                 sv_catpv(Sv,"\\n\",");
805 #endif
806 #if defined(LOCAL_PATCH_COUNT)
807                 if (LOCAL_PATCH_COUNT > 0) {
808                     int i;
809                     sv_catpv(Sv,"\"  Locally applied patches:\\n\",");
810                     for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
811                         if (localpatches[i])
812                             sv_catpvf(Sv,"\"  \\t%s\\n\",",localpatches[i]);
813                     }
814                 }
815 #endif
816                 sv_catpvf(Sv,"\"  Built under %s\\n\"",OSNAME);
817 #ifdef __DATE__
818 #  ifdef __TIME__
819                 sv_catpvf(Sv,",\"  Compiled at %s %s\\n\"",__DATE__,__TIME__);
820 #  else
821                 sv_catpvf(Sv,",\"  Compiled on %s\\n\"",__DATE__);
822 #  endif
823 #endif
824                 sv_catpv(Sv, "; \
825 $\"=\"\\n    \"; \
826 @env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; \
827 print \"  \\%ENV:\\n    @env\\n\" if @env; \
828 print \"  \\@INC:\\n    @INC\\n\";");
829             }
830             else {
831                 Sv = newSVpv("config_vars(qw(",0);
832                 sv_catpv(Sv, ++s);
833                 sv_catpv(Sv, "))");
834                 s += strlen(s);
835             }
836             av_push(preambleav, Sv);
837             scriptname = BIT_BUCKET;    /* don't look for script or read stdin */
838             goto reswitch;
839         case 'x':
840             doextract = TRUE;
841             s++;
842             if (*s)
843                 cddir = savepv(s);
844             break;
845         case 0:
846             break;
847         case '-':
848             if (!*++s || isSPACE(*s)) {
849                 argc--,argv++;
850                 goto switch_end;
851             }
852             /* catch use of gnu style long options */
853             if (strEQ(s, "version")) {
854                 s = "v";
855                 goto reswitch;
856             }
857             if (strEQ(s, "help")) {
858                 s = "h";
859                 goto reswitch;
860             }
861             s--;
862             /* FALL THROUGH */
863         default:
864             croak("Unrecognized switch: -%s  (-h will show valid options)",s);
865         }
866     }
867   switch_end:
868
869     if (!tainting && (s = getenv("PERL5OPT"))) {
870         while (s && *s) {
871             while (isSPACE(*s))
872                 s++;
873             if (*s == '-') {
874                 s++;
875                 if (isSPACE(*s))
876                     continue;
877             }
878             if (!*s)
879                 break;
880             if (!strchr("DIMUdmw", *s))
881                 croak("Illegal switch in PERL5OPT: -%c", *s);
882             s = moreswitches(s);
883         }
884     }
885
886     if (!scriptname)
887         scriptname = argv[0];
888     if (e_fp) {
889         if (PerlIO_flush(e_fp) || PerlIO_error(e_fp) || PerlIO_close(e_fp)) {
890 #ifndef MULTIPLICITY
891             warn("Did you forget to compile with -DMULTIPLICITY?");
892 #endif      
893             croak("Can't write to temp file for -e: %s", Strerror(errno));
894         }
895         e_fp = Nullfp;
896         argc++,argv--;
897         scriptname = e_tmpname;
898     }
899     else if (scriptname == Nullch) {
900 #ifdef MSDOS
901         if ( isatty(PerlIO_fileno(PerlIO_stdin())) )
902             moreswitches("h");
903 #endif
904         scriptname = "-";
905     }
906
907     init_perllib();
908
909     open_script(scriptname,dosearch,sv);
910
911     validate_suid(validarg, scriptname);
912
913     if (doextract)
914         find_beginning();
915
916     main_cv = compcv = (CV*)NEWSV(1104,0);
917     sv_upgrade((SV *)compcv, SVt_PVCV);
918     CvUNIQUE_on(compcv);
919
920     comppad = newAV();
921     av_push(comppad, Nullsv);
922     curpad = AvARRAY(comppad);
923     comppad_name = newAV();
924     comppad_name_fill = 0;
925     min_intro_pending = 0;
926     padix = 0;
927 #ifdef USE_THREADS
928     av_store(comppad_name, 0, newSVpv("@_", 2));
929     curpad[0] = (SV*)newAV();
930     SvPADMY_on(curpad[0]);      /* XXX Needed? */
931     CvOWNER(compcv) = 0;
932     New(666, CvMUTEXP(compcv), 1, perl_mutex);
933     MUTEX_INIT(CvMUTEXP(compcv));
934 #endif /* USE_THREADS */
935
936     comppadlist = newAV();
937     AvREAL_off(comppadlist);
938     av_store(comppadlist, 0, (SV*)comppad_name);
939     av_store(comppadlist, 1, (SV*)comppad);
940     CvPADLIST(compcv) = comppadlist;
941
942     boot_core_UNIVERSAL();
943     if (xsinit)
944         (*xsinit)();    /* in case linked C routines want magical variables */
945 #if defined(VMS) || defined(WIN32)
946     init_os_extras();
947 #endif
948
949 #if defined(DEBUGGING) && defined(USE_THREADS) && defined(__linux__)
950     DEBUG_L(signal(SIGSEGV, (void(*)(int))catch_sigsegv););
951 #endif
952
953     init_predump_symbols();
954     if (!do_undump)
955         init_postdump_symbols(argc,argv,env);
956
957     init_lexer();
958
959     /* now parse the script */
960
961     error_count = 0;
962     if (yyparse() || error_count) {
963         if (minus_c)
964             croak("%s had compilation errors.\n", origfilename);
965         else {
966             croak("Execution of %s aborted due to compilation errors.\n",
967                 origfilename);
968         }
969     }
970     curcop->cop_line = 0;
971     curstash = defstash;
972     preprocess = FALSE;
973     if (e_tmpname) {
974         (void)UNLINK(e_tmpname);
975         Safefree(e_tmpname);
976         e_tmpname = Nullch;
977     }
978
979     /* now that script is parsed, we can modify record separator */
980     SvREFCNT_dec(rs);
981     rs = SvREFCNT_inc(nrs);
982     sv_setsv(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), rs);
983
984     if (do_undump)
985         my_unexec();
986
987     if (dowarn)
988         gv_check(defstash);
989
990     LEAVE;
991     FREETMPS;
992
993 #ifdef MYMALLOC
994     if ((s=getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
995         dump_mstats("after compilation:");
996 #endif
997
998     ENTER;
999     restartop = 0;
1000     JMPENV_POP;
1001     return 0;
1002 }
1003
1004 int
1005 perl_run(PerlInterpreter *sv_interp)
1006 {
1007     dTHR;
1008     I32 oldscope;
1009     dJMPENV;
1010     int ret;
1011
1012     if (!(curinterp = sv_interp))
1013         return 255;
1014
1015     oldscope = scopestack_ix;
1016
1017     JMPENV_PUSH(ret);
1018     switch (ret) {
1019     case 1:
1020         cxstack_ix = -1;                /* start context stack again */
1021         break;
1022     case 2:
1023         /* my_exit() was called */
1024         while (scopestack_ix > oldscope)
1025             LEAVE;
1026         FREETMPS;
1027         curstash = defstash;
1028         if (endav)
1029             call_list(oldscope, endav);
1030 #ifdef MYMALLOC
1031         if (getenv("PERL_DEBUG_MSTATS"))
1032             dump_mstats("after execution:  ");
1033 #endif
1034         JMPENV_POP;
1035         return STATUS_NATIVE_EXPORT;
1036     case 3:
1037         if (!restartop) {
1038             PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
1039             FREETMPS;
1040             JMPENV_POP;
1041             return 1;
1042         }
1043         if (curstack != mainstack) {
1044             dSP;
1045             SWITCHSTACK(curstack, mainstack);
1046         }
1047         break;
1048     }
1049
1050     DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
1051                     sawampersand ? "Enabling" : "Omitting"));
1052
1053     if (!restartop) {
1054         DEBUG_x(dump_all());
1055         DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
1056 #ifdef USE_THREADS
1057         DEBUG_L(PerlIO_printf(Perl_debug_log, "main thread is 0x%lx\n",
1058                               (unsigned long) thr));
1059 #endif /* USE_THREADS */        
1060
1061         if (minus_c) {
1062             PerlIO_printf(PerlIO_stderr(), "%s syntax OK\n", origfilename);
1063             my_exit(0);
1064         }
1065         if (PERLDB_SINGLE && DBsingle)
1066            sv_setiv(DBsingle, 1); 
1067         if (initav)
1068             call_list(oldscope, initav);
1069     }
1070
1071     /* do it */
1072
1073     if (restartop) {
1074         op = restartop;
1075         restartop = 0;
1076         runops();
1077     }
1078     else if (main_start) {
1079         CvDEPTH(main_cv) = 1;
1080         op = main_start;
1081         runops();
1082     }
1083
1084     my_exit(0);
1085     /* NOTREACHED */
1086     return 0;
1087 }
1088
1089 SV*
1090 perl_get_sv(char *name, I32 create)
1091 {
1092     GV* gv = gv_fetchpv(name, create, SVt_PV);
1093     if (gv)
1094         return GvSV(gv);
1095     return Nullsv;
1096 }
1097
1098 AV*
1099 perl_get_av(char *name, I32 create)
1100 {
1101     GV* gv = gv_fetchpv(name, create, SVt_PVAV);
1102     if (create)
1103         return GvAVn(gv);
1104     if (gv)
1105         return GvAV(gv);
1106     return Nullav;
1107 }
1108
1109 HV*
1110 perl_get_hv(char *name, I32 create)
1111 {
1112     GV* gv = gv_fetchpv(name, create, SVt_PVHV);
1113     if (create)
1114         return GvHVn(gv);
1115     if (gv)
1116         return GvHV(gv);
1117     return Nullhv;
1118 }
1119
1120 CV*
1121 perl_get_cv(char *name, I32 create)
1122 {
1123     GV* gv = gv_fetchpv(name, create, SVt_PVCV);
1124     if (create && !GvCVu(gv))
1125         return newSUB(start_subparse(FALSE, 0),
1126                       newSVOP(OP_CONST, 0, newSVpv(name,0)),
1127                       Nullop,
1128                       Nullop);
1129     if (gv)
1130         return GvCVu(gv);
1131     return Nullcv;
1132 }
1133
1134 /* Be sure to refetch the stack pointer after calling these routines. */
1135
1136 I32
1137 perl_call_argv(char *subname, I32 flags, register char **argv)
1138               
1139                         /* See G_* flags in cop.h */
1140                         /* null terminated arg list */
1141 {
1142     dSP;
1143
1144     PUSHMARK(sp);
1145     if (argv) {
1146         while (*argv) {
1147             XPUSHs(sv_2mortal(newSVpv(*argv,0)));
1148             argv++;
1149         }
1150         PUTBACK;
1151     }
1152     return perl_call_pv(subname, flags);
1153 }
1154
1155 I32
1156 perl_call_pv(char *subname, I32 flags)
1157                         /* name of the subroutine */
1158                         /* See G_* flags in cop.h */
1159 {
1160     return perl_call_sv((SV*)perl_get_cv(subname, TRUE), flags);
1161 }
1162
1163 I32
1164 perl_call_method(char *methname, I32 flags)
1165                         /* name of the subroutine */
1166                         /* See G_* flags in cop.h */
1167 {
1168     dSP;
1169     OP myop;
1170     if (!op)
1171         op = &myop;
1172     XPUSHs(sv_2mortal(newSVpv(methname,0)));
1173     PUTBACK;
1174     pp_method(ARGS);
1175     return perl_call_sv(*stack_sp--, flags);
1176 }
1177
1178 /* May be called with any of a CV, a GV, or an SV containing the name. */
1179 I32
1180 perl_call_sv(SV *sv, I32 flags)
1181        
1182                         /* See G_* flags in cop.h */
1183 {
1184     dTHR;
1185     LOGOP myop;         /* fake syntax tree node */
1186     SV** sp = stack_sp;
1187     I32 oldmark;
1188     I32 retval;
1189     I32 oldscope;
1190     static CV *DBcv;
1191     bool oldcatch = CATCH_GET;
1192     dJMPENV;
1193     int ret;
1194     OP* oldop = op;
1195
1196     if (flags & G_DISCARD) {
1197         ENTER;
1198         SAVETMPS;
1199     }
1200
1201     Zero(&myop, 1, LOGOP);
1202     myop.op_next = Nullop;
1203     if (!(flags & G_NOARGS))
1204         myop.op_flags |= OPf_STACKED;
1205     myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1206                       (flags & G_ARRAY) ? OPf_WANT_LIST :
1207                       OPf_WANT_SCALAR);
1208     SAVEOP();
1209     op = (OP*)&myop;
1210
1211     EXTEND(stack_sp, 1);
1212     *++stack_sp = sv;
1213     oldmark = TOPMARK;
1214     oldscope = scopestack_ix;
1215
1216     if (PERLDB_SUB && curstash != debstash
1217            /* Handle first BEGIN of -d. */
1218           && (DBcv || (DBcv = GvCV(DBsub)))
1219            /* Try harder, since this may have been a sighandler, thus
1220             * curstash may be meaningless. */
1221           && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != debstash))
1222         op->op_private |= OPpENTERSUB_DB;
1223
1224     if (flags & G_EVAL) {
1225         cLOGOP->op_other = op;
1226         markstack_ptr--;
1227         /* we're trying to emulate pp_entertry() here */
1228         {
1229             register CONTEXT *cx;
1230             I32 gimme = GIMME_V;
1231             
1232             ENTER;
1233             SAVETMPS;
1234             
1235             push_return(op->op_next);
1236             PUSHBLOCK(cx, CXt_EVAL, stack_sp);
1237             PUSHEVAL(cx, 0, 0);
1238             eval_root = op;             /* Only needed so that goto works right. */
1239             
1240             in_eval = 1;
1241             if (flags & G_KEEPERR)
1242                 in_eval |= 4;
1243             else
1244                 sv_setpv(GvSV(errgv),"");
1245         }
1246         markstack_ptr++;
1247
1248         JMPENV_PUSH(ret);
1249         switch (ret) {
1250         case 0:
1251             break;
1252         case 1:
1253             STATUS_ALL_FAILURE;
1254             /* FALL THROUGH */
1255         case 2:
1256             /* my_exit() was called */
1257             curstash = defstash;
1258             FREETMPS;
1259             JMPENV_POP;
1260             if (statusvalue)
1261                 croak("Callback called exit");
1262             my_exit_jump();
1263             /* NOTREACHED */
1264         case 3:
1265             if (restartop) {
1266                 op = restartop;
1267                 restartop = 0;
1268                 break;
1269             }
1270             stack_sp = stack_base + oldmark;
1271             if (flags & G_ARRAY)
1272                 retval = 0;
1273             else {
1274                 retval = 1;
1275                 *++stack_sp = &sv_undef;
1276             }
1277             goto cleanup;
1278         }
1279     }
1280     else
1281         CATCH_SET(TRUE);
1282
1283     if (op == (OP*)&myop)
1284         op = pp_entersub(ARGS);
1285     if (op)
1286         runops();
1287     retval = stack_sp - (stack_base + oldmark);
1288     if ((flags & G_EVAL) && !(flags & G_KEEPERR))
1289         sv_setpv(GvSV(errgv),"");
1290
1291   cleanup:
1292     if (flags & G_EVAL) {
1293         if (scopestack_ix > oldscope) {
1294             SV **newsp;
1295             PMOP *newpm;
1296             I32 gimme;
1297             register CONTEXT *cx;
1298             I32 optype;
1299
1300             POPBLOCK(cx,newpm);
1301             POPEVAL(cx);
1302             pop_return();
1303             curpm = newpm;
1304             LEAVE;
1305         }
1306         JMPENV_POP;
1307     }
1308     else
1309         CATCH_SET(oldcatch);
1310
1311     if (flags & G_DISCARD) {
1312         stack_sp = stack_base + oldmark;
1313         retval = 0;
1314         FREETMPS;
1315         LEAVE;
1316     }
1317     op = oldop;
1318     return retval;
1319 }
1320
1321 /* Eval a string. The G_EVAL flag is always assumed. */
1322
1323 I32
1324 perl_eval_sv(SV *sv, I32 flags)
1325        
1326                         /* See G_* flags in cop.h */
1327 {
1328     dTHR;
1329     UNOP myop;          /* fake syntax tree node */
1330     SV** sp = stack_sp;
1331     I32 oldmark = sp - stack_base;
1332     I32 retval;
1333     I32 oldscope;
1334     dJMPENV;
1335     int ret;
1336     OP* oldop = op;
1337
1338     if (flags & G_DISCARD) {
1339         ENTER;
1340         SAVETMPS;
1341     }
1342
1343     SAVEOP();
1344     op = (OP*)&myop;
1345     Zero(op, 1, UNOP);
1346     EXTEND(stack_sp, 1);
1347     *++stack_sp = sv;
1348     oldscope = scopestack_ix;
1349
1350     if (!(flags & G_NOARGS))
1351         myop.op_flags = OPf_STACKED;
1352     myop.op_next = Nullop;
1353     myop.op_type = OP_ENTEREVAL;
1354     myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1355                       (flags & G_ARRAY) ? OPf_WANT_LIST :
1356                       OPf_WANT_SCALAR);
1357     if (flags & G_KEEPERR)
1358         myop.op_flags |= OPf_SPECIAL;
1359
1360     JMPENV_PUSH(ret);
1361     switch (ret) {
1362     case 0:
1363         break;
1364     case 1:
1365         STATUS_ALL_FAILURE;
1366         /* FALL THROUGH */
1367     case 2:
1368         /* my_exit() was called */
1369         curstash = defstash;
1370         FREETMPS;
1371         JMPENV_POP;
1372         if (statusvalue)
1373             croak("Callback called exit");
1374         my_exit_jump();
1375         /* NOTREACHED */
1376     case 3:
1377         if (restartop) {
1378             op = restartop;
1379             restartop = 0;
1380             break;
1381         }
1382         stack_sp = stack_base + oldmark;
1383         if (flags & G_ARRAY)
1384             retval = 0;
1385         else {
1386             retval = 1;
1387             *++stack_sp = &sv_undef;
1388         }
1389         goto cleanup;
1390     }
1391
1392     if (op == (OP*)&myop)
1393         op = pp_entereval(ARGS);
1394     if (op)
1395         runops();
1396     retval = stack_sp - (stack_base + oldmark);
1397     if (!(flags & G_KEEPERR))
1398         sv_setpv(GvSV(errgv),"");
1399
1400   cleanup:
1401     JMPENV_POP;
1402     if (flags & G_DISCARD) {
1403         stack_sp = stack_base + oldmark;
1404         retval = 0;
1405         FREETMPS;
1406         LEAVE;
1407     }
1408     op = oldop;
1409     return retval;
1410 }
1411
1412 SV*
1413 perl_eval_pv(char *p, I32 croak_on_error)
1414 {
1415     dSP;
1416     SV* sv = newSVpv(p, 0);
1417
1418     PUSHMARK(sp);
1419     perl_eval_sv(sv, G_SCALAR);
1420     SvREFCNT_dec(sv);
1421
1422     SPAGAIN;
1423     sv = POPs;
1424     PUTBACK;
1425
1426     if (croak_on_error && SvTRUE(GvSV(errgv)))
1427         croak(SvPVx(GvSV(errgv), na));
1428
1429     return sv;
1430 }
1431
1432 /* Require a module. */
1433
1434 void
1435 perl_require_pv(char *pv)
1436 {
1437     SV* sv = sv_newmortal();
1438     sv_setpv(sv, "require '");
1439     sv_catpv(sv, pv);
1440     sv_catpv(sv, "'");
1441     perl_eval_sv(sv, G_DISCARD);
1442 }
1443
1444 void
1445 magicname(char *sym, char *name, I32 namlen)
1446 {
1447     register GV *gv;
1448
1449     if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
1450         sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
1451 }
1452
1453 static void
1454 usage(char *name)               /* XXX move this out into a module ? */
1455            
1456 {
1457     /* This message really ought to be max 23 lines.
1458      * Removed -h because the user already knows that opton. Others? */
1459
1460     static char *usage[] = {
1461 "-0[octal]       specify record separator (\\0, if no argument)",
1462 "-a              autosplit mode with -n or -p (splits $_ into @F)",
1463 "-c              check syntax only (runs BEGIN and END blocks)",
1464 "-d[:debugger]   run scripts under debugger",
1465 "-D[number/list] set debugging flags (argument is a bit mask or flags)",
1466 "-e 'command'    one line of script. Several -e's allowed. Omit [programfile].",
1467 "-F/pattern/     split() pattern for autosplit (-a). The //'s are optional.",
1468 "-i[extension]   edit <> files in place (make backup if extension supplied)",
1469 "-Idirectory     specify @INC/#include directory (may be used more than once)",
1470 "-l[octal]       enable line ending processing, specifies line terminator",
1471 "-[mM][-]module.. executes `use/no module...' before executing your script.",
1472 "-n              assume 'while (<>) { ... }' loop around your script",
1473 "-p              assume loop like -n but print line also like sed",
1474 "-P              run script through C preprocessor before compilation",
1475 "-s              enable some switch parsing for switches after script name",
1476 "-S              look for the script using PATH environment variable",
1477 "-T              turn on tainting checks",
1478 "-u              dump core after parsing script",
1479 "-U              allow unsafe operations",
1480 "-v              print version number and patchlevel of perl",
1481 "-V[:variable]   print perl configuration information",
1482 "-w              TURN WARNINGS ON FOR COMPILATION OF YOUR SCRIPT. Recommended.",
1483 "-x[directory]   strip off text before #!perl line and perhaps cd to directory",
1484 "\n",
1485 NULL
1486 };
1487     char **p = usage;
1488
1489     printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
1490     while (*p)
1491         printf("\n  %s", *p++);
1492 }
1493
1494 /* This routine handles any switches that can be given during run */
1495
1496 char *
1497 moreswitches(char *s)
1498 {
1499     I32 numlen;
1500     U32 rschar;
1501
1502     switch (*s) {
1503     case '0':
1504         rschar = scan_oct(s, 4, &numlen);
1505         SvREFCNT_dec(nrs);
1506         if (rschar & ~((U8)~0))
1507             nrs = &sv_undef;
1508         else if (!rschar && numlen >= 2)
1509             nrs = newSVpv("", 0);
1510         else {
1511             char ch = rschar;
1512             nrs = newSVpv(&ch, 1);
1513         }
1514         return s + numlen;
1515     case 'F':
1516         minus_F = TRUE;
1517         splitstr = savepv(s + 1);
1518         s += strlen(s);
1519         return s;
1520     case 'a':
1521         minus_a = TRUE;
1522         s++;
1523         return s;
1524     case 'c':
1525         minus_c = TRUE;
1526         s++;
1527         return s;
1528     case 'd':
1529         forbid_setid("-d");
1530         s++;
1531         if (*s == ':' || *s == '=')  {
1532             my_setenv("PERL5DB", form("use Devel::%s;", ++s));
1533             s += strlen(s);
1534         }
1535         if (!perldb) {
1536             perldb = PERLDB_ALL;
1537             init_debugger();
1538         }
1539         return s;
1540     case 'D':
1541 #ifdef DEBUGGING
1542         forbid_setid("-D");
1543         if (isALPHA(s[1])) {
1544             static char debopts[] = "psltocPmfrxuLHXD";
1545             char *d;
1546
1547             for (s++; *s && (d = strchr(debopts,*s)); s++)
1548                 debug |= 1 << (d - debopts);
1549         }
1550         else {
1551             debug = atoi(s+1);
1552             for (s++; isDIGIT(*s); s++) ;
1553         }
1554         debug |= 0x80000000;
1555 #else
1556         warn("Recompile perl with -DDEBUGGING to use -D switch\n");
1557         for (s++; isALNUM(*s); s++) ;
1558 #endif
1559         /*SUPPRESS 530*/
1560         return s;
1561     case 'h':
1562         usage(origargv[0]);    
1563         exit(0);
1564     case 'i':
1565         if (inplace)
1566             Safefree(inplace);
1567         inplace = savepv(s+1);
1568         /*SUPPRESS 530*/
1569         for (s = inplace; *s && !isSPACE(*s); s++) ;
1570         if (*s)
1571             *s++ = '\0';
1572         return s;
1573     case 'I':   /* -I handled both here and in parse_perl() */
1574         forbid_setid("-I");
1575         ++s;
1576         while (*s && isSPACE(*s))
1577             ++s;
1578         if (*s) {
1579             char *e, *p;
1580             for (e = s; *e && !isSPACE(*e); e++) ;
1581             p = savepvn(s, e-s);
1582             incpush(p, TRUE);
1583             Safefree(p);
1584             s = e;
1585         }
1586         else
1587             croak("No space allowed after -I");
1588         return s;
1589     case 'l':
1590         minus_l = TRUE;
1591         s++;
1592         if (ors)
1593             Safefree(ors);
1594         if (isDIGIT(*s)) {
1595             ors = savepv("\n");
1596             orslen = 1;
1597             *ors = scan_oct(s, 3 + (*s == '0'), &numlen);
1598             s += numlen;
1599         }
1600         else {
1601             if (RsPARA(nrs)) {
1602                 ors = "\n\n";
1603                 orslen = 2;
1604             }
1605             else
1606                 ors = SvPV(nrs, orslen);
1607             ors = savepvn(ors, orslen);
1608         }
1609         return s;
1610     case 'M':
1611         forbid_setid("-M");     /* XXX ? */
1612         /* FALL THROUGH */
1613     case 'm':
1614         forbid_setid("-m");     /* XXX ? */
1615         if (*++s) {
1616             char *start;
1617             SV *sv;
1618             char *use = "use ";
1619             /* -M-foo == 'no foo'       */
1620             if (*s == '-') { use = "no "; ++s; }
1621             sv = newSVpv(use,0);
1622             start = s;
1623             /* We allow -M'Module qw(Foo Bar)'  */
1624             while(isALNUM(*s) || *s==':') ++s;
1625             if (*s != '=') {
1626                 sv_catpv(sv, start);
1627                 if (*(start-1) == 'm') {
1628                     if (*s != '\0')
1629                         croak("Can't use '%c' after -mname", *s);
1630                     sv_catpv( sv, " ()");
1631                 }
1632             } else {
1633                 sv_catpvn(sv, start, s-start);
1634                 sv_catpv(sv, " split(/,/,q{");
1635                 sv_catpv(sv, ++s);
1636                 sv_catpv(sv,    "})");
1637             }
1638             s += strlen(s);
1639             if (preambleav == NULL)
1640                 preambleav = newAV();
1641             av_push(preambleav, sv);
1642         }
1643         else
1644             croak("No space allowed after -%c", *(s-1));
1645         return s;
1646     case 'n':
1647         minus_n = TRUE;
1648         s++;
1649         return s;
1650     case 'p':
1651         minus_p = TRUE;
1652         s++;
1653         return s;
1654     case 's':
1655         forbid_setid("-s");
1656         doswitches = TRUE;
1657         s++;
1658         return s;
1659     case 'T':
1660         if (!tainting)
1661             croak("Too late for \"-T\" option");
1662         s++;
1663         return s;
1664     case 'u':
1665         do_undump = TRUE;
1666         s++;
1667         return s;
1668     case 'U':
1669         unsafe = TRUE;
1670         s++;
1671         return s;
1672     case 'v':
1673 #if defined(SUBVERSION) && SUBVERSION > 0
1674         printf("\nThis is perl, version 5.%03d_%02d built for %s",
1675             PATCHLEVEL, SUBVERSION, ARCHNAME);
1676 #else
1677         printf("\nThis is perl, version %s built for %s",
1678                 patchlevel, ARCHNAME);
1679 #endif
1680 #if defined(LOCAL_PATCH_COUNT)
1681         if (LOCAL_PATCH_COUNT > 0)
1682             printf("\n(with %d registered patch%s, see perl -V for more detail)",
1683                 LOCAL_PATCH_COUNT, (LOCAL_PATCH_COUNT!=1) ? "es" : "");
1684 #endif
1685
1686         printf("\n\nCopyright 1987-1997, Larry Wall\n");
1687 #ifdef MSDOS
1688         printf("\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
1689 #endif
1690 #ifdef DJGPP
1691         printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
1692 #endif
1693 #ifdef OS2
1694         printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
1695             "Version 5 port Copyright (c) 1994-1997, Andreas Kaiser, Ilya Zakharevich\n");
1696 #endif
1697 #ifdef atarist
1698         printf("atariST series port, ++jrb  bammi@cadence.com\n");
1699 #endif
1700         printf("\n\
1701 Perl may be copied only under the terms of either the Artistic License or the\n\
1702 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n");
1703         exit(0);
1704     case 'w':
1705         dowarn = TRUE;
1706         s++;
1707         return s;
1708     case '*':
1709     case ' ':
1710         if (s[1] == '-')        /* Additional switches on #! line. */
1711             return s+2;
1712         break;
1713     case '-':
1714     case 0:
1715     case '\n':
1716     case '\t':
1717         break;
1718 #ifdef ALTERNATE_SHEBANG
1719     case 'S':                   /* OS/2 needs -S on "extproc" line. */
1720         break;
1721 #endif
1722     case 'P':
1723         if (preprocess)
1724             return s+1;
1725         /* FALL THROUGH */
1726     default:
1727         croak("Can't emulate -%.1s on #! line",s);
1728     }
1729     return Nullch;
1730 }
1731
1732 /* compliments of Tom Christiansen */
1733
1734 /* unexec() can be found in the Gnu emacs distribution */
1735
1736 void
1737 my_unexec(void)
1738 {
1739 #ifdef UNEXEC
1740     SV*    prog;
1741     SV*    file;
1742     int    status;
1743     extern int etext;
1744
1745     prog = newSVpv(BIN_EXP);
1746     sv_catpv(prog, "/perl");
1747     file = newSVpv(origfilename);
1748     sv_catpv(file, ".perldump");
1749
1750     status = unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
1751     if (status)
1752         PerlIO_printf(PerlIO_stderr(), "unexec of %s into %s failed!\n",
1753                       SvPVX(prog), SvPVX(file));
1754     exit(status);
1755 #else
1756 #  ifdef VMS
1757 #    include <lib$routines.h>
1758      lib$signal(SS$_DEBUG);  /* ssdef.h #included from vmsish.h */
1759 #  else
1760     ABORT();            /* for use with undump */
1761 #  endif
1762 #endif
1763 }
1764
1765 static void
1766 init_main_stash(void)
1767 {
1768     dTHR;
1769     GV *gv;
1770
1771     /* Note that strtab is a rather special HV.  Assumptions are made
1772        about not iterating on it, and not adding tie magic to it.
1773        It is properly deallocated in perl_destruct() */
1774     strtab = newHV();
1775     HvSHAREKEYS_off(strtab);                    /* mandatory */
1776     Newz(506,((XPVHV*)SvANY(strtab))->xhv_array,
1777          sizeof(HE*) * (((XPVHV*)SvANY(strtab))->xhv_max + 1), char);
1778     
1779     curstash = defstash = newHV();
1780     curstname = newSVpv("main",4);
1781     gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
1782     SvREFCNT_dec(GvHV(gv));
1783     GvHV(gv) = (HV*)SvREFCNT_inc(defstash);
1784     SvREADONLY_on(gv);
1785     HvNAME(defstash) = savepv("main");
1786     incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
1787     GvMULTI_on(incgv);
1788     defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
1789     errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
1790     GvMULTI_on(errgv);
1791     (void)form("%240s","");     /* Preallocate temp - for immediate signals. */
1792     sv_grow(GvSV(errgv), 240);  /* Preallocate - for immediate signals. */
1793     sv_setpvn(GvSV(errgv), "", 0);
1794     curstash = defstash;
1795     compiling.cop_stash = defstash;
1796     debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
1797     /* We must init $/ before switches are processed. */
1798     sv_setpvn(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), "\n", 1);
1799 }
1800
1801 #ifdef CAN_PROTOTYPE
1802 static void
1803 open_script(char *scriptname, bool dosearch, SV *sv)
1804 #else
1805 static void
1806 open_script(scriptname,dosearch,sv)
1807 char *scriptname;
1808 bool dosearch;
1809 SV *sv;
1810 #endif
1811 {
1812     dTHR;
1813     char *xfound = Nullch;
1814     char *xfailed = Nullch;
1815     register char *s;
1816     I32 len;
1817     int retval;
1818 #if defined(DOSISH) && !defined(OS2) && !defined(atarist)
1819 #  define SEARCH_EXTS ".bat", ".cmd", NULL
1820 #  define MAX_EXT_LEN 4
1821 #endif
1822 #ifdef OS2
1823 #  define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
1824 #  define MAX_EXT_LEN 4
1825 #endif
1826 #ifdef VMS
1827 #  define SEARCH_EXTS ".pl", ".com", NULL
1828 #  define MAX_EXT_LEN 4
1829 #endif
1830     /* additional extensions to try in each dir if scriptname not found */
1831 #ifdef SEARCH_EXTS
1832     char *ext[] = { SEARCH_EXTS };
1833     int extidx = 0, i = 0;
1834     char *curext = Nullch;
1835 #else
1836 #  define MAX_EXT_LEN 0
1837 #endif
1838
1839     /*
1840      * If dosearch is true and if scriptname does not contain path
1841      * delimiters, search the PATH for scriptname.
1842      *
1843      * If SEARCH_EXTS is also defined, will look for each
1844      * scriptname{SEARCH_EXTS} whenever scriptname is not found
1845      * while searching the PATH.
1846      *
1847      * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
1848      * proceeds as follows:
1849      *   If DOSISH:
1850      *     + look for ./scriptname{,.foo,.bar}
1851      *     + search the PATH for scriptname{,.foo,.bar}
1852      *
1853      *   If !DOSISH:
1854      *     + look *only* in the PATH for scriptname{,.foo,.bar} (note
1855      *       this will not look in '.' if it's not in the PATH)
1856      */
1857
1858 #ifdef VMS
1859     if (dosearch) {
1860         int hasdir, idx = 0, deftypes = 1;
1861         bool seen_dot = 1;
1862
1863         hasdir = (strpbrk(scriptname,":[</") != Nullch) ;
1864         /* The first time through, just add SEARCH_EXTS to whatever we
1865          * already have, so we can check for default file types. */
1866         while (deftypes ||
1867                (!hasdir && my_trnlnm("DCL$PATH",tokenbuf,idx++)) )
1868         {
1869             if (deftypes) {
1870                 deftypes = 0;
1871                 *tokenbuf = '\0';
1872             }
1873             if ((strlen(tokenbuf) + strlen(scriptname)
1874                  + MAX_EXT_LEN) >= sizeof tokenbuf)
1875                 continue;       /* don't search dir with too-long name */
1876             strcat(tokenbuf, scriptname);
1877 #else  /* !VMS */
1878
1879 #ifdef DOSISH
1880     if (strEQ(scriptname, "-"))
1881         dosearch = 0;
1882     if (dosearch) {             /* Look in '.' first. */
1883         char *cur = scriptname;
1884 #ifdef SEARCH_EXTS
1885         if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
1886             while (ext[i])
1887                 if (strEQ(ext[i++],curext)) {
1888                     extidx = -1;                /* already has an ext */
1889                     break;
1890                 }
1891         do {
1892 #endif
1893             DEBUG_p(PerlIO_printf(Perl_debug_log,
1894                                   "Looking for %s\n",cur));
1895             if (Stat(cur,&statbuf) >= 0) {
1896                 dosearch = 0;
1897                 scriptname = cur;
1898 #ifdef SEARCH_EXTS
1899                 break;
1900 #endif
1901             }
1902 #ifdef SEARCH_EXTS
1903             if (cur == scriptname) {
1904                 len = strlen(scriptname);
1905                 if (len+MAX_EXT_LEN+1 >= sizeof(tokenbuf))
1906                     break;
1907                 cur = strcpy(tokenbuf, scriptname);
1908             }
1909         } while (extidx >= 0 && ext[extidx]     /* try an extension? */
1910                  && strcpy(tokenbuf+len, ext[extidx++]));
1911 #endif
1912     }
1913 #endif
1914
1915     if (dosearch && !strchr(scriptname, '/')
1916 #ifdef DOSISH
1917                  && !strchr(scriptname, '\\')
1918 #endif
1919                  && (s = getenv("PATH"))) {
1920         bool seen_dot = 0;
1921         
1922         bufend = s + strlen(s);
1923         while (s < bufend) {
1924 #if defined(atarist) || defined(DOSISH)
1925             for (len = 0; *s
1926 #  ifdef atarist
1927                     && *s != ','
1928 #  endif
1929                     && *s != ';'; len++, s++) {
1930                 if (len < sizeof tokenbuf)
1931                     tokenbuf[len] = *s;
1932             }
1933             if (len < sizeof tokenbuf)
1934                 tokenbuf[len] = '\0';
1935 #else  /* ! (atarist || DOSISH) */
1936             s = delimcpy(tokenbuf, tokenbuf + sizeof tokenbuf, s, bufend,
1937                         ':',
1938                         &len);
1939 #endif /* ! (atarist || DOSISH) */
1940             if (s < bufend)
1941                 s++;
1942             if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tokenbuf)
1943                 continue;       /* don't search dir with too-long name */
1944             if (len
1945 #if defined(atarist) || defined(DOSISH)
1946                 && tokenbuf[len - 1] != '/'
1947                 && tokenbuf[len - 1] != '\\'
1948 #endif
1949                )
1950                 tokenbuf[len++] = '/';
1951             if (len == 2 && tokenbuf[0] == '.')
1952                 seen_dot = 1;
1953             (void)strcpy(tokenbuf + len, scriptname);
1954 #endif  /* !VMS */
1955
1956 #ifdef SEARCH_EXTS
1957             len = strlen(tokenbuf);
1958             if (extidx > 0)     /* reset after previous loop */
1959                 extidx = 0;
1960             do {
1961 #endif
1962                 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tokenbuf));
1963                 retval = Stat(tokenbuf,&statbuf);
1964 #ifdef SEARCH_EXTS
1965             } while (  retval < 0               /* not there */
1966                     && extidx>=0 && ext[extidx] /* try an extension? */
1967                     && strcpy(tokenbuf+len, ext[extidx++])
1968                 );
1969 #endif
1970             if (retval < 0)
1971                 continue;
1972             if (S_ISREG(statbuf.st_mode)
1973                 && cando(S_IRUSR,TRUE,&statbuf)
1974 #ifndef DOSISH
1975                 && cando(S_IXUSR,TRUE,&statbuf)
1976 #endif
1977                 )
1978             {
1979                 xfound = tokenbuf;              /* bingo! */
1980                 break;
1981             }
1982             if (!xfailed)
1983                 xfailed = savepv(tokenbuf);
1984         }
1985 #ifndef DOSISH
1986         if (!xfound && !seen_dot && !xfailed && (Stat(scriptname,&statbuf) < 0))
1987 #endif
1988             seen_dot = 1;                       /* Disable message. */
1989         if (!xfound)
1990             croak("Can't %s %s%s%s",
1991                   (xfailed ? "execute" : "find"),
1992                   (xfailed ? xfailed : scriptname),
1993                   (xfailed ? "" : " on PATH"),
1994                   (xfailed || seen_dot) ? "" : ", '.' not in PATH");
1995         if (xfailed)
1996             Safefree(xfailed);
1997         scriptname = xfound;
1998     }
1999
2000     if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
2001         char *s = scriptname + 8;
2002         fdscript = atoi(s);
2003         while (isDIGIT(*s))
2004             s++;
2005         if (*s)
2006             scriptname = s + 1;
2007     }
2008     else
2009         fdscript = -1;
2010     origfilename = savepv(e_tmpname ? "-e" : scriptname);
2011     curcop->cop_filegv = gv_fetchfile(origfilename);
2012     if (strEQ(origfilename,"-"))
2013         scriptname = "";
2014     if (fdscript >= 0) {
2015         rsfp = PerlIO_fdopen(fdscript,"r");
2016 #if defined(HAS_FCNTL) && defined(F_SETFD)
2017         if (rsfp)
2018             fcntl(PerlIO_fileno(rsfp),F_SETFD,1);  /* ensure close-on-exec */
2019 #endif
2020     }
2021     else if (preprocess) {
2022         char *cpp_cfg = CPPSTDIN;
2023         SV *cpp = NEWSV(0,0);
2024         SV *cmd = NEWSV(0,0);
2025
2026         if (strEQ(cpp_cfg, "cppstdin"))
2027             sv_catpvf(cpp, "%s/", BIN_EXP);
2028         sv_catpv(cpp, cpp_cfg);
2029
2030         sv_catpv(sv,"-I");
2031         sv_catpv(sv,PRIVLIB_EXP);
2032
2033 #ifdef MSDOS
2034         sv_setpvf(cmd, "\
2035 sed %s -e \"/^[^#]/b\" \
2036  -e \"/^#[      ]*include[      ]/b\" \
2037  -e \"/^#[      ]*define[       ]/b\" \
2038  -e \"/^#[      ]*if[   ]/b\" \
2039  -e \"/^#[      ]*ifdef[        ]/b\" \
2040  -e \"/^#[      ]*ifndef[       ]/b\" \
2041  -e \"/^#[      ]*else/b\" \
2042  -e \"/^#[      ]*elif[         ]/b\" \
2043  -e \"/^#[      ]*undef[        ]/b\" \
2044  -e \"/^#[      ]*endif/b\" \
2045  -e \"s/^#.*//\" \
2046  %s | %_ -C %_ %s",
2047           (doextract ? "-e \"1,/^#/d\n\"" : ""),
2048 #else
2049         sv_setpvf(cmd, "\
2050 %s %s -e '/^[^#]/b' \
2051  -e '/^#[       ]*include[      ]/b' \
2052  -e '/^#[       ]*define[       ]/b' \
2053  -e '/^#[       ]*if[   ]/b' \
2054  -e '/^#[       ]*ifdef[        ]/b' \
2055  -e '/^#[       ]*ifndef[       ]/b' \
2056  -e '/^#[       ]*else/b' \
2057  -e '/^#[       ]*elif[         ]/b' \
2058  -e '/^#[       ]*undef[        ]/b' \
2059  -e '/^#[       ]*endif/b' \
2060  -e 's/^[       ]*#.*//' \
2061  %s | %_ -C %_ %s",
2062 #ifdef LOC_SED
2063           LOC_SED,
2064 #else
2065           "sed",
2066 #endif
2067           (doextract ? "-e '1,/^#/d\n'" : ""),
2068 #endif
2069           scriptname, cpp, sv, CPPMINUS);
2070         doextract = FALSE;
2071 #ifdef IAMSUID                          /* actually, this is caught earlier */
2072         if (euid != uid && !euid) {     /* if running suidperl */
2073 #ifdef HAS_SETEUID
2074             (void)seteuid(uid);         /* musn't stay setuid root */
2075 #else
2076 #ifdef HAS_SETREUID
2077             (void)setreuid((Uid_t)-1, uid);
2078 #else
2079 #ifdef HAS_SETRESUID
2080             (void)setresuid((Uid_t)-1, uid, (Uid_t)-1);
2081 #else
2082             setuid(uid);
2083 #endif
2084 #endif
2085 #endif
2086             if (geteuid() != uid)
2087                 croak("Can't do seteuid!\n");
2088         }
2089 #endif /* IAMSUID */
2090         rsfp = my_popen(SvPVX(cmd), "r");
2091         SvREFCNT_dec(cmd);
2092         SvREFCNT_dec(cpp);
2093     }
2094     else if (!*scriptname) {
2095         forbid_setid("program input from stdin");
2096         rsfp = PerlIO_stdin();
2097     }
2098     else {
2099         rsfp = PerlIO_open(scriptname,"r");
2100 #if defined(HAS_FCNTL) && defined(F_SETFD)
2101         if (rsfp)
2102             fcntl(PerlIO_fileno(rsfp),F_SETFD,1);  /* ensure close-on-exec */
2103 #endif
2104     }
2105     if (e_tmpname) {
2106         e_fp = rsfp;
2107     }
2108     if (!rsfp) {
2109 #ifdef DOSUID
2110 #ifndef IAMSUID         /* in case script is not readable before setuid */
2111         if (euid && Stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 &&
2112           statbuf.st_mode & (S_ISUID|S_ISGID)) {
2113             /* try again */
2114             execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
2115             croak("Can't do setuid\n");
2116         }
2117 #endif
2118 #endif
2119         croak("Can't open perl script \"%s\": %s\n",
2120           SvPVX(GvSV(curcop->cop_filegv)), Strerror(errno));
2121     }
2122 }
2123
2124 static void
2125 validate_suid(char *validarg, char *scriptname)
2126 {
2127     int which;
2128
2129     /* do we need to emulate setuid on scripts? */
2130
2131     /* This code is for those BSD systems that have setuid #! scripts disabled
2132      * in the kernel because of a security problem.  Merely defining DOSUID
2133      * in perl will not fix that problem, but if you have disabled setuid
2134      * scripts in the kernel, this will attempt to emulate setuid and setgid
2135      * on scripts that have those now-otherwise-useless bits set.  The setuid
2136      * root version must be called suidperl or sperlN.NNN.  If regular perl
2137      * discovers that it has opened a setuid script, it calls suidperl with
2138      * the same argv that it had.  If suidperl finds that the script it has
2139      * just opened is NOT setuid root, it sets the effective uid back to the
2140      * uid.  We don't just make perl setuid root because that loses the
2141      * effective uid we had before invoking perl, if it was different from the
2142      * uid.
2143      *
2144      * DOSUID must be defined in both perl and suidperl, and IAMSUID must
2145      * be defined in suidperl only.  suidperl must be setuid root.  The
2146      * Configure script will set this up for you if you want it.
2147      */
2148
2149 #ifdef DOSUID
2150     dTHR;
2151     char *s, *s2;
2152
2153     if (Fstat(PerlIO_fileno(rsfp),&statbuf) < 0)        /* normal stat is insecure */
2154         croak("Can't stat script \"%s\"",origfilename);
2155     if (fdscript < 0 && statbuf.st_mode & (S_ISUID|S_ISGID)) {
2156         I32 len;
2157
2158 #ifdef IAMSUID
2159 #ifndef HAS_SETREUID
2160         /* On this access check to make sure the directories are readable,
2161          * there is actually a small window that the user could use to make
2162          * filename point to an accessible directory.  So there is a faint
2163          * chance that someone could execute a setuid script down in a
2164          * non-accessible directory.  I don't know what to do about that.
2165          * But I don't think it's too important.  The manual lies when
2166          * it says access() is useful in setuid programs.
2167          */
2168         if (access(SvPVX(GvSV(curcop->cop_filegv)),1))  /*double check*/
2169             croak("Permission denied");
2170 #else
2171         /* If we can swap euid and uid, then we can determine access rights
2172          * with a simple stat of the file, and then compare device and
2173          * inode to make sure we did stat() on the same file we opened.
2174          * Then we just have to make sure he or she can execute it.
2175          */
2176         {
2177             struct stat tmpstatbuf;
2178
2179             if (
2180 #ifdef HAS_SETREUID
2181                 setreuid(euid,uid) < 0
2182 #else
2183 # if HAS_SETRESUID
2184                 setresuid(euid,uid,(Uid_t)-1) < 0
2185 # endif
2186 #endif
2187                 || getuid() != euid || geteuid() != uid)
2188                 croak("Can't swap uid and euid");       /* really paranoid */
2189             if (Stat(SvPVX(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0)
2190                 croak("Permission denied");     /* testing full pathname here */
2191             if (tmpstatbuf.st_dev != statbuf.st_dev ||
2192                 tmpstatbuf.st_ino != statbuf.st_ino) {
2193                 (void)PerlIO_close(rsfp);
2194                 if (rsfp = my_popen("/bin/mail root","w")) {    /* heh, heh */
2195                     PerlIO_printf(rsfp,
2196 "User %ld tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
2197 (Filename of set-id script was %s, uid %ld gid %ld.)\n\nSincerely,\nperl\n",
2198                         (long)uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
2199                         (long)statbuf.st_dev, (long)statbuf.st_ino,
2200                         SvPVX(GvSV(curcop->cop_filegv)),
2201                         (long)statbuf.st_uid, (long)statbuf.st_gid);
2202                     (void)my_pclose(rsfp);
2203                 }
2204                 croak("Permission denied\n");
2205             }
2206             if (
2207 #ifdef HAS_SETREUID
2208               setreuid(uid,euid) < 0
2209 #else
2210 # if defined(HAS_SETRESUID)
2211               setresuid(uid,euid,(Uid_t)-1) < 0
2212 # endif
2213 #endif
2214               || getuid() != uid || geteuid() != euid)
2215                 croak("Can't reswap uid and euid");
2216             if (!cando(S_IXUSR,FALSE,&statbuf))         /* can real uid exec? */
2217                 croak("Permission denied\n");
2218         }
2219 #endif /* HAS_SETREUID */
2220 #endif /* IAMSUID */
2221
2222         if (!S_ISREG(statbuf.st_mode))
2223             croak("Permission denied");
2224         if (statbuf.st_mode & S_IWOTH)
2225             croak("Setuid/gid script is writable by world");
2226         doswitches = FALSE;             /* -s is insecure in suid */
2227         curcop->cop_line++;
2228         if (sv_gets(linestr, rsfp, 0) == Nullch ||
2229           strnNE(SvPV(linestr,na),"#!",2) )     /* required even on Sys V */
2230             croak("No #! line");
2231         s = SvPV(linestr,na)+2;
2232         if (*s == ' ') s++;
2233         while (!isSPACE(*s)) s++;
2234         for (s2 = s;  (s2 > SvPV(linestr,na)+2 &&
2235                        (isDIGIT(s2[-1]) || strchr("._-", s2[-1])));  s2--) ;
2236         if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4))  /* sanity check */
2237             croak("Not a perl script");
2238         while (*s == ' ' || *s == '\t') s++;
2239         /*
2240          * #! arg must be what we saw above.  They can invoke it by
2241          * mentioning suidperl explicitly, but they may not add any strange
2242          * arguments beyond what #! says if they do invoke suidperl that way.
2243          */
2244         len = strlen(validarg);
2245         if (strEQ(validarg," PHOOEY ") ||
2246             strnNE(s,validarg,len) || !isSPACE(s[len]))
2247             croak("Args must match #! line");
2248
2249 #ifndef IAMSUID
2250         if (euid != uid && (statbuf.st_mode & S_ISUID) &&
2251             euid == statbuf.st_uid)
2252             if (!do_undump)
2253                 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2254 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2255 #endif /* IAMSUID */
2256
2257         if (euid) {     /* oops, we're not the setuid root perl */
2258             (void)PerlIO_close(rsfp);
2259 #ifndef IAMSUID
2260             /* try again */
2261             execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
2262 #endif
2263             croak("Can't do setuid\n");
2264         }
2265
2266         if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid) {
2267 #ifdef HAS_SETEGID
2268             (void)setegid(statbuf.st_gid);
2269 #else
2270 #ifdef HAS_SETREGID
2271            (void)setregid((Gid_t)-1,statbuf.st_gid);
2272 #else
2273 #ifdef HAS_SETRESGID
2274            (void)setresgid((Gid_t)-1,statbuf.st_gid,(Gid_t)-1);
2275 #else
2276             setgid(statbuf.st_gid);
2277 #endif
2278 #endif
2279 #endif
2280             if (getegid() != statbuf.st_gid)
2281                 croak("Can't do setegid!\n");
2282         }
2283         if (statbuf.st_mode & S_ISUID) {
2284             if (statbuf.st_uid != euid)
2285 #ifdef HAS_SETEUID
2286                 (void)seteuid(statbuf.st_uid);  /* all that for this */
2287 #else
2288 #ifdef HAS_SETREUID
2289                 (void)setreuid((Uid_t)-1,statbuf.st_uid);
2290 #else
2291 #ifdef HAS_SETRESUID
2292                 (void)setresuid((Uid_t)-1,statbuf.st_uid,(Uid_t)-1);
2293 #else
2294                 setuid(statbuf.st_uid);
2295 #endif
2296 #endif
2297 #endif
2298             if (geteuid() != statbuf.st_uid)
2299                 croak("Can't do seteuid!\n");
2300         }
2301         else if (uid) {                 /* oops, mustn't run as root */
2302 #ifdef HAS_SETEUID
2303           (void)seteuid((Uid_t)uid);
2304 #else
2305 #ifdef HAS_SETREUID
2306           (void)setreuid((Uid_t)-1,(Uid_t)uid);
2307 #else
2308 #ifdef HAS_SETRESUID
2309           (void)setresuid((Uid_t)-1,(Uid_t)uid,(Uid_t)-1);
2310 #else
2311           setuid((Uid_t)uid);
2312 #endif
2313 #endif
2314 #endif
2315             if (geteuid() != uid)
2316                 croak("Can't do seteuid!\n");
2317         }
2318         init_ids();
2319         if (!cando(S_IXUSR,TRUE,&statbuf))
2320             croak("Permission denied\n");       /* they can't do this */
2321     }
2322 #ifdef IAMSUID
2323     else if (preprocess)
2324         croak("-P not allowed for setuid/setgid script\n");
2325     else if (fdscript >= 0)
2326         croak("fd script not allowed in suidperl\n");
2327     else
2328         croak("Script is not setuid/setgid in suidperl\n");
2329
2330     /* We absolutely must clear out any saved ids here, so we */
2331     /* exec the real perl, substituting fd script for scriptname. */
2332     /* (We pass script name as "subdir" of fd, which perl will grok.) */
2333     PerlIO_rewind(rsfp);
2334     lseek(PerlIO_fileno(rsfp),(Off_t)0,0);  /* just in case rewind didn't */
2335     for (which = 1; origargv[which] && origargv[which] != scriptname; which++) ;
2336     if (!origargv[which])
2337         croak("Permission denied");
2338     origargv[which] = savepv(form("/dev/fd/%d/%s",
2339                                   PerlIO_fileno(rsfp), origargv[which]));
2340 #if defined(HAS_FCNTL) && defined(F_SETFD)
2341     fcntl(PerlIO_fileno(rsfp),F_SETFD,0);       /* ensure no close-on-exec */
2342 #endif
2343     execv(form("%s/perl%s", BIN_EXP, patchlevel), origargv);    /* try again */
2344     croak("Can't do setuid\n");
2345 #endif /* IAMSUID */
2346 #else /* !DOSUID */
2347     if (euid != uid || egid != gid) {   /* (suidperl doesn't exist, in fact) */
2348 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
2349         dTHR;
2350         Fstat(PerlIO_fileno(rsfp),&statbuf);    /* may be either wrapped or real suid */
2351         if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
2352             ||
2353             (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
2354            )
2355             if (!do_undump)
2356                 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2357 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2358 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
2359         /* not set-id, must be wrapped */
2360     }
2361 #endif /* DOSUID */
2362 }
2363
2364 static void
2365 find_beginning(void)
2366 {
2367     register char *s, *s2;
2368
2369     /* skip forward in input to the real script? */
2370
2371     forbid_setid("-x");
2372     while (doextract) {
2373         if ((s = sv_gets(linestr, rsfp, 0)) == Nullch)
2374             croak("No Perl script found in input\n");
2375         if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
2376             PerlIO_ungetc(rsfp, '\n');          /* to keep line count right */
2377             doextract = FALSE;
2378             while (*s && !(isSPACE (*s) || *s == '#')) s++;
2379             s2 = s;
2380             while (*s == ' ' || *s == '\t') s++;
2381             if (*s++ == '-') {
2382                 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
2383                 if (strnEQ(s2-4,"perl",4))
2384                     /*SUPPRESS 530*/
2385                     while (s = moreswitches(s)) ;
2386             }
2387             if (cddir && chdir(cddir) < 0)
2388                 croak("Can't chdir to %s",cddir);
2389         }
2390     }
2391 }
2392
2393 static void
2394 init_ids(void)
2395 {
2396     uid = (int)getuid();
2397     euid = (int)geteuid();
2398     gid = (int)getgid();
2399     egid = (int)getegid();
2400 #ifdef VMS
2401     uid |= gid << 16;
2402     euid |= egid << 16;
2403 #endif
2404     tainting |= (uid && (euid != uid || egid != gid));
2405 }
2406
2407 static void
2408 forbid_setid(char *s)
2409 {
2410     if (euid != uid)
2411         croak("No %s allowed while running setuid", s);
2412     if (egid != gid)
2413         croak("No %s allowed while running setgid", s);
2414 }
2415
2416 static void
2417 init_debugger(void)
2418 {
2419     dTHR;
2420     curstash = debstash;
2421     dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
2422     AvREAL_off(dbargs);
2423     DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2424     DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
2425     DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
2426     DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
2427     sv_setiv(DBsingle, 0); 
2428     DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
2429     sv_setiv(DBtrace, 0); 
2430     DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
2431     sv_setiv(DBsignal, 0); 
2432     curstash = defstash;
2433 }
2434
2435 void
2436 init_stacks(ARGSproto)
2437 {
2438     curstack = newAV();
2439     mainstack = curstack;               /* remember in case we switch stacks */
2440     AvREAL_off(curstack);               /* not a real array */
2441     av_extend(curstack,127);
2442
2443     stack_base = AvARRAY(curstack);
2444     stack_sp = stack_base;
2445     stack_max = stack_base + 127;
2446
2447     cxstack_max = 8192 / sizeof(CONTEXT) - 2;   /* Use most of 8K. */
2448     New(50,cxstack,cxstack_max + 1,CONTEXT);
2449     cxstack_ix  = -1;
2450
2451     New(50,tmps_stack,128,SV*);
2452     tmps_floor = -1;
2453     tmps_ix = -1;
2454     tmps_max = 128;
2455
2456     /*
2457      * The following stacks almost certainly should be per-interpreter,
2458      * but for now they're not.  XXX
2459      */
2460
2461     if (markstack) {
2462         markstack_ptr = markstack;
2463     } else {
2464         New(54,markstack,64,I32);
2465         markstack_ptr = markstack;
2466         markstack_max = markstack + 64;
2467     }
2468
2469     if (scopestack) {
2470         scopestack_ix = 0;
2471     } else {
2472         New(54,scopestack,32,I32);
2473         scopestack_ix = 0;
2474         scopestack_max = 32;
2475     }
2476
2477     if (savestack) {
2478         savestack_ix = 0;
2479     } else {
2480         New(54,savestack,128,ANY);
2481         savestack_ix = 0;
2482         savestack_max = 128;
2483     }
2484
2485     if (retstack) {
2486         retstack_ix = 0;
2487     } else {
2488         New(54,retstack,16,OP*);
2489         retstack_ix = 0;
2490         retstack_max = 16;
2491     }
2492 }
2493
2494 static void
2495 nuke_stacks(void)
2496 {
2497     dTHR;
2498     Safefree(cxstack);
2499     Safefree(tmps_stack);
2500     DEBUG( {
2501         Safefree(debname);
2502         Safefree(debdelim);
2503     } )
2504 }
2505
2506 static PerlIO *tmpfp;  /* moved outside init_lexer() because of UNICOS bug */
2507
2508 static void
2509 init_lexer(void)
2510 {
2511     tmpfp = rsfp;
2512     rsfp = Nullfp;
2513     lex_start(linestr);
2514     rsfp = tmpfp;
2515     subname = newSVpv("main",4);
2516 }
2517
2518 static void
2519 init_predump_symbols(void)
2520 {
2521     dTHR;
2522     GV *tmpgv;
2523     GV *othergv;
2524
2525     sv_setpvn(GvSV(gv_fetchpv("\"", TRUE, SVt_PV)), " ", 1);
2526
2527     stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2528     GvMULTI_on(stdingv);
2529     IoIFP(GvIOp(stdingv)) = PerlIO_stdin();
2530     tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
2531     GvMULTI_on(tmpgv);
2532     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(stdingv));
2533
2534     tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2535     GvMULTI_on(tmpgv);
2536     IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = PerlIO_stdout();
2537     setdefout(tmpgv);
2538     tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2539     GvMULTI_on(tmpgv);
2540     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(defoutgv));
2541
2542     othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2543     GvMULTI_on(othergv);
2544     IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = PerlIO_stderr();
2545     tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
2546     GvMULTI_on(tmpgv);
2547     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv));
2548
2549     statname = NEWSV(66,0);             /* last filename we did stat on */
2550
2551     if (!osname)
2552         osname = savepv(OSNAME);
2553 }
2554
2555 static void
2556 init_postdump_symbols(register int argc, register char **argv, register char **env)
2557 {
2558     char *s;
2559     SV *sv;
2560     GV* tmpgv;
2561
2562     argc--,argv++;      /* skip name of script */
2563     if (doswitches) {
2564         for (; argc > 0 && **argv == '-'; argc--,argv++) {
2565             if (!argv[0][1])
2566                 break;
2567             if (argv[0][1] == '-') {
2568                 argc--,argv++;
2569                 break;
2570             }
2571             if (s = strchr(argv[0], '=')) {
2572                 *s++ = '\0';
2573                 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
2574             }
2575             else
2576                 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
2577         }
2578     }
2579     toptarget = NEWSV(0,0);
2580     sv_upgrade(toptarget, SVt_PVFM);
2581     sv_setpvn(toptarget, "", 0);
2582     bodytarget = NEWSV(0,0);
2583     sv_upgrade(bodytarget, SVt_PVFM);
2584     sv_setpvn(bodytarget, "", 0);
2585     formtarget = bodytarget;
2586
2587     TAINT;
2588     if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
2589         sv_setpv(GvSV(tmpgv),origfilename);
2590         magicname("0", "0", 1);
2591     }
2592     if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
2593         sv_setpv(GvSV(tmpgv),origargv[0]);
2594     if (argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
2595         GvMULTI_on(argvgv);
2596         (void)gv_AVadd(argvgv);
2597         av_clear(GvAVn(argvgv));
2598         for (; argc > 0; argc--,argv++) {
2599             av_push(GvAVn(argvgv),newSVpv(argv[0],0));
2600         }
2601     }
2602     if (envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
2603         HV *hv;
2604         GvMULTI_on(envgv);
2605         hv = GvHVn(envgv);
2606         hv_magic(hv, envgv, 'E');
2607 #ifndef VMS  /* VMS doesn't have environ array */
2608         /* Note that if the supplied env parameter is actually a copy
2609            of the global environ then it may now point to free'd memory
2610            if the environment has been modified since. To avoid this
2611            problem we treat env==NULL as meaning 'use the default'
2612         */
2613         if (!env)
2614             env = environ;
2615         if (env != environ)
2616             environ[0] = Nullch;
2617         for (; *env; env++) {
2618             if (!(s = strchr(*env,'=')))
2619                 continue;
2620             *s++ = '\0';
2621 #ifdef WIN32
2622             (void)strupr(*env);
2623 #endif
2624             sv = newSVpv(s--,0);
2625             (void)hv_store(hv, *env, s - *env, sv, 0);
2626             *s = '=';
2627 #if defined(__BORLANDC__) && defined(USE_WIN32_RTL_ENV)
2628             /* Sins of the RTL. See note in my_setenv(). */
2629             (void)putenv(savepv(*env));
2630 #endif
2631         }
2632 #endif
2633 #ifdef DYNAMIC_ENV_FETCH
2634         HvNAME(hv) = savepv(ENV_HV_NAME);
2635 #endif
2636     }
2637     TAINT_NOT;
2638     if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
2639         sv_setiv(GvSV(tmpgv), (IV)getpid());
2640 }
2641
2642 static void
2643 init_perllib(void)
2644 {
2645     char *s;
2646     if (!tainting) {
2647 #ifndef VMS
2648         s = getenv("PERL5LIB");
2649         if (s)
2650             incpush(s, TRUE);
2651         else
2652             incpush(getenv("PERLLIB"), FALSE);
2653 #else /* VMS */
2654         /* Treat PERL5?LIB as a possible search list logical name -- the
2655          * "natural" VMS idiom for a Unix path string.  We allow each
2656          * element to be a set of |-separated directories for compatibility.
2657          */
2658         char buf[256];
2659         int idx = 0;
2660         if (my_trnlnm("PERL5LIB",buf,0))
2661             do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
2662         else
2663             while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
2664 #endif /* VMS */
2665     }
2666
2667 /* Use the ~-expanded versions of APPLLIB (undocumented),
2668     ARCHLIB PRIVLIB SITEARCH SITELIB and OLDARCHLIB
2669 */
2670 #ifdef APPLLIB_EXP
2671     incpush(APPLLIB_EXP, FALSE);
2672 #endif
2673
2674 #ifdef ARCHLIB_EXP
2675     incpush(ARCHLIB_EXP, FALSE);
2676 #endif
2677 #ifndef PRIVLIB_EXP
2678 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
2679 #endif
2680     incpush(PRIVLIB_EXP, FALSE);
2681
2682 #ifdef SITEARCH_EXP
2683     incpush(SITEARCH_EXP, FALSE);
2684 #endif
2685 #ifdef SITELIB_EXP
2686     incpush(SITELIB_EXP, FALSE);
2687 #endif
2688 #ifdef OLDARCHLIB_EXP  /* 5.00[01] compatibility */
2689     incpush(OLDARCHLIB_EXP, FALSE);
2690 #endif
2691     
2692     if (!tainting)
2693         incpush(".", FALSE);
2694 }
2695
2696 #if defined(DOSISH)
2697 #    define PERLLIB_SEP ';'
2698 #else
2699 #  if defined(VMS)
2700 #    define PERLLIB_SEP '|'
2701 #  else
2702 #    define PERLLIB_SEP ':'
2703 #  endif
2704 #endif
2705 #ifndef PERLLIB_MANGLE
2706 #  define PERLLIB_MANGLE(s,n) (s)
2707 #endif 
2708
2709 static void
2710 incpush(char *p, int addsubdirs)
2711 {
2712     SV *subdir = Nullsv;
2713     static char *archpat_auto;
2714
2715     if (!p)
2716         return;
2717
2718     if (addsubdirs) {
2719         subdir = newSV(0);
2720         if (!archpat_auto) {
2721             STRLEN len = (sizeof(ARCHNAME) + strlen(patchlevel)
2722                           + sizeof("//auto"));
2723             New(55, archpat_auto, len, char);
2724             sprintf(archpat_auto, "/%s/%s/auto", ARCHNAME, patchlevel);
2725 #ifdef VMS
2726         for (len = sizeof(ARCHNAME) + 2;
2727              archpat_auto[len] != '\0' && archpat_auto[len] != '/'; len++)
2728                 if (archpat_auto[len] == '.') archpat_auto[len] = '_';
2729 #endif
2730         }
2731     }
2732
2733     /* Break at all separators */
2734     while (p && *p) {
2735         SV *libdir = newSV(0);
2736         char *s;
2737
2738         /* skip any consecutive separators */
2739         while ( *p == PERLLIB_SEP ) {
2740             /* Uncomment the next line for PATH semantics */
2741             /* av_push(GvAVn(incgv), newSVpv(".", 1)); */
2742             p++;
2743         }
2744
2745         if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
2746             sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
2747                       (STRLEN)(s - p));
2748             p = s + 1;
2749         }
2750         else {
2751             sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
2752             p = Nullch; /* break out */
2753         }
2754
2755         /*
2756          * BEFORE pushing libdir onto @INC we may first push version- and
2757          * archname-specific sub-directories.
2758          */
2759         if (addsubdirs) {
2760             struct stat tmpstatbuf;
2761 #ifdef VMS
2762             char *unix;
2763             STRLEN len;
2764
2765             if ((unix = tounixspec_ts(SvPV(libdir,na),Nullch)) != Nullch) {
2766                 len = strlen(unix);
2767                 while (unix[len-1] == '/') len--;  /* Cosmetic */
2768                 sv_usepvn(libdir,unix,len);
2769             }
2770             else
2771                 PerlIO_printf(PerlIO_stderr(),
2772                               "Failed to unixify @INC element \"%s\"\n",
2773                               SvPV(libdir,na));
2774 #endif
2775             /* .../archname/version if -d .../archname/version/auto */
2776             sv_setsv(subdir, libdir);
2777             sv_catpv(subdir, archpat_auto);
2778             if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2779                   S_ISDIR(tmpstatbuf.st_mode))
2780                 av_push(GvAVn(incgv),
2781                         newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2782
2783             /* .../archname if -d .../archname/auto */
2784             sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME),
2785                       strlen(patchlevel) + 1, "", 0);
2786             if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2787                   S_ISDIR(tmpstatbuf.st_mode))
2788                 av_push(GvAVn(incgv),
2789                         newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2790         }
2791
2792         /* finally push this lib directory on the end of @INC */
2793         av_push(GvAVn(incgv), libdir);
2794     }
2795
2796     SvREFCNT_dec(subdir);
2797 }
2798
2799 void
2800 call_list(I32 oldscope, AV *list)
2801 {
2802     dTHR;
2803     line_t oldline = curcop->cop_line;
2804     STRLEN len;
2805     dJMPENV;
2806     int ret;
2807
2808     while (AvFILL(list) >= 0) {
2809         CV *cv = (CV*)av_shift(list);
2810
2811         SAVEFREESV(cv);
2812
2813         JMPENV_PUSH(ret);
2814         switch (ret) {
2815         case 0: {
2816                 SV* atsv = GvSV(errgv);
2817                 PUSHMARK(stack_sp);
2818                 perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
2819                 (void)SvPV(atsv, len);
2820                 if (len) {
2821                     JMPENV_POP;
2822                     curcop = &compiling;
2823                     curcop->cop_line = oldline;
2824                     if (list == beginav)
2825                         sv_catpv(atsv, "BEGIN failed--compilation aborted");
2826                     else
2827                         sv_catpv(atsv, "END failed--cleanup aborted");
2828                     while (scopestack_ix > oldscope)
2829                         LEAVE;
2830                     croak("%s", SvPVX(atsv));
2831                 }
2832             }
2833             break;
2834         case 1:
2835             STATUS_ALL_FAILURE;
2836             /* FALL THROUGH */
2837         case 2:
2838             /* my_exit() was called */
2839             while (scopestack_ix > oldscope)
2840                 LEAVE;
2841             FREETMPS;
2842             curstash = defstash;
2843             if (endav)
2844                 call_list(oldscope, endav);
2845             JMPENV_POP;
2846             curcop = &compiling;
2847             curcop->cop_line = oldline;
2848             if (statusvalue) {
2849                 if (list == beginav)
2850                     croak("BEGIN failed--compilation aborted");
2851                 else
2852                     croak("END failed--cleanup aborted");
2853             }
2854             my_exit_jump();
2855             /* NOTREACHED */
2856         case 3:
2857             if (!restartop) {
2858                 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
2859                 FREETMPS;
2860                 break;
2861             }
2862             JMPENV_POP;
2863             curcop = &compiling;
2864             curcop->cop_line = oldline;
2865             JMPENV_JUMP(3);
2866         }
2867         JMPENV_POP;
2868     }
2869 }
2870
2871 void
2872 my_exit(U32 status)
2873 {
2874     dTHR;
2875
2876 #ifdef USE_THREADS
2877     DEBUG_L(PerlIO_printf(Perl_debug_log, "my_exit: thread 0x%lx, status %lu\n",
2878                          (unsigned long) thr, (unsigned long) status));
2879 #endif /* USE_THREADS */
2880     switch (status) {
2881     case 0:
2882         STATUS_ALL_SUCCESS;
2883         break;
2884     case 1:
2885         STATUS_ALL_FAILURE;
2886         break;
2887     default:
2888         STATUS_NATIVE_SET(status);
2889         break;
2890     }
2891     my_exit_jump();
2892 }
2893
2894 void
2895 my_failure_exit(void)
2896 {
2897 #ifdef VMS
2898     if (vaxc$errno & 1) {
2899         if (STATUS_NATIVE & 1)          /* fortuitiously includes "-1" */
2900             STATUS_NATIVE_SET(44);
2901     }
2902     else {
2903         if (!vaxc$errno && errno)       /* unlikely */
2904             STATUS_NATIVE_SET(44);
2905         else
2906             STATUS_NATIVE_SET(vaxc$errno);
2907     }
2908 #else
2909     if (errno & 255)
2910         STATUS_POSIX_SET(errno);
2911     else if (STATUS_POSIX == 0)
2912         STATUS_POSIX_SET(255);
2913 #endif
2914     my_exit_jump();
2915 }
2916
2917 static void
2918 my_exit_jump(void)
2919 {
2920     dTHR;
2921     register CONTEXT *cx;
2922     I32 gimme;
2923     SV **newsp;
2924
2925     if (e_tmpname) {
2926         if (e_fp) {
2927             PerlIO_close(e_fp);
2928             e_fp = Nullfp;
2929         }
2930         (void)UNLINK(e_tmpname);
2931         Safefree(e_tmpname);
2932         e_tmpname = Nullch;
2933     }
2934
2935     if (cxstack_ix >= 0) {
2936         if (cxstack_ix > 0)
2937             dounwind(0);
2938         POPBLOCK(cx,curpm);
2939         LEAVE;
2940     }
2941
2942     JMPENV_JUMP(2);
2943 }
2944