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