X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=perl.c;h=fddaf5308f9953b2da643ae65ada966d04866a76;hb=dd9703c97d9c97246c909791992f0b966b2be5d5;hp=a96fbbd09335a8e4f1efcf411e5b87479ac29d09;hpb=317ea90d97caba0232674f77b3cbed1394243c39;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/perl.c b/perl.c
index a96fbbd..fddaf53 100644
--- a/perl.c
+++ b/perl.c
@@ -1,6 +1,6 @@
 /*    perl.c
  *
- *    Copyright (c) 1987-2001 Larry Wall
+ *    Copyright (c) 1987-2002 Larry Wall
  *
  *    You may distribute under the terms of either the GNU General Public
  *    License or the Artistic License, as specified in the README file.
@@ -102,6 +102,8 @@ perl_alloc_using(struct IPerlMem* ipM, struct IPerlMem* ipMS,
 #else
 
 /*
+=head1 Embedding Functions
+
 =for apidoc perl_alloc
 
 Allocates a new Perl interpreter.  See L<perlembed>.
@@ -113,6 +115,9 @@ PerlInterpreter *
 perl_alloc(void)
 {
     PerlInterpreter *my_perl;
+#ifdef USE_5005THREADS
+    dTHX;
+#endif
 
     /* New() needs interpreter, so call malloc() instead */
     my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
@@ -200,16 +205,6 @@ perl_construct(pTHXx)
 
 	PL_sighandlerp = Perl_sighandler;
 	PL_pidstatus = newHV();
-
-#ifdef MSDOS
-	/*
-	 * There is no way we can refer to them from Perl so close them to save
-	 * space.  The other alternative would be to provide STDAUX and STDPRN
-	 * filehandles.
-	 */
-	(void)PerlIO_close(PerlIO_importFILE(stdaux, 0));
-	(void)PerlIO_close(PerlIO_importFILE(stdprn, 0));
-#endif
     }
 
     PL_rs = newSVpvn("\n", 1);
@@ -269,8 +264,7 @@ perl_construct(pTHXx)
     PL_regex_pad = AvARRAY(PL_regex_padav);
 #endif
 #ifdef USE_REENTRANT_API
-    New(31337, PL_reentrant_buffer,1, REBUF);
-    New(31337, PL_reentrant_buffer->tmbuff,1, struct tm);
+    Perl_reentrant_init(aTHX);
 #endif
 
     /* Note that strtab is a rather special HV.  Assumptions are made
@@ -694,15 +688,8 @@ perl_destruct(pTHXx)
     if (!specialCopIO(PL_compiling.cop_io))
 	SvREFCNT_dec(PL_compiling.cop_io);
     PL_compiling.cop_io = Nullsv;
-#ifdef USE_ITHREADS
-    Safefree(CopFILE(&PL_compiling));
-    CopFILE(&PL_compiling) = Nullch;
-    Safefree(CopSTASHPV(&PL_compiling));
-#else
-    SvREFCNT_dec(CopFILEGV(&PL_compiling));
-    CopFILEGV(&PL_compiling) = Nullgv;
-    /* cop_stash is not refcounted */
-#endif
+    CopFILE_free(&PL_compiling);
+    CopSTASH_free(&PL_compiling);
 
     /* Prepare to destruct main symbol table.  */
 
@@ -719,18 +706,18 @@ perl_destruct(pTHXx)
     FREETMPS;
     if (destruct_level >= 2 && ckWARN_d(WARN_INTERNAL)) {
 	if (PL_scopestack_ix != 0)
-	    Perl_warner(aTHX_ WARN_INTERNAL,
+	    Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
 	         "Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
 		 (long)PL_scopestack_ix);
 	if (PL_savestack_ix != 0)
-	    Perl_warner(aTHX_ WARN_INTERNAL,
+	    Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
 		 "Unbalanced saves: %ld more saves than restores\n",
 		 (long)PL_savestack_ix);
 	if (PL_tmps_floor != -1)
-	    Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced tmps: %ld more allocs than frees\n",
+	    Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced tmps: %ld more allocs than frees\n",
 		 (long)PL_tmps_floor + 1);
 	if (cxstack_ix != -1)
-	    Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced context: %ld more PUSHes than POPs\n",
+	    Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced context: %ld more PUSHes than POPs\n",
 		 (long)cxstack_ix + 1);
     }
 
