X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=perl.c;h=d769b44e39eded254dd79393bfa14d0c064e0515;hb=94d58c47cfbe97ca0a689bcd5b7f9132f7918fee;hp=2f6ba45f0b8cb55f01a848f805ca865071de2ac7;hpb=a0d0e21ea6ea90a22318550944fe6cb09ae10cda;p=p5sagit%2Fp5-mst-13.2.git diff --git a/perl.c b/perl.c index 2f6ba45..d769b44 100644 --- a/perl.c +++ b/perl.c @@ -1,6 +1,6 @@ /* perl.c * - * Copyright (c) 1987-1994 Larry Wall + * Copyright (c) 1987-1996 Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -21,7 +21,7 @@ #endif */ -char rcsid[] = "perl.c\nPatch level: ###\n"; +dEXT char rcsid[] = "perl.c\nPatch level: ###\n"; #ifdef IAMSUID #ifndef DOSUID @@ -37,6 +37,7 @@ char rcsid[] = "perl.c\nPatch level: ###\n"; static void find_beginning _((void)); static void incpush _((char *)); +static void init_ids _((void)); static void init_debugger _((void)); static void init_lexer _((void)); static void init_main_stash _((void)); @@ -45,6 +46,7 @@ static void init_postdump_symbols _((int, char **, char **)); static void init_predump_symbols _((void)); static void init_stacks _((void)); static void open_script _((char *, bool, SV *)); +static void usage _((char *)); static void validate_suid _((char *)); PerlInterpreter * @@ -61,8 +63,6 @@ void perl_construct( sv_interp ) register PerlInterpreter *sv_interp; { - char* s; - if (!(curinterp = sv_interp)) return; @@ -85,6 +85,9 @@ register PerlInterpreter *sv_interp; SvNV(&sv_yes); SvREADONLY_on(&sv_yes); + nrs = newSVpv("\n", 1); + rs = SvREFCNT_inc(nrs); + #ifdef MSDOS /* * There is no way we can refer to them from Perl so close them to save @@ -100,32 +103,29 @@ register PerlInterpreter *sv_interp; chopset = " \n-"; copline = NOLINE; curcop = &compiling; + dbargs = 0; dlmax = 128; laststatval = -1; laststype = OP_STAT; maxscream = -1; maxsysfd = MAXSYSFD; - nrs = "\n"; - nrschar = '\n'; - nrslen = 1; - rs = "\n"; - rschar = '\n'; rsfp = Nullfp; - rslen = 1; statname = Nullsv; tmps_floor = -1; #endif - uid = (int)getuid(); - euid = (int)geteuid(); - gid = (int)getgid(); - egid = (int)getegid(); -#ifdef VMS - uid |= gid << 16; - euid |= egid << 16; -#endif - tainting = (euid != uid || egid != gid); + init_ids(); + +#if defined(SUBVERSION) && SUBVERSION > 0 + sprintf(patchlevel, "%7.5f", 5.0 + (PATCHLEVEL / 1000.0) + + (SUBVERSION / 100000.0)); +#else sprintf(patchlevel, "%5.3f", 5.0 + (PATCHLEVEL / 1000.0)); +#endif + +#if defined(LOCAL_PATCH_COUNT) + Ilocalpatches = local_patches; /* For possible -v */ +#endif fdpid = newAV(); /* for remembering popen pids by fd */ pidstatus = newHV();/* for remembering status of dead pids */ @@ -135,15 +135,25 @@ register PerlInterpreter *sv_interp; } void -perl_destruct(sv_interp, destruct_level) +perl_destruct(sv_interp) register PerlInterpreter *sv_interp; -int destruct_level; /* 0=none, 1=full, 2=full with checks */ { + int destruct_level; /* 0=none, 1=full, 2=full with checks */ I32 last_sv_count; HV *hv; if (!(curinterp = sv_interp)) return; + + destruct_level = perl_destruct_level; +#ifdef DEBUGGING + { + char *s; + if (s = getenv("PERL_DESTRUCT_LEVEL")) + destruct_level = atoi(s); + } +#endif + LEAVE; FREETMPS; @@ -199,6 +209,7 @@ int destruct_level; /* 0=none, 1=full, 2=full with checks */ } if (sv_count != 0) warn("Scalars leaked: %d\n", sv_count); + sv_free_arenas(); DEBUG_P(debprofdump()); } @@ -211,7 +222,7 @@ PerlInterpreter *sv_interp; return; Safefree(sv_interp); } -#ifndef STANDARD_C +#if !defined(STANDARD_C) && !defined(HAS_GETENV_PROTOTYPE) char *getenv _((char *)); /* Usually in */ #endif @@ -225,9 +236,10 @@ char **env; { register SV *sv; register char *s; - char *scriptname; + char *scriptname = NULL; VOL bool dosearch = FALSE; char *validarg = ""; + AV* comppadlist; #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW #ifdef IAMSUID @@ -245,6 +257,7 @@ setuid perl scripts securely.\n"); #ifndef VMS /* VMS doesn't have environ array */ origenviron = environ; #endif + e_tmpname = Nullch; if (do_undump) { @@ -253,6 +266,7 @@ setuid perl scripts securely.\n"); origfilename = savepv(argv[0]); do_undump = FALSE; cxstack_ix = -1; /* start label stack again */ + init_ids(); init_postdump_symbols(argc,argv,env); return 0; } @@ -261,9 +275,13 @@ setuid perl scripts securely.\n"); op_free(main_root); main_root = 0; - switch (setjmp(top_env)) { + switch (Sigsetjmp(top_env,1)) { case 1: +#ifdef VMS statusvalue = 255; +#else + statusvalue = 1; +#endif case 2: curstash = defstash; if (endav) @@ -296,8 +314,11 @@ setuid perl scripts securely.\n"); case 'c': case 'd': case 'D': + case 'h': case 'i': case 'l': + case 'M': + case 'm': case 'n': case 'p': case 's': @@ -353,6 +374,22 @@ setuid perl scripts securely.\n"); dosearch = TRUE; s++; goto reswitch; + case 'V': + if (!preambleav) + preambleav = newAV(); + av_push(preambleav, newSVpv("use Config qw(myconfig config_vars)",0)); + if (*++s != ':') { + Sv = newSVpv("print myconfig(),'@INC: '.\"@INC\\n\"",0); + } + else { + Sv = newSVpv("config_vars(qw(",0); + sv_catpv(Sv, ++s); + sv_catpv(Sv, "))"); + s += strlen(s); + } + av_push(preambleav, Sv); + scriptname = BIT_BUCKET; /* don't look for script or read stdin */ + goto reswitch; case 'x': doextract = TRUE; s++; @@ -369,10 +406,12 @@ setuid perl scripts securely.\n"); } } switch_end: - scriptname = argv[0]; + if (!scriptname) + scriptname = argv[0]; if (e_fp) { - if (fflush(e_fp) || ferror(e_fp) || fclose(e_fp)) + if (Fflush(e_fp) || ferror(e_fp) || fclose(e_fp)) croak("Can't write to temp file for -e: %s", Strerror(errno)); + e_fp = Nullfp; argc++,argv--; scriptname = e_tmpname; } @@ -393,6 +432,9 @@ setuid perl scripts securely.\n"); if (doextract) find_beginning(); + compcv = (CV*)NEWSV(1104,0); + sv_upgrade((SV *)compcv, SVt_PVCV); + pad = newAV(); comppad = pad; av_push(comppad, Nullsv); @@ -403,8 +445,17 @@ setuid perl scripts securely.\n"); min_intro_pending = 0; padix = 0; + comppadlist = newAV(); + AvREAL_off(comppadlist); + av_store(comppadlist, 0, (SV*)comppad_name); + av_store(comppadlist, 1, (SV*)comppad); + CvPADLIST(compcv) = comppadlist; + if (xsinit) (*xsinit)(); /* in case linked C routines want magical variables */ +#ifdef VMS + init_os_extras(); +#endif init_predump_symbols(); if (!do_undump) @@ -426,18 +477,16 @@ setuid perl scripts securely.\n"); curcop->cop_line = 0; curstash = defstash; preprocess = FALSE; - if (e_fp) { - e_fp = Nullfp; + if (e_tmpname) { (void)UNLINK(e_tmpname); + Safefree(e_tmpname); + e_tmpname = Nullch; } /* now that script is parsed, we can modify record separator */ - - rs = nrs; - rslen = nrslen; - rschar = nrschar; - rspara = (nrslen == 2); - sv_setpvn(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), rs, rslen); + SvREFCNT_dec(rs); + rs = SvREFCNT_inc(nrs); + sv_setsv(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), rs); if (do_undump) my_unexec(); @@ -447,6 +496,12 @@ setuid perl scripts securely.\n"); LEAVE; FREETMPS; + +#ifdef DEBUGGING_MSTATS + if ((s=getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2) + dump_mstats("after compilation:"); +#endif + ENTER; restartop = 0; return 0; @@ -458,7 +513,7 @@ PerlInterpreter *sv_interp; { if (!(curinterp = sv_interp)) return 255; - switch (setjmp(top_env)) { + switch (Sigsetjmp(top_env,1)) { case 1: cxstack_ix = -1; /* start context stack again */ break; @@ -467,6 +522,10 @@ PerlInterpreter *sv_interp; if (endav) calllist(endav); FREETMPS; +#ifdef DEBUGGING_MSTATS + if (getenv("PERL_DEBUG_MSTATS")) + dump_mstats("after execution: "); +#endif return(statusvalue); /* my_exit() was called */ case 3: if (!restartop) { @@ -498,11 +557,11 @@ PerlInterpreter *sv_interp; if (restartop) { op = restartop; restartop = 0; - run(); + runops(); } else if (main_start) { op = main_start; - run(); + runops(); } my_exit(0); @@ -511,20 +570,20 @@ PerlInterpreter *sv_interp; void my_exit(status) -I32 status; +U32 status; { register CONTEXT *cx; I32 gimme; SV **newsp; - statusvalue = (unsigned short)(status & 0xffff); + statusvalue = FIXSTATUS(status); if (cxstack_ix >= 0) { if (cxstack_ix > 0) dounwind(0); POPBLOCK(cx,curpm); LEAVE; } - longjmp(top_env, 2); + Siglongjmp(top_env, 2); } SV* @@ -573,6 +632,7 @@ I32 create; if (create && !GvCV(gv)) return newSUB(start_subparse(), newSVOP(OP_CONST, 0, newSVpv(name,0)), + Nullop, Nullop); if (gv) return GvCV(gv); @@ -633,7 +693,7 @@ I32 flags; /* See G_* flags in cop.h */ SV** sp = stack_sp; I32 oldmark = TOPMARK; I32 retval; - jmp_buf oldtop; + Sigjmp_buf oldtop; I32 oldscope; if (flags & G_DISCARD) { @@ -656,25 +716,47 @@ I32 flags; /* See G_* flags in cop.h */ myop.op_flags |= OPf_LIST; if (flags & G_EVAL) { - Copy(top_env, oldtop, 1, jmp_buf); + Copy(top_env, oldtop, 1, Sigjmp_buf); cLOGOP->op_other = op; markstack_ptr--; - pp_entertry(); + /* we're trying to emulate pp_entertry() here */ + { + register CONTEXT *cx; + I32 gimme = GIMME; + + ENTER; + SAVETMPS; + + push_return(op->op_next); + PUSHBLOCK(cx, CXt_EVAL, stack_sp); + PUSHEVAL(cx, 0, 0); + eval_root = op; /* Only needed so that goto works right. */ + + in_eval = 1; + if (flags & G_KEEPERR) + in_eval |= 4; + else + sv_setpv(GvSV(errgv),""); + } markstack_ptr++; restart: - switch (setjmp(top_env)) { + switch (Sigsetjmp(top_env,1)) { case 0: break; case 1: +#ifdef VMS statusvalue = 255; /* XXX I don't think we use 1 anymore. */ +#else + statusvalue = 1; +#endif /* FALL THROUGH */ case 2: /* my_exit() was called */ curstash = defstash; FREETMPS; - Copy(oldtop, top_env, 1, jmp_buf); + Copy(oldtop, top_env, 1, Sigjmp_buf); if (statusvalue) croak("Callback called exit"); my_exit(statusvalue); @@ -699,18 +781,27 @@ I32 flags; /* See G_* flags in cop.h */ if (op == (OP*)&myop) op = pp_entersub(); if (op) - run(); + runops(); retval = stack_sp - (stack_base + oldmark); - if (flags & G_EVAL) - sv_setpv(GvSV(gv_fetchpv("@",TRUE, SVt_PV)),""); + if ((flags & G_EVAL) && !(flags & G_KEEPERR)) + sv_setpv(GvSV(errgv),""); cleanup: if (flags & G_EVAL) { if (scopestack_ix > oldscope) { - op = (OP*)&myop; - pp_leavetry(); + SV **newsp; + PMOP *newpm; + I32 gimme; + register CONTEXT *cx; + I32 optype; + + POPBLOCK(cx,newpm); + POPEVAL(cx); + pop_return(); + curpm = newpm; + LEAVE; } - Copy(oldtop, top_env, 1, jmp_buf); + Copy(oldtop, top_env, 1, Sigjmp_buf); } if (flags & G_DISCARD) { stack_sp = stack_base + oldmark; @@ -721,78 +812,107 @@ I32 flags; /* See G_* flags in cop.h */ return retval; } -/* Older forms, here grandfathered. */ +/* Eval a string. */ -#ifdef DEPRECATED I32 -perl_callargv(subname, spix, gimme, argv) -char *subname; -register I32 spix; /* current stack pointer index */ -I32 gimme; /* See G_* flags in cop.h */ -register char **argv; /* null terminated arg list, NULL for no arglist */ -{ - stack_sp = stack_base + spix; - return spix + perl_call_argv(subname, gimme, argv); -} - -I32 -perl_callpv(subname, spix, gimme, hasargs, numargs) -char *subname; -I32 spix; /* stack pointer index after args are pushed */ -I32 gimme; /* See G_* flags in cop.h */ -I32 hasargs; /* whether to create a @_ array for routine */ -I32 numargs; /* how many args are pushed on the stack */ -{ - stack_sp = stack_base + spix; - PUSHMARK(stack_sp - numargs); - return spix - numargs + perl_call_sv((SV*)perl_get_cv(subname, TRUE), - gimme, hasargs, numargs); -} - -I32 -perl_callsv(sv, spix, gimme, hasargs, numargs) +perl_eval_sv(sv, flags) SV* sv; -I32 spix; /* stack pointer index after args are pushed */ -I32 gimme; /* See G_* flags in cop.h */ -I32 hasargs; /* whether to create a @_ array for routine */ -I32 numargs; /* how many args are pushed on the stack */ -{ - stack_sp = stack_base + spix; - PUSHMARK(stack_sp - numargs); - return spix - numargs + perl_call_sv(sv, gimme, hasargs, numargs); -} -#endif - -/* Require a module. */ - -void -perl_requirepv(pv) -char* pv; +I32 flags; /* See G_* flags in cop.h */ { UNOP myop; /* fake syntax tree node */ - SV* sv; - dSP; + SV** sp = stack_sp; + I32 oldmark = sp - stack_base; + I32 retval; + Sigjmp_buf oldtop; + I32 oldscope; - ENTER; - SAVETMPS; + if (flags & G_DISCARD) { + ENTER; + SAVETMPS; + } + SAVESPTR(op); - sv = sv_newmortal(); - sv_setpv(sv, pv); op = (OP*)&myop; Zero(op, 1, UNOP); - XPUSHs(sv); + EXTEND(stack_sp, 1); + *++stack_sp = sv; + oldscope = scopestack_ix; - myop.op_type = OP_REQUIRE; + if (!(flags & G_NOARGS)) + myop.op_flags = OPf_STACKED; myop.op_next = Nullop; - myop.op_private = 1; - myop.op_flags = OPf_KNOW; + myop.op_flags |= OPf_KNOW; + if (flags & G_ARRAY) + myop.op_flags |= OPf_LIST; - PUTBACK; - if (op = pp_require()) - run(); - stack_sp--; - FREETMPS; - LEAVE; + Copy(top_env, oldtop, 1, Sigjmp_buf); + +restart: + switch (Sigsetjmp(top_env,1)) { + case 0: + break; + case 1: +#ifdef VMS + statusvalue = 255; /* XXX I don't think we use 1 anymore. */ +#else + statusvalue = 1; +#endif + /* FALL THROUGH */ + case 2: + /* my_exit() was called */ + curstash = defstash; + FREETMPS; + Copy(oldtop, top_env, 1, Sigjmp_buf); + if (statusvalue) + croak("Callback called exit"); + my_exit(statusvalue); + /* NOTREACHED */ + case 3: + if (restartop) { + op = restartop; + restartop = 0; + goto restart; + } + stack_sp = stack_base + oldmark; + if (flags & G_ARRAY) + retval = 0; + else { + retval = 1; + *++stack_sp = &sv_undef; + } + goto cleanup; + } + + if (op == (OP*)&myop) + op = pp_entereval(); + if (op) + runops(); + retval = stack_sp - (stack_base + oldmark); + if ((flags & G_EVAL) && !(flags & G_KEEPERR)) + sv_setpv(GvSV(errgv),""); + + cleanup: + Copy(oldtop, top_env, 1, Sigjmp_buf); + if (flags & G_DISCARD) { + stack_sp = stack_base + oldmark; + retval = 0; + FREETMPS; + LEAVE; + } + return retval; +} + +/* Require a module. */ + +void +perl_require_pv(pv) +char* pv; +{ + SV* sv = sv_newmortal(); + sv_setpv(sv, "require '"); + sv_catpv(sv, pv); + sv_catpv(sv, "'"); + perl_eval_sv(sv, G_DISCARD); } void @@ -807,10 +927,14 @@ I32 namlen; sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen); } -#ifdef DOSISH -#define PERLLIB_SEP ';' +#if defined(DOSISH) +# define PERLLIB_SEP ';' #else -#define PERLLIB_SEP ':' +# if defined(VMS) +# define PERLLIB_SEP '|' +# else +# define PERLLIB_SEP ':' +# endif #endif static void @@ -840,6 +964,41 @@ char *p; } } +static void +usage(name) /* XXX move this out into a module ? */ +char *name; +{ + /* This message really ought to be max 23 lines. + * Removed -h because the user already knows that opton. Others? */ + printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name); + printf("\n -0[octal] specify record separator (\\0, if no argument)"); + printf("\n -a autosplit mode with -n or -p (splits $_ into @F)"); + printf("\n -c check syntax only (runs BEGIN and END blocks)"); + printf("\n -d[:debugger] run scripts under debugger"); + printf("\n -D[number/list] set debugging flags (argument is a bit mask or flags)"); + printf("\n -e 'command' one line of script. Several -e's allowed. Omit [programfile]."); + printf("\n -F/pattern/ split() pattern for autosplit (-a). The //'s are optional."); + printf("\n -i[extension] edit <> files in place (make backup if extension supplied)"); + printf("\n -Idirectory specify @INC/#include directory (may be used more then once)"); + printf("\n -l[octal] enable line ending processing, specifies line teminator"); + printf("\n -[mM][-]module.. executes `use/no module...' before executing your script."); + printf("\n -n assume 'while (<>) { ... }' loop arround your script"); + printf("\n -p assume loop like -n but print line also like sed"); + printf("\n -P run script through C preprocessor before compilation"); +#ifdef OS2 + printf("\n -R enable REXX variable pool"); +#endif + printf("\n -s enable some switch parsing for switches after script name"); + printf("\n -S look for the script using PATH environment variable"); + printf("\n -T turn on tainting checks"); + printf("\n -u dump core after parsing script"); + printf("\n -U allow unsafe operations"); + printf("\n -v print version number and patchlevel of perl"); + printf("\n -V[:variable] print perl configuration information"); + printf("\n -w TURN WARNINGS ON FOR COMPILATION OF YOUR SCRIPT."); + printf("\n -x[directory] strip off text before #!perl line and perhaps cd to directory\n"); +} + /* This routine handles any switches that can be given during run */ char * @@ -847,20 +1006,19 @@ moreswitches(s) char *s; { I32 numlen; + U32 rschar; switch (*s) { case '0': - nrschar = scan_oct(s, 4, &numlen); - nrs = savepvn("\n",1); - *nrs = nrschar; - if (nrschar > 0377) { - nrslen = 0; - nrs = ""; - } - else if (!nrschar && numlen >= 2) { - nrslen = 2; - nrs = "\n\n"; - nrschar = '\n'; + rschar = scan_oct(s, 4, &numlen); + SvREFCNT_dec(nrs); + if (rschar & ~((U8)~0)) + nrs = &sv_undef; + else if (!rschar && numlen >= 2) + nrs = newSVpv("", 0); + else { + char ch = rschar; + nrs = newSVpv(&ch, 1); } return s + numlen; case 'F': @@ -878,11 +1036,16 @@ char *s; return s; case 'd': taint_not("-d"); + s++; + if (*s == ':' || *s == '=') { + sprintf(buf, "use Devel::%s;", ++s); + s += strlen(s); + my_setenv("PERL5DB",buf); + } if (!perldb) { perldb = TRUE; init_debugger(); } - s++; return s; case 'D': #ifdef DEBUGGING @@ -905,6 +1068,9 @@ char *s; #endif /*SUPPRESS 530*/ return s; + case 'h': + usage(origargv[0]); + exit(0); case 'i': if (inplace) Safefree(inplace); @@ -916,7 +1082,11 @@ char *s; case 'I': taint_not("-I"); if (*++s) { - av_push(GvAVn(incgv),newSVpv(s,0)); + char *e; + for (e = s; *e && !isSPACE(*e); e++) ; + av_push(GvAVn(incgv),newSVpv(s,e-s)); + if (*e) + return e; } else croak("No space allowed after -I"); @@ -933,9 +1103,48 @@ char *s; s += numlen; } else { - ors = savepvn(nrs,nrslen); - orslen = nrslen; + if (RsPARA(nrs)) { + ors = savepvn("\n\n", 2); + orslen = 2; + } + else + ors = SvPV(nrs, orslen); + } + return s; + case 'M': + taint_not("-M"); /* XXX ? */ + /* FALL THROUGH */ + case 'm': + taint_not("-m"); /* XXX ? */ + if (*++s) { + char *start; + char *use = "use "; + /* -M-foo == 'no foo' */ + if (*s == '-') { use = "no "; ++s; } + Sv = newSVpv(use,0); + start = s; + /* We allow -M'Module qw(Foo Bar)' */ + while(isALNUM(*s) || *s==':') ++s; + if (*s != '=') { + sv_catpv(Sv, start); + if (*(start-1) == 'm') { + if (*s != '\0') + croak("Can't use '%c' after -mname", *s); + sv_catpv( Sv, " ()"); + } + } else { + sv_catpvn(Sv, start, s-start); + sv_catpv(Sv, " split(/,/,q{"); + sv_catpv(Sv, ++s); + sv_catpv(Sv, "})"); + } + s += strlen(s); + if (preambleav == NULL) + preambleav = newAV(); + av_push(preambleav, Sv); } + else + croak("No space allowed after -%c", *(s-1)); return s; case 'n': minus_n = TRUE; @@ -963,22 +1172,58 @@ char *s; s++; return s; case 'v': - printf("\nThis is perl, version %s\n\n",patchlevel); - fputs("\nCopyright 1987-1994, Larry Wall\n",stdout); +#if defined(SUBVERSION) && SUBVERSION > 0 + printf("\nThis is perl, version 5.%03d_%02d", PATCHLEVEL, SUBVERSION); +#else + printf("\nThis is perl, version %s",patchlevel); +#endif + +#if defined(DEBUGGING) || defined(EMBED) || defined(MULTIPLICITY) + fputs(" with", stdout); +#ifdef DEBUGGING + fputs(" DEBUGGING", stdout); +#endif +#ifdef EMBED + fputs(" EMBED", stdout); +#endif +#ifdef MULTIPLICITY + fputs(" MULTIPLICITY", stdout); +#endif +#endif + +#if defined(LOCAL_PATCH_COUNT) + if (LOCAL_PATCH_COUNT > 0) + { int i; + fputs("\n\tLocally applied patches:\n", stdout); + for (i = 1; i <= LOCAL_PATCH_COUNT; i++) { + if (Ilocalpatches[i]) + fprintf(stdout, "\t %s\n", Ilocalpatches[i]); + } + } +#endif + printf("\n\tbuilt under %s",OSNAME); +#ifdef __DATE__ +# ifdef __TIME__ + printf(" at %s %s",__DATE__,__TIME__); +# else + printf(" on %s",__DATE__); +# endif +#endif + fputs("\n\nCopyright 1987-1996, Larry Wall\n",stdout); #ifdef MSDOS fputs("MS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n", stdout); -#ifdef OS2 - fputs("OS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n", - stdout); #endif +#ifdef OS2 + fputs("OS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n" + "Version 5 port Copyright (c) 1994-1995, Andreas Kaiser\n", stdout); #endif #ifdef atarist - fputs("atariST series port, ++jrb bammi@cadence.com\n", stdout); + fputs("atariST series port, ++jrb bammi@cadence.com\n", stdout); #endif fputs("\n\ Perl may be copied only under the terms of either the Artistic License or the\n\ -GNU General Public License, which may be found in the Perl 5.0 source kit.\n",stdout); +GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n",stdout); #ifdef MSDOS usage(origargv[0]); #endif @@ -1026,8 +1271,13 @@ my_unexec() fprintf(stderr, "unexec of %s into %s failed!\n", tokenbuf, buf); exit(status); #else +# ifdef VMS +# include + lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */ +#else ABORT(); /* for use with undump */ #endif +#endif } static void @@ -1036,17 +1286,21 @@ init_main_stash() GV *gv; curstash = defstash = newHV(); curstname = newSVpv("main",4); - GvHV(gv = gv_fetchpv("main::",TRUE, SVt_PVHV)) = - (HV*)SvREFCNT_inc(defstash); + gv = gv_fetchpv("main::",TRUE, SVt_PVHV); + SvREFCNT_dec(GvHV(gv)); + GvHV(gv) = (HV*)SvREFCNT_inc(defstash); SvREADONLY_on(gv); HvNAME(defstash) = savepv("main"); incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV))); - SvMULTI_on(incgv); + GvMULTI_on(incgv); defgv = gv_fetchpv("_",TRUE, SVt_PVAV); + errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV)); + GvMULTI_on(errgv); curstash = defstash; compiling.cop_stash = defstash; - debstash = newHV(); - GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV)) = debstash; + debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV)); + /* We must init $/ before switches are processed. */ + sv_setpvn(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), "\n", 1); } #ifdef CAN_PROTOTYPE @@ -1064,7 +1318,26 @@ SV *sv; char *xfailed = Nullch; register char *s; I32 len; + int retval; +#if defined(DOSISH) && !defined(OS2) && !defined(atarist) +#define SEARCH_EXTS ".bat", ".cmd", NULL +#endif +#ifdef VMS +# define SEARCH_EXTS ".pl", ".com", NULL +#endif + /* additional extensions to try in each dir if scriptname not found */ +#ifdef SEARCH_EXTS + char *ext[] = { SEARCH_EXTS }; + int extidx = (strchr(scriptname,'.')) ? -1 : 0; /* has ext already */ +#endif +#ifdef VMS + if (dosearch && !strpbrk(scriptname,":[ 0) /* reset after previous loop */ + extidx = 0; + do { +#endif + DEBUG_p(fprintf(stderr,"Looking for %s\n",tokenbuf)); + retval = Stat(tokenbuf,&statbuf); +#ifdef SEARCH_EXTS + } while ( retval < 0 /* not there */ + && extidx>=0 && ext[extidx] /* try an extension? */ + && strcpy(tokenbuf+len, ext[extidx++]) + ); +#endif + if (retval < 0) continue; if (S_ISREG(statbuf.st_mode) && cando(S_IRUSR,TRUE,&statbuf) && cando(S_IXUSR,TRUE,&statbuf)) { @@ -1111,7 +1399,7 @@ SV *sv; scriptname = xfound; } - origfilename = savepv(e_fp ? "-e" : scriptname); + origfilename = savepv(e_tmpname ? "-e" : scriptname); curcop->cop_filegv = gv_fetchfile(origfilename); if (strEQ(origfilename,"-")) scriptname = ""; @@ -1123,7 +1411,7 @@ SV *sv; else sprintf(tokenbuf, "%s", cpp); sv_catpv(sv,"-I"); - sv_catpv(sv,PRIVLIB); + sv_catpv(sv,PRIVLIB_EXP); #ifdef MSDOS (void)sprintf(buf, "\ sed %s -e \"/^[^#]/b\" \ @@ -1395,11 +1683,7 @@ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n"); if (geteuid() != uid) croak("Can't do seteuid!\n"); } - uid = (int)getuid(); - euid = (int)geteuid(); - gid = (int)getgid(); - egid = (int)getegid(); - tainting |= (euid != uid || egid != gid); + init_ids(); if (!cando(S_IXUSR,TRUE,&statbuf)) croak("Permission denied\n"); /* they can't do this */ } @@ -1452,19 +1736,34 @@ find_beginning() } static void -init_debugger() +init_ids() { - GV* tmpgv; + uid = (int)getuid(); + euid = (int)geteuid(); + gid = (int)getgid(); + egid = (int)getegid(); +#ifdef VMS + uid |= gid << 16; + euid |= egid << 16; +#endif + tainting |= (uid && (euid != uid || egid != gid)); +} +static void +init_debugger() +{ curstash = debstash; - dbargs = GvAV(gv_AVadd((tmpgv = gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV)))); + dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV)))); AvREAL_off(dbargs); DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV); DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV); - DBsub = gv_HVadd(tmpgv = gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV)); - DBsingle = GvSV((tmpgv = gv_fetchpv("single", GV_ADDMULTI, SVt_PV))); - DBtrace = GvSV((tmpgv = gv_fetchpv("trace", GV_ADDMULTI, SVt_PV))); - DBsignal = GvSV((tmpgv = gv_fetchpv("signal", GV_ADDMULTI, SVt_PV))); + DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV)); + DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV))); + sv_setiv(DBsingle, 0); + DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV))); + sv_setiv(DBtrace, 0); + DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV))); + sv_setiv(DBsignal, 0); curstash = defstash; } @@ -1496,9 +1795,9 @@ init_stacks() retstack_ix = 0; retstack_max = 16; - New(50,cxstack,128,CONTEXT); + cxstack_max = 8192 / sizeof(CONTEXT) - 2; /* Use most of 8K. */ + New(50,cxstack,cxstack_max + 1,CONTEXT); cxstack_ix = -1; - cxstack_max = 128; New(50,tmps_stack,128,SV*); tmps_ix = -1; @@ -1530,28 +1829,30 @@ init_predump_symbols() sv_setpvn(GvSV(gv_fetchpv("\"", TRUE, SVt_PV)), " ", 1); stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO); - SvMULTI_on(stdingv); + GvMULTI_on(stdingv); IoIFP(GvIOp(stdingv)) = stdin; - tmpgv = gv_fetchpv("stdin",TRUE, SVt_PVIO); + tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV); + GvMULTI_on(tmpgv); GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(stdingv)); - SvMULTI_on(tmpgv); tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO); - SvMULTI_on(tmpgv); + GvMULTI_on(tmpgv); IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = stdout; - defoutgv = tmpgv; - tmpgv = gv_fetchpv("stdout",TRUE, SVt_PVIO); + setdefout(tmpgv); + tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV); + GvMULTI_on(tmpgv); GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(defoutgv)); - SvMULTI_on(tmpgv); othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO); - SvMULTI_on(othergv); + GvMULTI_on(othergv); IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = stderr; - tmpgv = gv_fetchpv("stderr",TRUE, SVt_PVIO); + tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV); + GvMULTI_on(tmpgv); GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv)); - SvMULTI_on(tmpgv); statname = NEWSV(66,0); /* last filename we did stat on */ + + osname = savepv(OSNAME); } static void @@ -1584,8 +1885,7 @@ register char **env; toptarget = NEWSV(0,0); sv_upgrade(toptarget, SVt_PVFM); sv_setpvn(toptarget, "", 0); - tmpgv = gv_fetchpv("\001",TRUE, SVt_PV); - bodytarget = GvSV(tmpgv); + bodytarget = NEWSV(0,0); sv_upgrade(bodytarget, SVt_PVFM); sv_setpvn(bodytarget, "", 0); formtarget = bodytarget; @@ -1600,7 +1900,7 @@ register char **env; if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV)) sv_setpv(GvSV(tmpgv),origargv[0]); if (argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) { - SvMULTI_on(argvgv); + GvMULTI_on(argvgv); (void)gv_AVadd(argvgv); av_clear(GvAVn(argvgv)); for (; argc > 0; argc--,argv++) { @@ -1609,18 +1909,21 @@ register char **env; } if (envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) { HV *hv; - SvMULTI_on(envgv); + GvMULTI_on(envgv); hv = GvHVn(envgv); hv_clear(hv); #ifndef VMS /* VMS doesn't have environ array */ + /* Note that if the supplied env parameter is actually a copy + of the global environ then it may now point to free'd memory + if the environment has been modified since. To avoid this + problem we treat env==NULL as meaning 'use the default' + */ + if (!env) + env = environ; if (env != environ) { environ[0] = Nullch; hv_magic(hv, envgv, 'E'); } -#endif -#ifdef DYNAMIC_ENV_FETCH - HvNAME(hv) = savepv(ENV_HV_NAME); -#endif for (; *env; env++) { if (!(s = strchr(*env,'='))) continue; @@ -1630,6 +1933,10 @@ register char **env; (void)hv_store(hv, *env, s - *env, sv, 0); *s = '='; } +#endif +#ifdef DYNAMIC_ENV_FETCH + HvNAME(hv) = savepv(ENV_HV_NAME); +#endif hv_magic(hv, envgv, 'E'); } tainted = 0; @@ -1650,50 +1957,71 @@ init_perllib() incpush(getenv("PERLLIB")); } -#ifdef ARCHLIB - incpush(ARCHLIB); +#ifdef APPLLIB_EXP + incpush(APPLLIB_EXP); #endif -#ifndef PRIVLIB -#define PRIVLIB "/usr/local/lib/perl5:/usr/local/lib/perl" + +#ifdef ARCHLIB_EXP + incpush(ARCHLIB_EXP); +#endif +#ifndef PRIVLIB_EXP +#define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl" +#endif + incpush(PRIVLIB_EXP); + +#ifdef SITEARCH_EXP + incpush(SITEARCH_EXP); +#endif +#ifdef SITELIB_EXP + incpush(SITELIB_EXP); +#endif +#ifdef OLDARCHLIB_EXP /* 5.00[01] compatibility */ + incpush(OLDARCHLIB_EXP); #endif - incpush(PRIVLIB); - av_push(GvAVn(incgv),newSVpv(".",1)); + if (!tainting) + incpush("."); } void calllist(list) AV* list; { - jmp_buf oldtop; - char *mess; + Sigjmp_buf oldtop; STRLEN len; line_t oldline = curcop->cop_line; - Copy(top_env, oldtop, 1, jmp_buf); + Copy(top_env, oldtop, 1, Sigjmp_buf); while (AvFILL(list) >= 0) { CV *cv = (CV*)av_shift(list); SAVEFREESV(cv); - switch (setjmp(top_env)) { - case 0: - PUSHMARK(stack_sp); - perl_call_sv((SV*)cv, G_EVAL|G_DISCARD); - mess = SvPVx(GvSV(gv_fetchpv("@",TRUE, SVt_PV)), len); - if (len) { - Copy(oldtop, top_env, 1, jmp_buf); - curcop = &compiling; - curcop->cop_line = oldline; - if (list == beginav) - croak("%sBEGIN failed--compilation aborted", mess); - else - croak("%sEND failed--cleanup aborted", mess); + switch (Sigsetjmp(top_env,1)) { + case 0: { + SV* atsv = GvSV(errgv); + PUSHMARK(stack_sp); + perl_call_sv((SV*)cv, G_EVAL|G_DISCARD); + (void)SvPV(atsv, len); + if (len) { + Copy(oldtop, top_env, 1, Sigjmp_buf); + curcop = &compiling; + curcop->cop_line = oldline; + if (list == beginav) + sv_catpv(atsv, "BEGIN failed--compilation aborted"); + else + sv_catpv(atsv, "END failed--cleanup aborted"); + croak("%s", SvPVX(atsv)); + } } break; case 1: +#ifdef VMS statusvalue = 255; /* XXX I don't think we use 1 anymore. */ +#else + statusvalue = 1; +#endif /* FALL THROUGH */ case 2: /* my_exit() was called */ @@ -1701,7 +2029,7 @@ AV* list; if (endav) calllist(endav); FREETMPS; - Copy(oldtop, top_env, 1, jmp_buf); + Copy(oldtop, top_env, 1, Sigjmp_buf); curcop = &compiling; curcop->cop_line = oldline; if (statusvalue) { @@ -1719,13 +2047,13 @@ AV* list; FREETMPS; break; } - Copy(oldtop, top_env, 1, jmp_buf); + Copy(oldtop, top_env, 1, Sigjmp_buf); curcop = &compiling; curcop->cop_line = oldline; - longjmp(top_env, 3); + Siglongjmp(top_env, 3); } } - Copy(oldtop, top_env, 1, jmp_buf); + Copy(oldtop, top_env, 1, Sigjmp_buf); }