X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=perl.h;h=1612020c16f6341dae1c1af26eb7267633eeda5e;hb=a6b599c70633c3b011aba1a198149d25707cbc98;hp=f613aac8ad687fbe0fddf9f1201d109526a96337;hpb=7a7fd8e0ed51785cbfb9fc040ff670a40911ca48;p=p5sagit%2Fp5-mst-13.2.git diff --git a/perl.h b/perl.h index f613aac..1612020 100644 --- a/perl.h +++ b/perl.h @@ -88,14 +88,14 @@ # 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. * @@ -148,12 +148,13 @@ # 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 @@ -171,6 +172,11 @@ # 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 @@ -190,7 +196,12 @@ #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 @@ -226,6 +237,9 @@ #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 @@ -385,11 +399,11 @@ register struct op *Perl_op asm(stringify(OP_IN_REGISTER)); #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 @@ -547,7 +561,7 @@ register struct op *Perl_op asm(stringify(OP_IN_REGISTER)); # include #endif -#ifdef SYMBIAN +#ifdef __SYMBIAN32__ # undef _SC_ARG_MAX /* Symbian has _SC_ARG_MAX but no sysconf() */ #endif @@ -810,6 +824,14 @@ int usleep(unsigned int); #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 */ @@ -833,7 +855,7 @@ int usleep(unsigned int); # define STRUCT_OFFSET(s,m) (Size_t)(&(((s *)0)->m)) #endif -#ifndef SYMBIAN +#ifndef __SYMBIAN32__ # if defined(I_STRING) || defined(__cplusplus) # include # else @@ -1397,6 +1419,16 @@ int sockatmark(int); # 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 */ #ifdef UTS @@ -2312,7 +2344,7 @@ typedef struct clone_params CLONE_PARAMS; # define ISHISH "epoc" #endif -#ifdef SYMBIAN +#ifdef __SYMBIAN32__ # include "symbian/symbianish.h" # include "embed.h" # define ISHISH "symbian" @@ -2547,7 +2579,7 @@ typedef pthread_key_t perl_key; # 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. */ @@ -2569,24 +2601,29 @@ typedef pthread_key_t perl_key; (((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) { \ @@ -2594,14 +2631,16 @@ typedef pthread_key_t perl_key; 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 @@ -2620,58 +2659,102 @@ typedef pthread_key_t perl_key; # 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) @@ -2718,6 +2801,7 @@ typedef pthread_key_t perl_key; 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) @@ -2888,11 +2972,16 @@ typedef pthread_key_t perl_key; #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 @@ -3413,7 +3502,7 @@ Gid_t getegid (void); #ifndef assert /* 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))) @@ -3637,6 +3726,24 @@ typedef Sighandler_t Sigsave_t; # 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); @@ -3710,10 +3817,8 @@ EXTCONST char PL_no_myglob[] 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[\\]^_"); @@ -3931,6 +4036,9 @@ EXTCONST char* const PL_block_type[] = { "LOOP", "SUBST", "BLOCK", + "FORMAT", + "GIVEN", + "WHEN" }; #else EXTCONST char* PL_block_type[]; @@ -4637,7 +4745,10 @@ enum { 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. */ }; @@ -4684,7 +4795,8 @@ EXTCONST char * const PL_AMG_names[NofAMmeth] = { "(${}", "(@{}", "(%{}", "(*{}", "(&{}", "(<>", - "(int", "DESTROY", + "(int", "(~~", + "DESTROY" }; #else EXTCONST char * PL_AMG_names[NofAMmeth]; @@ -4982,6 +5094,7 @@ typedef struct am_table_short AMTS; * 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. @@ -4998,35 +5111,30 @@ typedef struct am_table_short AMTS; /* 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 */ @@ -5041,7 +5149,7 @@ typedef struct am_table_short AMTS; #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 @@ -5057,7 +5165,7 @@ typedef struct am_table_short AMTS; #define aMY_CXT_ #define _aMY_CXT -#endif /* !defined(USE_ITHREADS) */ +#endif /* !defined(PERL_IMPLICIT_CONTEXT) */ #ifdef I_FCNTL # include @@ -5314,6 +5422,17 @@ extern void moncontrol(int); #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"