X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=perl.c;h=1abb48dbcfc70e181e471825ea6f45426102a929;hb=3f6d40bd7fe955329c1f574485922604c74d8097;hp=246412a2308d1deb48e3e04e6d66833e6f527dfe;hpb=829372d3895763a8b826b343859a01ae699a641e;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/perl.c b/perl.c
index 246412a..1abb48d 100644
--- a/perl.c
+++ b/perl.c
@@ -194,6 +194,9 @@ void
 Perl_sys_init(int* argc, char*** argv)
 {
     dVAR;
+
+    PERL_ARGS_ASSERT_SYS_INIT;
+
     PERL_UNUSED_ARG(argc); /* may not be used depending on _BODY macro */
     PERL_UNUSED_ARG(argv);
     PERL_SYS_INIT_BODY(argc, argv);
@@ -203,6 +206,9 @@ void
 Perl_sys_init3(int* argc, char*** argv, char*** env)
 {
     dVAR;
+
+    PERL_ARGS_ASSERT_SYS_INIT3;
+
     PERL_UNUSED_ARG(argc); /* may not be used depending on _BODY macro */
     PERL_UNUSED_ARG(argv);
     PERL_UNUSED_ARG(env);
@@ -228,6 +234,9 @@ perl_alloc_using(struct IPerlMem* ipM, struct IPerlMem* ipMS,
 		 struct IPerlProc* ipP)
 {
     PerlInterpreter *my_perl;
+
+    PERL_ARGS_ASSERT_PERL_ALLOC_USING;
+
     /* Newx() needs interpreter, so call malloc() instead */
     my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
     S_init_tls_and_interp(my_perl);
@@ -288,11 +297,14 @@ void
 perl_construct(pTHXx)
 {
     dVAR;
-    PERL_UNUSED_ARG(my_perl);
+
+    PERL_ARGS_ASSERT_PERL_CONSTRUCT;
+
 #ifdef MULTIPLICITY
     init_interp();
     PL_perl_destruct_level = 1;
 #else
+    PERL_UNUSED_ARG(my_perl);
    if (PL_perl_destruct_level > 0)
        init_interp();
 #endif
@@ -478,6 +490,8 @@ Perl_dump_sv_child(pTHX_ SV *sv)
     int returned_errno;
     unsigned char buffer[256];
 
+    PERL_ARGS_ASSERT_DUMP_SV_CHILD;
+
     if(sock == -1 || debug_fd == -1)
 	return;
 
@@ -580,7 +594,10 @@ perl_destruct(pTHXx)
     pid_t child;
 #endif
 
+    PERL_ARGS_ASSERT_PERL_DESTRUCT;
+#ifndef MULTIPLICITY
     PERL_UNUSED_ARG(my_perl);
+#endif
 
     /* wait for all pseudo-forked children to finish */
     PERL_WAIT_FOR_CHILDREN;
@@ -1346,6 +1363,8 @@ perl_free(pTHXx)
 {
     dVAR;
 
+    PERL_ARGS_ASSERT_PERL_FREE;
+
     if (PL_veto_cleanup)
 	return;
 
@@ -1357,10 +1376,17 @@ perl_free(pTHXx)
 	 */
 	const char * const s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL");
 	if (!s || atoi(s) == 0) {
+	    const U32 old_debug = PL_debug;
 	    /* Emulate the PerlHost behaviour of free()ing all memory allocated in this
 	       thread at thread exit.  */
+	    if (DEBUG_m_TEST) {
+		PerlIO_puts(Perl_debug_log, "Disabling memory debugging as we "
+			    "free this thread's memory\n");
+		PL_debug &= ~ DEBUG_m_FLAG;
+	    }
 	    while(aTHXx->Imemory_debug_header.next != &(aTHXx->Imemory_debug_header))
 		safesysfree(sTHX + (char *)(aTHXx->Imemory_debug_header.next));
+	    PL_debug = old_debug;
 	}
     }
 #endif
@@ -1490,7 +1516,10 @@ perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env)
     int ret;
     dJMPENV;
 
+    PERL_ARGS_ASSERT_PERL_PARSE;
+#ifndef MULTIPLICITY
     PERL_UNUSED_ARG(my_perl);
+#endif
 
 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW_AND_IAMSUID
     Perl_croak(aTHX_ "suidperl is no longer needed since the kernel can now "
@@ -2271,7 +2300,10 @@ perl_run(pTHXx)
     int ret = 0;
     dJMPENV;
 
+    PERL_ARGS_ASSERT_PERL_RUN;
+#ifndef MULTIPLICITY
     PERL_UNUSED_ARG(my_perl);
+#endif
 
     oldscope = PL_scopestack_ix;
 #ifdef VMS
@@ -2335,8 +2367,6 @@ S_run_body(pTHX_ I32 oldscope)
 	if (!DEBUG_q_TEST)
 	  PERL_DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
 #endif
-	DEBUG_S(PerlIO_printf(Perl_debug_log, "main thread is 0x%"UVxf"\n",
-			      PTR2UV(thr)));
 
 	if (PL_minus_c) {
 #ifdef MACOS_TRADITIONAL
@@ -2389,6 +2419,9 @@ SV*
 Perl_get_sv(pTHX_ const char *name, I32 create)
 {
     GV *gv;
+
+    PERL_ARGS_ASSERT_GET_SV;
+
     gv = gv_fetchpv(name, create, SVt_PV);
     if (gv)
 	return GvSV(gv);
@@ -2411,6 +2444,9 @@ AV*
 Perl_get_av(pTHX_ const char *name, I32 create)
 {
     GV* const gv = gv_fetchpv(name, create, SVt_PVAV);
+
+    PERL_ARGS_ASSERT_GET_AV;
+
     if (create)
     	return GvAVn(gv);
     if (gv)
@@ -2434,6 +2470,9 @@ HV*
 Perl_get_hv(pTHX_ const char *name, I32 create)
 {
     GV* const gv = gv_fetchpv(name, create, SVt_PVHV);
+
+    PERL_ARGS_ASSERT_GET_HV;
+
     if (create)
     	return GvHVn(gv);
     if (gv)
@@ -2466,6 +2505,9 @@ Perl_get_cvn_flags(pTHX_ const char *name, STRLEN len, I32 flags)
     /* XXX this is probably not what they think they're getting.
      * It has the same effect as "sub name;", i.e. just a forward
      * declaration! */
+
+    PERL_ARGS_ASSERT_GET_CVN_FLAGS;
+
     if ((flags & ~GV_NOADD_MASK) && !GvCVu(gv)) {
 	SV *const sv = newSVpvn_flags(name, len, flags & SVf_UTF8);
     	return newSUB(start_subparse(FALSE, 0),
@@ -2480,6 +2522,8 @@ Perl_get_cvn_flags(pTHX_ const char *name, STRLEN len, I32 flags)
 CV*
 Perl_get_cv(pTHX_ const char *name, I32 flags)
 {
+    PERL_ARGS_ASSERT_GET_CV;
+
     return get_cvn_flags(name, strlen(name), flags);
 }
 
@@ -2505,6 +2549,8 @@ Perl_call_argv(pTHX_ const char *sub_name, I32 flags, register char **argv)
     dVAR;
     dSP;
 
+    PERL_ARGS_ASSERT_CALL_ARGV;
+
     PUSHMARK(SP);
     if (argv) {
 	while (*argv) {
@@ -2529,6 +2575,8 @@ Perl_call_pv(pTHX_ const char *sub_name, I32 flags)
               		/* name of the subroutine */
           		/* See G_* flags in cop.h */
 {
+    PERL_ARGS_ASSERT_CALL_PV;
+
     return call_sv((SV*)get_cv(sub_name, TRUE), flags);
 }
 
@@ -2546,6 +2594,8 @@ Perl_call_method(pTHX_ const char *methname, I32 flags)
                		/* name of the subroutine */
           		/* See G_* flags in cop.h */
 {
+    PERL_ARGS_ASSERT_CALL_METHOD;
+
     return call_sv(sv_2mortal(newSVpv(methname,0)), flags | G_METHOD);
 }
 
@@ -2560,7 +2610,7 @@ L<perlcall>.
 */
 
 I32
-Perl_call_sv(pTHX_ SV *sv, I32 flags)
+Perl_call_sv(pTHX_ SV *sv, VOL I32 flags)
           		/* See G_* flags in cop.h */
 {
     dVAR; dSP;
@@ -2574,18 +2624,23 @@ Perl_call_sv(pTHX_ SV *sv, I32 flags)
     OP* const oldop = PL_op;
     dJMPENV;
 
+    PERL_ARGS_ASSERT_CALL_SV;
+
     if (flags & G_DISCARD) {
 	ENTER;
 	SAVETMPS;
     }
+    if (!(flags & G_WANT)) {
+	/* Backwards compatibility - as G_SCALAR was 0, it could be omitted.
+	 */
+	flags |= G_SCALAR;
+    }
 
     Zero(&myop, 1, LOGOP);
     myop.op_next = NULL;
     if (!(flags & G_NOARGS))
 	myop.op_flags |= OPf_STACKED;
-    myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
-		      (flags & G_ARRAY) ? OPf_WANT_LIST :
-		      OPf_WANT_SCALAR);
+    myop.op_flags |= OP_GIMME_REVERSE(flags);
     SAVEOP();
     PL_op = (OP*)&myop;
 
@@ -2607,7 +2662,9 @@ Perl_call_sv(pTHX_ SV *sv, I32 flags)
 	Zero(&method_op, 1, UNOP);
 	method_op.op_next = PL_op;
 	method_op.op_ppaddr = PL_ppaddr[OP_METHOD];
+	method_op.op_type = OP_METHOD;
 	myop.op_ppaddr = PL_ppaddr[OP_ENTERSUB];
+	myop.op_type = OP_ENTERSUB;
 	PL_op = (OP*)&method_op;
     }
 
@@ -2652,7 +2709,7 @@ Perl_call_sv(pTHX_ SV *sv, I32 flags)
 		goto redo_body;
 	    }
 	    PL_stack_sp = PL_stack_base + oldmark;
-	    if (flags & G_ARRAY)
+	    if ((flags & G_WANT) == G_ARRAY)
 		retval = 0;
 	    else {
 		retval = 1;
@@ -2700,6 +2757,8 @@ Perl_eval_sv(pTHX_ SV *sv, I32 flags)
     OP* const oldop = PL_op;
     dJMPENV;
 
+    PERL_ARGS_ASSERT_EVAL_SV;
+
     if (flags & G_DISCARD) {
 	ENTER;
 	SAVETMPS;
@@ -2715,9 +2774,7 @@ Perl_eval_sv(pTHX_ SV *sv, I32 flags)
 	myop.op_flags = OPf_STACKED;
     myop.op_next = NULL;
     myop.op_type = OP_ENTEREVAL;
-    myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
-		      (flags & G_ARRAY) ? OPf_WANT_LIST :
-		      OPf_WANT_SCALAR);
+    myop.op_flags |= OP_GIMME_REVERSE(flags);
     if (flags & G_KEEPERR)
 	myop.op_flags |= OPf_SPECIAL;
 
@@ -2753,7 +2810,7 @@ Perl_eval_sv(pTHX_ SV *sv, I32 flags)
 	    goto redo_body;
 	}
 	PL_stack_sp = PL_stack_base + oldmark;
-	if (flags & G_ARRAY)
+	if ((flags & G_WANT) == G_ARRAY)
 	    retval = 0;
 	else {
 	    retval = 1;
@@ -2788,6 +2845,8 @@ Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
     dSP;
     SV* sv = newSVpv(p, 0);
 
+    PERL_ARGS_ASSERT_EVAL_PV;
+
     eval_sv(sv, G_SCALAR);
     SvREFCNT_dec(sv);
 
@@ -2821,6 +2880,9 @@ Perl_require_pv(pTHX_ const char *pv)
     dVAR;
     dSP;
     SV* sv;
+
+    PERL_ARGS_ASSERT_REQUIRE_PV;
+
     PUSHSTACKi(PERLSI_REQUIRE);
     PUTBACK;
     sv = Perl_newSVpvf(aTHX_ "require q%c%s%c", 0, pv, 0);
@@ -2834,6 +2896,8 @@ Perl_magicname(pTHX_ const char *sym, const char *name, I32 namlen)
 {
     register GV * const gv = gv_fetchpv(sym, GV_ADD, SVt_PV);
 
+    PERL_ARGS_ASSERT_MAGICNAME;
+
     if (gv)
 	sv_magic(GvSV(gv), (SV*)gv, PERL_MAGIC_sv, name, namlen);
 }
@@ -2878,6 +2942,8 @@ NULL
 };
     const char * const *p = usage_msg;
 
+    PERL_ARGS_ASSERT_USAGE;
+
     PerlIO_printf(PerlIO_stdout(),
 		  "\nUsage: %s [switches] [--] [programfile] [arguments]",
 		  name);
@@ -2909,7 +2975,6 @@ Perl_get_debug_opts(pTHX_ const char **s, bool givehelp)
       "  H  Hash dump -- usurps values()",
       "  X  Scratchpad allocation",
       "  D  Cleaning up",
-      "  S  Thread synchronization",
       "  T  Tokenising",
       "  R  Include reference counts of dumped variables (eg when using -Ds)",
       "  J  Do not s,t,P-debug (Jump over) opcodes within package DB",
@@ -2920,6 +2985,9 @@ Perl_get_debug_opts(pTHX_ const char **s, bool givehelp)
       NULL
     };
     int i = 0;
+
+    PERL_ARGS_ASSERT_GET_DEBUG_OPTS;
+
     if (isALPHA(**s)) {
 	/* if adding extra options, remember to update DEBUG_MASK */
 	static const char debopts[] = "psltocPmfrxuUHXDSTRJvCAq";
@@ -2957,6 +3025,9 @@ Perl_moreswitches(pTHX_ const char *s)
 {
     dVAR;
     UV rschar;
+    const char option = *s; /* used to remember option in -m/-M code */
+
+    PERL_ARGS_ASSERT_MORESWITCHES;
 
     switch (*s) {
     case '0':
@@ -3154,6 +3225,7 @@ Perl_moreswitches(pTHX_ const char *s)
 	    const char *end;
 	    SV *sv;
 	    const char *use = "use ";
+	    bool colon = FALSE;
 	    /* -M-foo == 'no foo'	*/
 	    /* Leading space on " no " is deliberate, to make both
 	       possibilities the same length.  */
@@ -3161,19 +3233,30 @@ Perl_moreswitches(pTHX_ const char *s)
 	    sv = newSVpvn(use,4);
 	    start = s;
 	    /* We allow -M'Module qw(Foo Bar)'	*/
-	    while(isALNUM(*s) || *s==':') ++s;
+	    while(isALNUM(*s) || *s==':') {
+		if( *s++ == ':' ) {
+		    if( *s == ':' ) 
+			s++;
+		    else
+			colon = TRUE;
+		}
+	    }
+	    if (s == start)
+		Perl_croak(aTHX_ "Module name required with -%c option",
+				    option);
+	    if (colon) 
+		Perl_croak(aTHX_ "Invalid module name %.*s with -%c option: "
+				    "contains single ':'",
+				    s - start, start, option);
 	    end = s + strlen(s);
 	    if (*s != '=') {
 		sv_catpvn(sv, start, end - start);
-		if (*(start-1) == 'm') {
+		if (option == 'm') {
 		    if (*s != '\0')
 			Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
 		    sv_catpvs( sv, " ()");
 		}
 	    } else {
-                if (s == start)
-                    Perl_croak(aTHX_ "Module name required with -%c option",
-			       s[-1]);
 		sv_catpvn(sv, start, s-start);
 		/* Use NUL as q''-delimiter.  */
 		sv_catpvs(sv, " split(/,/,q\0");
@@ -3185,7 +3268,7 @@ Perl_moreswitches(pTHX_ const char *s)
 	    Perl_av_create_and_push(aTHX_ &PL_preambleav, sv);
 	}
 	else
-	    Perl_croak(aTHX_ "Missing argument to -%c", *(s-1));
+	    Perl_croak(aTHX_ "Missing argument to -%c", option);
 	return s;
     case 'n':
 	PL_minus_n = TRUE;
@@ -3501,6 +3584,8 @@ S_open_script(pTHX_ const char *scriptname, bool dosearch,
     int fdscript = -1;
     dVAR;
 
+    PERL_ARGS_ASSERT_OPEN_SCRIPT;
+
     if (PL_e_script) {
 	PL_origfilename = savepvs("-e");
     }
@@ -3783,6 +3868,8 @@ S_validate_suid(pTHX_ const char *validarg,
     dVAR;
     const char *s, *s2;
 
+    PERL_ARGS_ASSERT_VALIDATE_SUID;
+
     /* do we need to emulate setuid on scripts? */
 
     /* This code is for those BSD systems that have setuid #! scripts disabled
@@ -4161,6 +4248,8 @@ FIX YOUR KERNEL, OR PUT A C WRAPPER AROUND THIS SCRIPT!\n");
 STATIC void
 S_validate_suid(pTHX_ PerlIO *rsfp)
 {
+    PERL_ARGS_ASSERT_VALIDATE_SUID;
+
     if (PL_euid != PL_uid || PL_egid != PL_gid) {	/* (suidperl doesn't exist, in fact) */
 #  ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
 	PerlLIO_fstat(PerlIO_fileno(rsfp),&PL_statbuf);	/* may be either wrapped or real suid */
@@ -4188,6 +4277,8 @@ S_find_beginning(pTHX_ SV* linestr_sv, PerlIO *rsfp)
     int maclines = 0;
 #endif
 
+    PERL_ARGS_ASSERT_FIND_BEGINNING;
+
     /* skip forward in input to the real script? */
 
 #ifdef MACOS_TRADITIONAL
@@ -4493,6 +4584,9 @@ void
 Perl_init_argv_symbols(pTHX_ register int argc, register char **argv)
 {
     dVAR;
+
+    PERL_ARGS_ASSERT_INIT_ARGV_SYMBOLS;
+
     argc--,argv++;	/* skip name of script */
     if (PL_doswitches) {
 	for (; argc > 0 && **argv == '-'; argc--,argv++) {
@@ -4535,6 +4629,8 @@ S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register
     dVAR;
     GV* tmpgv;
 
+    PERL_ARGS_ASSERT_INIT_POSTDUMP_SYMBOLS;
+
     PL_toptarget = newSV_type(SVt_PVFM);
     sv_setpvn(PL_toptarget, "", 0);
     PL_bodytarget = newSV_type(SVt_PVFM);
@@ -4765,6 +4861,9 @@ S_incpush_if_exists(pTHX_ SV *dir)
 {
     dVAR;
     Stat_t tmpstatbuf;
+
+    PERL_ARGS_ASSERT_INCPUSH_IF_EXISTS;
+
     if (PerlLIO_stat(SvPVX_const(dir), &tmpstatbuf) >= 0 &&
 	S_ISDIR(tmpstatbuf.st_mode)) {
 	av_push(GvAVn(PL_incgv), dir);
@@ -5008,6 +5107,8 @@ Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
     int ret;
     dJMPENV;
 
+    PERL_ARGS_ASSERT_CALL_LIST;
+
     while (av_len(paramList) >= 0) {
 	cv = (CV*)av_shift(paramList);
 	if (PL_savebegin) {
@@ -5101,8 +5202,6 @@ void
 Perl_my_exit(pTHX_ U32 status)
 {
     dVAR;
-    DEBUG_S(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
-			  (void*)thr, (unsigned long) status));
     switch (status) {
     case 0:
 	STATUS_ALL_SUCCESS;