@@ -771,7 +758,7 @@ perl_destruct(pTHXx)
 	hent = array[0];
 	for (;;) {
 	    if (hent && ckWARN_d(WARN_INTERNAL)) {
-		Perl_warner(aTHX_ WARN_INTERNAL,
+		Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
 		     "Unbalanced string table refcount: (%d) for \"%s\"",
 		     HeVAL(hent) - Nullsv, HeKEY(hent));
 		HeVAL(hent) = Nullsv;
@@ -807,7 +794,7 @@ perl_destruct(pTHXx)
     SvREADONLY_off(&PL_sv_undef);
 
     if (PL_sv_count != 0 && ckWARN_d(WARN_INTERNAL))
-	Perl_warner(aTHX_ WARN_INTERNAL,"Scalars leaked: %ld\n", (long)PL_sv_count);
+	Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Scalars leaked: %ld\n", (long)PL_sv_count);
 
 #if defined(PERLIO_LAYERS)
     /* No more IO - including error messages ! */
@@ -848,7 +835,7 @@ perl_destruct(pTHXx)
 #endif /* USE_5005THREADS */
 
 #ifdef USE_REENTRANT_API
-    Safefree(PL_reentrant_buffer->tmbuff);
+    Safefree(PL_reentrant_buffer->tmbuf);
     Safefree(PL_reentrant_buffer);
 #endif
 
@@ -1363,7 +1350,7 @@ print \"  \\@INC:\\n    @INC\\n\";");
 	Sighandler_t sigstate = rsignal_state(SIGCHLD);
 	if (sigstate == SIG_IGN) {
 	    if (ckWARN(WARN_SIGNAL))
-		Perl_warner(aTHX_ WARN_SIGNAL,
+		Perl_warner(aTHX_ packWARN(WARN_SIGNAL),
 			    "Can't ignore signal CHLD, forcing to default");
 	    (void)rsignal(SIGCHLD, (Sighandler_t)SIG_DFL);
 	}
@@ -1622,6 +1609,8 @@ S_run_body(pTHX_ I32 oldscope)
 }
 
 /*
+=head1 SV Manipulation Functions
+
 =for apidoc p||get_sv
 
 Returns the SV of the specified Perl scalar.  If C<create> is set and the
@@ -1649,6 +1638,8 @@ Perl_get_sv(pTHX_ const char *name, I32 create)
 }
 
 /*
+=head1 Array Manipulation Functions
+
 =for apidoc p||get_av
 
 Returns the AV of the specified Perl array.  If C<create> is set and the
@@ -1670,6 +1661,8 @@ Perl_get_av(pTHX_ const char *name, I32 create)
 }
 
 /*
+=head1 Hash Manipulation Functions
+
 =for apidoc p||get_hv
 
 Returns the HV of the specified Perl hash.  If C<create> is set and the
@@ -1691,6 +1684,8 @@ Perl_get_hv(pTHX_ const char *name, I32 create)
 }
 
 /*
+=head1 CV Manipulation Functions
+
 =for apidoc p||get_cv
 
 Returns the CV of the specified Perl subroutine.  If C<create> is set and
@@ -1722,6 +1717,9 @@ Perl_get_cv(pTHX_ const char *name, I32 create)
 /* Be sure to refetch the stack pointer after calling these routines. */
 
 /*
+
+=head1 Callback Functions
+
 =for apidoc p||call_argv
 
 Performs a callback to the specified Perl sub.  See L<perlcall>.
@@ -2103,6 +2101,8 @@ Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
 /* Require a module. */
 
 /*
+=head1 Embedding Functions
+
 =for apidoc p||require_pv
 
 Tells Perl to C<require> the file named by the string argument.  It is
@@ -2259,7 +2259,7 @@ Perl_moreswitches(pTHX_ char *s)
 	forbid_setid("-D");
 	if (isALPHA(s[1])) {
 	    /* if adding extra options, remember to update DEBUG_MASK */
-	    static char debopts[] = "psltocPmfrxuLHXDSTR";
+	    static char debopts[] = "psltocPmfrxuLHXDSTRJ";
 	    char *d;
 
 	    for (s++; *s && (d = strchr(debopts,*s)); s++)
@@ -2272,7 +2272,7 @@ Perl_moreswitches(pTHX_ char *s)
 	PL_debug |= DEBUG_TOP_FLAG;
 #else
 	if (ckWARN_d(WARN_DEBUGGING))
-	    Perl_warner(aTHX_ WARN_DEBUGGING,
+	    Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
 	           "Recompile perl with -DDEBUGGING to use -D switch\n");
 	for (s++; isALNUM(*s); s++) ;
 #endif
@@ -2442,10 +2442,10 @@ Perl_moreswitches(pTHX_ char *s)
 #endif
 
 	PerlIO_printf(PerlIO_stdout(),
-		      "\n\nCopyright 1987-2001, Larry Wall\n");
+		      "\n\nCopyright 1987-2002, Larry Wall\n");
 #ifdef MACOS_TRADITIONAL
 	PerlIO_printf(PerlIO_stdout(),
-		      "\nMac OS port Copyright 1991-2001, Matthias Neeracher;\n"
+		      "\nMac OS port Copyright 1991-2002, Matthias Neeracher;\n"
 		      "maintained by Chris Nandor\n");
 #endif
 #ifdef MSDOS
