# endif
#endif
-#ifdef SYMBIAN
+#ifdef __SYMBIAN32__
# include "symbian/symbian_proto.h"
#endif
/* Any stack-challenged places. The limit varies (and often
* is configurable), but using more than a kilobyte of stack
* is usually dubious in these systems. */
-#if defined(EPOC) || defined(SYMBIAN)
+#if defined(EPOC) || defined(__SYMBIAN32__)
/* EPOC/Symbian: need to work around the SDK features. *
* On WINS: MS VC5 generates calls to _chkstk, *
* if a "large" stack frame is allocated. *
# ifndef MULTIPLICITY
# define MULTIPLICITY
# endif
-# define pTHX register PerlInterpreter *my_perl PERL_UNUSED_DECL
+# define tTHX PerlInterpreter*
+# define pTHX register tTHX my_perl PERL_UNUSED_DECL
# define aTHX my_perl
# ifdef PERL_GLOBAL_STRUCT
-# define dTHXa(a) dVAR; pTHX = (PerlInterpreter*)a
+# define dTHXa(a) dVAR; pTHX = (tTHX)a
# else
-# define dTHXa(a) pTHX = (PerlInterpreter*)a
+# define dTHXa(a) pTHX = (tTHX)a
# endif
# ifdef PERL_GLOBAL_STRUCT
# define dTHX dVAR; pTHX = PERL_GET_THX
# define pTHX_7 8
# define pTHX_8 9
# define pTHX_9 10
+# if defined(DEBUGGING) && !defined(PERL_TRACK_MEMPOOL)
+# define PERL_TRACK_MEMPOOL
+# endif
+#else
+# undef PERL_TRACK_MEMPOOL
#endif
#define STATIC static
#define CALLREG_INTUIT_STRING CALL_FPTR(PL_regint_string)
#define CALLREGFREE CALL_FPTR(PL_regfree)
-#if defined(SYMBIAN) && defined(__GNUC__)
+/* XXX The PERL_UNUSED_DECL suffix is unfortunately rather inflexible:
+ * it assumes that in all compilers the way to suppress an "unused"
+ * warning is to have a suffix. In some compilers that might be a
+ * a compiler pragma, e.g. #pragma unused(varname). */
+
+#if defined(__SYMBIAN32__) && defined(__GNUC__)
# ifdef __cplusplus
# define PERL_UNUSED_DECL
# else
#define dNOOP extern int Perl___notused PERL_UNUSED_DECL
#ifndef pTHX
+/* Don't bother defining tTHX and sTHX; using them outside
+ * code guarded by PERL_IMPLICIT_CONTEXT is an error.
+ */
# define pTHX void
# define pTHX_
# define aTHX
#define DOSISH 1
#endif
-#if defined(__STDC__) || defined(vax11c) || defined(_AIX) || defined(__stdc__) || defined(__cplusplus) || defined( EPOC) || defined(NETWARE) || defined(SYMBIAN)
+#if defined(__STDC__) || defined(_AIX) || defined(__stdc__) || defined(__cplusplus) || defined(EPOC) || defined(NETWARE) || defined(__SYMBIAN32__)
# define STANDARD_C 1
#endif
-#if defined(__cplusplus) || defined(WIN32) || defined(__sgi) || defined(__EMX__) || defined(__DGUX) || defined( EPOC) || defined(__QNX__) || defined(NETWARE) || defined(PERL_MICRO)
+#if defined(__cplusplus) || defined(WIN32) || defined(__sgi) || defined(__EMX__) || defined(__DGUX) || defined(EPOC) || defined(__QNX__) || defined(NETWARE) || defined(PERL_MICRO)
# define DONT_DECLARE_STD 1
#endif
# include <unistd.h>
#endif
-#ifdef SYMBIAN
+#ifdef __SYMBIAN32__
# undef _SC_ARG_MAX /* Symbian has _SC_ARG_MAX but no sysconf() */
#endif
#define PERL_DONT_CREATE_GVSV
#endif
+#if !defined(HAS_WAITPID) && !defined(HAS_WAIT4) || defined(HAS_WAITPID_RUNTIME)
+#define PERL_USES_PL_PIDSTATUS
+#endif
+
+#if !defined(OS2) && !defined(WIN32) && !defined(DJGPP) && !defined(EPOC) && !defined(__SYMBIAN32__) && !defined(MACOS_TRADITIONAL)
+#define PERL_DEFAULT_DO_EXEC3_IMPLEMENTATION
+#endif
+
/* Cannot include embed.h here on Win32 as win32.h has not
yet been included and defines some config variables e.g. HAVE_INTERP_INTERN
*/
# define STRUCT_OFFSET(s,m) (Size_t)(&(((s *)0)->m))
#endif
-#ifndef SYMBIAN
+#ifndef __SYMBIAN32__
# if defined(I_STRING) || defined(__cplusplus)
# include <string.h>
# else
# define sprintf UTS_sprintf_wrap
#endif
+/* For the times when you want the return value of sprintf, and you want it
+ to be the length. Can't have a thread variable passed in, because C89 has
+ no varargs macros.
+*/
+#ifdef SPRINTF_RETURNS_STRLEN
+# define my_sprintf sprintf
+#else
+# define my_sprintf Perl_my_sprintf
+#endif
+
/* Configure gets this right but the UTS compiler gets it wrong.
-- Hal Morris <hom00@utsglobal.com> */
#ifdef UTS
# define ISHISH "epoc"
#endif
-#ifdef SYMBIAN
+#ifdef __SYMBIAN32__
# include "symbian/symbianish.h"
# include "embed.h"
# define ISHISH "symbian"
# define STATUS_NATIVE PL_statusvalue_vms
/*
* vaxc$errno is only guaranteed to be valid if errno == EVMSERR, otherwise
- * it's contents can not be trusted. Unfortunately, Perl seems to check
+ * its contents can not be trusted. Unfortunately, Perl seems to check
* it on exit, so it when PL_statusvalue_vms is updated, vaxc$errno should
* be updated also.
*/
(((I32)PL_statusvalue_vms == -1 ? SS$_ABORT : PL_statusvalue_vms) | \
(VMSISH_HUSHED ? STS$M_INHIB_MSG : 0))
-/* STATUS_NATIVE_SET - takes a NATIVE status code and converts it to a
- * UNIX/POSIX status value and updates both the native and PL_statusvalue
- * as needed. This currently seems only exist for VMS and is used in the exit
- * handling.
- */
-# define STATUS_NATIVE_SET(n) STATUS_NATIVE_SET_PORC(n, 0)
-
-/* STATUS_NATIVE_CHILD_SET - same as STATUS_NATIVE_SET, but shifts the UNIX
- * value over the correct number of bits to be a child status. Usually
- * the number of bits is 8, but that could be platform dependent. The NATIVE
- * status code is presumed to have either from a child process.
+/* STATUS_NATIVE_CHILD_SET - Calculate UNIX status that matches the child
+ * exit code and shifts the UNIX value over the correct number of bits to
+ * be a child status. Usually the number of bits is 8, but that could be
+ * platform dependent. The NATIVE status code is presumed to have either
+ * from a child process.
*/
-# define STATUS_NATIVE_CHILD_SET(n) STATUS_NATIVE_SET_PORC(n, 1)
+/* This is complicated. The child processes return a true native VMS
+ status which must be saved. But there is an assumption in Perl that
+ the UNIX child status has some relationship to errno values, so
+ Perl tries to translate it to text in some of the tests.
+ In order to get the string translation correct, for the error, errno
+ must be EVMSERR, but that generates a different text message
+ than what the test programs are expecting. So an errno value must
+ be derived from the native status value when an error occurs.
+ That will hide the true native status message. With this version of
+ perl, the true native child status can always be retrieved so that
+ is not a problem. But in this case, Pl_statusvalue and errno may
+ have different values in them.
+ */
- /* internal convert VMS status codes to UNIX error or status codes */
-# define STATUS_NATIVE_SET_PORC(n, _x) \
+# define STATUS_NATIVE_CHILD_SET(n) \
STMT_START { \
I32 evalue = (I32)n; \
if (evalue == EVMSERR) { \
PL_statusvalue = evalue; \
} else { \
PL_statusvalue_vms = evalue; \
- if ((I32)PL_statusvalue_vms == -1) { \
+ if (evalue == -1) { \
PL_statusvalue = -1; \
PL_statusvalue_vms = SS$_ABORT; /* Should not happen */ \
} else \
- PL_statusvalue = Perl_vms_status_to_unix(evalue, _x); \
+ PL_statusvalue = Perl_vms_status_to_unix(evalue, 1); \
set_vaxc_errno(evalue); \
- set_errno(PL_statusvalue); \
- if (_x) PL_statusvalue = PL_statusvalue << child_offset_bits; \
+ if ((PL_statusvalue_vms & C_FAC_POSIX) == C_FAC_POSIX) \
+ set_errno(EVMSERR); \
+ else set_errno(Perl_vms_status_to_unix(evalue, 0)); \
+ PL_statusvalue = PL_statusvalue << child_offset_bits; \
} \
} STMT_END
# define STATUS_UNIX_SET(n) \
STMT_START { \
I32 evalue = (I32)n; \
- PL_statusvalue = evalue; \
+ PL_statusvalue = evalue; \
if (PL_statusvalue != -1) { \
- if (PL_statusvalue != EVMSERR) { \
- PL_statusvalue &= 0xFFFF; \
- PL_statusvalue_vms = Perl_unix_status_to_vms(evalue); \
- } \
- else { \
- PL_statusvalue_vms = vaxc$errno; \
- } \
+ if (PL_statusvalue != EVMSERR) { \
+ PL_statusvalue &= 0xFFFF; \
+ if (MY_POSIX_EXIT) \
+ PL_statusvalue_vms=PL_statusvalue ? SS$_ABORT : SS$_NORMAL;\
+ else PL_statusvalue_vms = Perl_unix_status_to_vms(evalue); \
+ } \
+ else { \
+ PL_statusvalue_vms = vaxc$errno; \
+ } \
} \
- else PL_statusvalue_vms = SS$_ABORT; \
- set_vaxc_errno(evalue); \
+ else PL_statusvalue_vms = SS$_ABORT; \
+ set_vaxc_errno(PL_statusvalue_vms); \
} STMT_END
/* STATUS_UNIX_EXIT_SET - Takes a UNIX/POSIX exit code and sets
* the NATIVE error status based on it. It does not assume that
- * the UNIX/POSIX exit codes have any relationship to errno
- * values and are only being encoded into the NATIVE form so
- * that they can be properly passed through to the calling
- * program or shell.
+ * the UNIX/POSIX exit codes have any relationship to errno, except
+ * that 0 indicates a success. When in the default mode to comply
+ * with the Perl VMS documentation, any other code sets the NATIVE
+ * status to a failure code of SS$_ABORT.
+ *
+ * In the new POSIX EXIT mode, native status will be set so that the
+ * actual exit code will can be retrieved by the calling program or
+ * shell.
+ *
+ * If the exit code is not clearly a UNIX parent or child exit status,
+ * it will be passed through as a VMS status.
*/
-# define STATUS_UNIX_EXIT_SET(n) \
+# define STATUS_UNIX_EXIT_SET(n) \
STMT_START { \
I32 evalue = (I32)n; \
PL_statusvalue = evalue; \
- if (PL_statusvalue != -1) { \
- if (PL_statusvalue != EVMSERR) { \
- if (PL_statusvalue < 256) { \
- if (PL_statusvalue == 0) \
- PL_statusvalue_vms == SS$_NORMAL; \
- else \
- PL_statusvalue_vms = MY_POSIX_EXIT ? \
- (C_FAC_POSIX | (evalue << 3 ) | (evalue == 1)? \
- (STS$K_ERROR | STS$M_INHIB_MSG) : 0) : evalue; \
- } else { /* forgive them Perl, for they have sinned */ \
- PL_statusvalue_vms = evalue; \
- } /* And obviously used a VMS status value instead of UNIX */ \
- PL_statusvalue = EVMSERR; \
- } \
- else { \
- PL_statusvalue_vms = vaxc$errno; \
- } \
+ if (evalue != -1) { \
+ if (evalue <= 0xFF00) { \
+ if (evalue > 0xFF) \
+ evalue = (evalue >> child_offset_bits) & 0xFF; \
+ if (evalue == 0) \
+ PL_statusvalue_vms == SS$_NORMAL; \
+ else \
+ if (MY_POSIX_EXIT) \
+ PL_statusvalue_vms = \
+ (C_FAC_POSIX | (evalue << 3 ) | (evalue == 1)? \
+ (STS$K_ERROR | STS$M_INHIB_MSG) : 1); \
+ else \
+ PL_statusvalue_vms = SS$_ABORT; \
+ } else { /* forgive them Perl, for they have sinned */ \
+ if (evalue != EVMSERR) PL_statusvalue_vms = evalue; \
+ else PL_statusvalue_vms = vaxc$errno; \
+ /* And obviously used a VMS status value instead of UNIX */ \
+ PL_statusvalue = EVMSERR; \
+ } \
} \
else PL_statusvalue_vms = SS$_ABORT; \
set_vaxc_errno(PL_statusvalue_vms); \
} STMT_END
+
+ /* STATUS_EXIT_SET - Takes a NATIVE/UNIX/POSIX exit code
+ * and sets the NATIVE error status based on it. This special case
+ * is needed to maintain compatibility with past VMS behavior.
+ *
+ * In the default mode on VMS, this number is passed through as
+ * both the NATIVE and UNIX status. Which makes it different
+ * that the STATUS_UNIX_EXIT_SET.
+ *
+ * In the new POSIX EXIT mode, native status will be set so that the
+ * actual exit code will can be retrieved by the calling program or
+ * shell.
+ *
+ */
+
+# define STATUS_EXIT_SET(n) \
+ STMT_START { \
+ I32 evalue = (I32)n; \
+ PL_statusvalue = evalue; \
+ if (MY_POSIX_EXIT) \
+ PL_statusvalue_vms = \
+ (C_FAC_POSIX | (evalue << 3 ) | (evalue == 1)? \
+ (STS$K_ERROR | STS$M_INHIB_MSG) : 1); \
+ else \
+ PL_statusvalue_vms = evalue ? evalue : SS$_NORMAL; \
+ set_vaxc_errno(PL_statusvalue_vms); \
+ } STMT_END
+
+
+ /* This macro forces a success status */
# define STATUS_ALL_SUCCESS \
(PL_statusvalue = 0, PL_statusvalue_vms = SS$_NORMAL)
+
+ /* This macro forces a failure status */
# define STATUS_ALL_FAILURE (PL_statusvalue = 1, \
vaxc$errno = PL_statusvalue_vms = MY_POSIX_EXIT ? \
(C_FAC_POSIX | (1 << 3) | STS$K_ERROR | STS$M_INHIB_MSG) : SS$_ABORT)
+
#else
# define STATUS_NATIVE PL_statusvalue_posix
# if defined(WCOREDUMP)
PL_statusvalue &= 0xFFFF; \
} STMT_END
# define STATUS_UNIX_EXIT_SET(n) STATUS_UNIX_SET(n)
+# define STATUS_EXIT_SET(n) STATUS_UNIX_SET(n)
# define STATUS_CURRENT STATUS_UNIX
# define STATUS_EXIT STATUS_UNIX
# define STATUS_ALL_SUCCESS (PL_statusvalue = 0, PL_statusvalue_posix = 0)
#ifndef IOCPARM_LEN
# ifdef IOCPARM_MASK
- /* on BSDish systes we're safe */
+ /* on BSDish systems we're safe */
# define IOCPARM_LEN(x) (((x) >> 16) & IOCPARM_MASK)
# else
+# if defined(_IOC_SIZE) && defined(__GLIBC__)
+ /* on Linux systems we're safe */
+# define IOCPARM_LEN(x) _IOC_SIZE(x)
+# else
/* otherwise guess at what's safe */
-# define IOCPARM_LEN(x) 256
+# define IOCPARM_LEN(x) 256
+# endif
# endif
#endif
#ifndef assert /* <assert.h> might have been included somehow */
#define assert(what) PERL_DEB( \
((what) ? ((void) 0) : \
- (Perl_croak(aTHX_ "Assertion %s failed: file \"" __FILE__ \
+ (Perl_croak_nocontext("Assertion %s failed: file \"" __FILE__ \
"\", line %d", STRINGIFY(what), __LINE__), \
PerlProc_exit(1), \
(void) 0)))
# define MALLOC_TERM
#endif
+#if defined(PERL_IMPLICIT_CONTEXT)
+struct perl_memory_debug_header {
+ tTHX interpreter;
+# ifdef PERL_POISON
+ MEM_SIZE size;
+ U8 in_use;
+# endif
+
+#define PERL_POISON_INUSE 29
+#define PERL_POISON_FREE 159
+};
+
+# define sTHX (sizeof(struct perl_memory_debug_header) + \
+ (MEM_ALIGNBYTES - sizeof(struct perl_memory_debug_header) \
+ %MEM_ALIGNBYTES) % MEM_ALIGNBYTES)
+
+#endif
+
typedef int (CPERLscope(*runops_proc_t)) (pTHX);
typedef void (CPERLscope(*share_proc_t)) (pTHX_ SV *sv);
INIT("\"my\" variable %s can't be in a package");
EXTCONST char PL_no_localize_ref[]
INIT("Can't localize through a reference");
-#ifdef PERL_MALLOC_WRAP
EXTCONST char PL_memory_wrap[]
INIT("panic: memory wrap");
-#endif
EXTCONST char PL_uuemap[65]
INIT("`!\"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_");
"LOOP",
"SUBST",
"BLOCK",
+ "FORMAT",
+ "GIVEN",
+ "WHEN"
};
#else
EXTCONST char* PL_block_type[];
to_sv_amg, to_av_amg,
to_hv_amg, to_gv_amg,
to_cv_amg, iter_amg,
- int_amg, DESTROY_amg,
+ int_amg, smart_amg,
+
+ /* Note: Perl_Gv_AMupdate() assumes that DESTROY is the last entry */
+ DESTROY_amg,
max_amg_code
/* Do not leave a trailing comma here. C9X allows it, C89 doesn't. */
};
"(${}", "(@{}",
"(%{}", "(*{}",
"(&{}", "(<>",
- "(int", "DESTROY",
+ "(int", "(~~",
+ "DESTROY"
};
#else
EXTCONST char * PL_AMG_names[NofAMmeth];
* Code that uses these macros is responsible for the following:
* 1. #define MY_CXT_KEY to a unique string, e.g.
* "DynaLoader::_guts" XS_VERSION
+ * XXX in the current implementation, this string is ignored.
* 2. Declare a typedef named my_cxt_t that is a structure that contains
* all the data that needs to be interpreter-local.
* 3. Use the START_MY_CXT macro after the declaration of my_cxt_t.
/* This must appear in all extensions that define a my_cxt_t structure,
* right after the definition (i.e. at file scope). The non-threads
* case below uses it to declare the data as static. */
-#define START_MY_CXT
-
-/* Fetches the SV that keeps the per-interpreter data. */
-#define dMY_CXT_SV \
- SV *my_cxt_sv = *hv_fetch(PL_modglobal, MY_CXT_KEY, \
- sizeof(MY_CXT_KEY)-1, TRUE)
+#define START_MY_CXT static int my_cxt_index = -1;
/* This declaration should be used within all functions that use the
* interpreter-local data. */
#define dMY_CXT \
- dMY_CXT_SV; \
- my_cxt_t *my_cxtp = INT2PTR(my_cxt_t*, SvUV(my_cxt_sv))
+ my_cxt_t *my_cxtp = (my_cxt_t *)PL_my_cxt_list[my_cxt_index]
+#define dMY_CXT_INTERP(my_perl) \
+ my_cxt_t *my_cxtp = (my_cxt_t *)(my_perl)->Imy_cxt_list[my_cxt_index]
/* Creates and zeroes the per-interpreter data.
* (We allocate my_cxtp in a Perl SV so that it will be released when
* the interpreter goes away.) */
#define MY_CXT_INIT \
- dMY_CXT_SV; \
- /* newSV() allocates one more than needed */ \
- my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1));\
- Zero(my_cxtp, 1, my_cxt_t); \
- sv_setuv(my_cxt_sv, PTR2UV(my_cxtp))
+ my_cxt_t *my_cxtp = \
+ (my_cxt_t*)Perl_my_cxt_init(aTHX_ &my_cxt_index, sizeof(my_cxt_t))
+#define MY_CXT_INIT_INTERP(my_perl) \
+ my_cxt_t *my_cxtp = \
+ (my_cxt_t*)Perl_my_cxt_init(my_perl, &my_cxt_index, sizeof(my_cxt_t))
/* Clones the per-interpreter data. */
#define MY_CXT_CLONE \
- dMY_CXT_SV; \
my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1));\
- Copy(INT2PTR(my_cxt_t*, SvUV(my_cxt_sv)), my_cxtp, 1, my_cxt_t);\
- sv_setuv(my_cxt_sv, PTR2UV(my_cxtp))
+ Copy(PL_my_cxt_list[my_cxt_index], my_cxtp, 1, my_cxt_t);\
+ PL_my_cxt_list[my_cxt_index] = my_cxtp \
/* This macro must be used to access members of the my_cxt_t structure.
* e.g. MYCXT.some_data */
#define aMY_CXT_ aMY_CXT,
#define _aMY_CXT ,aMY_CXT
-#else /* USE_ITHREADS */
+#else /* PERL_IMPLICIT_CONTEXT */
#define START_MY_CXT static my_cxt_t my_cxt;
#define dMY_CXT_SV dNOOP
#define aMY_CXT_
#define _aMY_CXT
-#endif /* !defined(USE_ITHREADS) */
+#endif /* !defined(PERL_IMPLICIT_CONTEXT) */
#ifdef I_FCNTL
# include <fcntl.h>
#pragma message disable (mainparm) /* Perl uses the envp in main(). */
#endif
+#define do_open(g, n, l, a, rm, rp, sf) \
+ do_openn(g, n, l, a, rm, rp, sf, (SV **) NULL, 0)
+#ifdef PERL_DEFAULT_DO_EXEC3_IMPLEMENTATION
+# define do_exec(cmd) do_exec3(cmd,0,0)
+#endif
+#ifdef OS2
+# define do_aexec Perl_do_aexec
+#else
+# define do_aexec(really, mark,sp) do_aexec5(really, mark, sp, 0, 0)
+#endif
+
/* and finally... */
#define PERL_PATCHLEVEL_H_IMPLICIT
#include "patchlevel.h"
projects / p5sagit/p5-mst-13.2.git / blobdiff