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