@@ -2460,7 +2460,7 @@ Perl_moreswitches(pTHX_ char *s)
 #ifdef OS2
 	PerlIO_printf(PerlIO_stdout(),
 		      "\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
-		      "Version 5 port Copyright (c) 1994-1999, Andreas Kaiser, Ilya Zakharevich\n");
+		      "Version 5 port Copyright (c) 1994-2002, Andreas Kaiser, Ilya Zakharevich\n");
 #endif
 #ifdef atarist
 	PerlIO_printf(PerlIO_stdout(),
@@ -2472,7 +2472,7 @@ Perl_moreswitches(pTHX_ char *s)
 #endif
 #ifdef MPE
 	PerlIO_printf(PerlIO_stdout(),
-		      "MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-2001\n");
+		      "MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-2002\n");
 #endif
 #ifdef OEMVS
 	PerlIO_printf(PerlIO_stdout(),
@@ -2480,7 +2480,7 @@ Perl_moreswitches(pTHX_ char *s)
 #endif
 #ifdef __VOS__
 	PerlIO_printf(PerlIO_stdout(),
-		      "Stratus VOS port by Paul_Green@stratus.com, 1997-1999\n");
+		      "Stratus VOS port by Paul_Green@stratus.com, 1997-2002\n");
 #endif
 #ifdef __OPEN_VM
 	PerlIO_printf(PerlIO_stdout(),
@@ -2496,10 +2496,10 @@ Perl_moreswitches(pTHX_ char *s)
 #endif
 #ifdef EPOC
 	PerlIO_printf(PerlIO_stdout(),
-		      "EPOC port by Olaf Flebbe, 1999-2000\n");
+		      "EPOC port by Olaf Flebbe, 1999-2002\n");
 #endif
 #ifdef UNDER_CE
-	printf("WINCE port by Rainer Keuchel, 2001\n");
+	printf("WINCE port by Rainer Keuchel, 2001-2002\n");
 	printf("Built on " __DATE__ " " __TIME__ "\n\n");
 	wce_hitreturn();
 #endif
@@ -2702,11 +2702,7 @@ S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript)
 	}
     }
 
-#   ifdef USE_ITHREADS
-        Safefree(CopFILE(PL_curcop));
-#   else
-        SvREFCNT_dec(CopFILEGV(PL_curcop));
-#   endif
+    CopFILE_free(PL_curcop);
     CopFILE_set(PL_curcop, PL_origfilename);
     if (strEQ(PL_origfilename,"-"))
 	scriptname = "";
@@ -3445,7 +3441,13 @@ S_procself_val(pTHX_ SV *sv, char *arg0)
 {
     char buf[MAXPATHLEN];
     int len = readlink(PROCSELFEXE_PATH, buf, sizeof(buf) - 1);
-    if (len > 0) {
+    /* FreeBSD's implementation is acknowledged to be imperfect, sometimes
+       returning the text "unknown" from the readlink rather than the path
+       to the executable (or returning an error from the readlink).  Any valid
+       path has a '/' in it somewhere, so use that to validate the result.
+       See http://www.freebsd.org/cgi/query-pr.cgi?pr=35703
+    */
+    if (len > 0 && memchr(buf, '/', len)) {
 	sv_setpvn(sv,buf,len);
     }
     else {