X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=perl.h;h=cdb2b86f54bc17ec82fad627d1e57d3e23a97dbc;hb=3dab1dad3c281a8a3802c3e053703d7cabca032a;hp=c85543dd50ecc644f37e494a15e223b494fb08f9;hpb=ad73156c09397f3cfc63484d3edc50554da0fe15;p=p5sagit%2Fp5-mst-13.2.git diff --git a/perl.h b/perl.h index c85543d..cdb2b86 100644 --- a/perl.h +++ b/perl.h @@ -1,7 +1,7 @@ /* perl.h * * Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, - * 2000, 2001, 2002, 2003, 2004, 2005 by Larry Wall and others + * 2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -34,7 +34,11 @@ #ifdef PERL_MICRO # include "uconfig.h" #else -# include "config.h" +# ifndef USE_CROSS_COMPILE +# include "config.h" +# else +# include "xconfig.h" +# endif #endif /* See L for detailed notes on @@ -59,23 +63,24 @@ # endif #endif -#if defined(MULTIPLICITY) -# ifndef PERL_IMPLICIT_CONTEXT -# define PERL_IMPLICIT_CONTEXT -# endif -#endif - #ifdef PERL_GLOBAL_STRUCT_PRIVATE # ifndef PERL_GLOBAL_STRUCT # define PERL_GLOBAL_STRUCT # endif #endif + #ifdef PERL_GLOBAL_STRUCT # ifndef MULTIPLICITY # define MULTIPLICITY # endif #endif +#ifdef MULTIPLICITY +# ifndef PERL_IMPLICIT_CONTEXT +# define PERL_IMPLICIT_CONTEXT +# endif +#endif + /* undef WIN32 when building on Cygwin (for libwin32) - gph */ #ifdef __CYGWIN__ # undef WIN32 @@ -88,14 +93,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 +153,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 +177,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 +201,19 @@ #define CALLREG_INTUIT_STRING CALL_FPTR(PL_regint_string) #define CALLREGFREE CALL_FPTR(PL_regfree) -#if defined(SYMBIAN) && defined(__GNUC__) +/* + * Because of backward compatibility reasons the PERL_UNUSED_DECL + * cannot be changed from postfix to PERL_UNUSED_DECL(x). Sigh. + * + * Note that there are C compilers such as MetroWerks CodeWarrior + * which do not have an "inlined" way (like the gcc __attribute__) of + * marking unused variables (they need e.g. a #pragma) and therefore + * cpp macros like PERL_UNUSED_DECL cannot work for this purpose, even + * if it were PERL_UNUSED_DECL(x), which it cannot be (see above). + * + */ + +#if defined(__SYMBIAN32__) && defined(__GNUC__) # ifdef __cplusplus # define PERL_UNUSED_DECL # else @@ -199,7 +222,7 @@ #endif #ifndef PERL_UNUSED_DECL -# ifdef HASATTRIBUTE_UNUSED +# if defined(HASATTRIBUTE_UNUSED) && !defined(__cplusplus) # define PERL_UNUSED_DECL __attribute__unused__ # else # define PERL_UNUSED_DECL @@ -210,21 +233,31 @@ * for silencing unused variables that are actually used most of the time, * but we cannot quite get rid of, such as "ax" in PPCODE+noargs xsubs */ -#define PERL_UNUSED_VAR(var) ((void)var) - -#ifndef LINT_UNUSED_ARG -# ifdef lint +#ifndef PERL_UNUSED_ARG +# if defined(lint) && defined(S_SPLINT_S) /* www.splint.org */ # include -# define LINT_UNUSED_ARG(x) NOTE(ARGUNUSED(x)) +# define PERL_UNUSED_ARG(x) NOTE(ARGUNUSED(x)) # else -# define LINT_UNUSED_ARG(x) +# define PERL_UNUSED_ARG(x) ((void)x) # endif #endif +#ifndef PERL_UNUSED_VAR +# define PERL_UNUSED_VAR(x) ((void)x) +#endif + +#ifdef USE_ITHREADS +# define PERL_UNUSED_CONTEXT PERL_UNUSED_ARG(my_perl) +#else +# define PERL_UNUSED_CONTEXT +#endif -#define NOOP (void)0 -#define dNOOP extern int Perl___notused PERL_UNUSED_DECL +#define NOOP /*EMPTY*/(void)0 +#define dNOOP extern int /*@unused@*/ 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 @@ -314,12 +347,18 @@ register struct op *Perl_op asm(stringify(OP_IN_REGISTER)); # endif #endif -#if defined(__STRICT_ANSI__) && defined(PERL_GCC_PEDANTIC) -# if !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN) +#if defined(PERL_GCC_PEDANTIC) +# ifndef PERL_GCC_BRACE_GROUPS_FORBIDDEN # define PERL_GCC_BRACE_GROUPS_FORBIDDEN # endif #endif +#if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN) && !defined(__cplusplus) +# ifndef PERL_USE_GCC_BRACE_GROUPS +# define PERL_USE_GCC_BRACE_GROUPS +# endif +#endif + /* * STMT_START { statements; } STMT_END; * can be used as a single statement, as in @@ -328,7 +367,7 @@ register struct op *Perl_op asm(stringify(OP_IN_REGISTER)); * Trying to select a version that gives no warnings... */ #if !(defined(STMT_START) && defined(STMT_END)) -# if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN) && !defined(__cplusplus) +# ifdef PERL_USE_GCC_BRACE_GROUPS # define STMT_START (void)( /* gcc supports "({ STATEMENTS; })" */ # define STMT_END ) # else @@ -346,16 +385,6 @@ register struct op *Perl_op asm(stringify(OP_IN_REGISTER)); #define WITH_THX(s) STMT_START { dTHX; s; } STMT_END #define WITH_THR(s) WITH_THX(s) -/* - * SOFT_CAST can be used for args to prototyped functions to retain some - * type checking; it only casts if the compiler does not know prototypes. - */ -#if defined(CAN_PROTOTYPE) && defined(DEBUGGING_COMPILE) -#define SOFT_CAST(type) -#else -#define SOFT_CAST(type) (type) -#endif - #ifndef BYTEORDER /* Should never happen -- byteorder is in config.h */ # define BYTEORDER 0x1234 #endif @@ -384,11 +413,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 @@ -406,7 +435,7 @@ register struct op *Perl_op asm(stringify(OP_IN_REGISTER)); #define TAINT_NOT (PL_tainted = FALSE) #define TAINT_IF(c) if (c) { PL_tainted = TRUE; } #define TAINT_ENV() if (PL_tainting) { taint_env(); } -#define TAINT_PROPER(s) if (PL_tainting) { taint_proper(Nullch, s); } +#define TAINT_PROPER(s) if (PL_tainting) { taint_proper(NULL, s); } /* XXX All process group stuff is handled in pp_sys.c. Should these defines move there? If so, I could simplify this a lot. --AD 9/96. @@ -546,7 +575,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 @@ -803,11 +832,31 @@ int usleep(unsigned int); #endif /* PERL_CORE */ +/* We no longer default to creating a new SV for GvSV. + Do this before embed. */ +#ifndef PERL_CREATE_GVSV +# ifndef PERL_DONT_CREATE_GVSV +# define PERL_DONT_CREATE_GVSV +# endif +#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 */ #if !defined(PERL_FOR_X2P) && !(defined(WIN32)||defined(VMS)) # include "embed.h" +# ifndef PERL_MAD +# undef op_getmad +# define op_getmad(arg,pegop,slot) NOOP +# endif #endif #define MEM_SIZE Size_t @@ -826,7 +875,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 @@ -1125,7 +1174,8 @@ int sockatmark(int); #endif #define ERRSV GvSV(PL_errgv) -#define DEFSV GvSV(PL_defgv) +/* FIXME? Change the assignments to PL_defgv to instantiate GvSV? */ +#define DEFSV GvSVn(PL_defgv) #define SAVE_DEFSV SAVESPTR(GvSV(PL_defgv)) #define ERRHV GvHV(PL_errgv) /* XXX unused, here for compatibility */ @@ -1389,6 +1439,55 @@ 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 + +/* + * If we have v?snprintf() and the C99 variadic macros, we can just + * use just the v?snprintf(). It is nice to try to trap the buffer + * overflow, however, so if we are DEBUGGING, and we cannot use the + * gcc brace groups, then use the function wrappers which try to trap + * the overflow. If we can use the gcc brace groups, we can try that + * even with the version that uses the C99 variadic macros. + */ + +/* Note that we do not check against snprintf()/vsnprintf() returning + * negative values because that is non-standard behaviour and we use + * snprintf/vsnprintf only iff HAS_VSNPRINTF has been defined, and + * that should be true only if the snprintf()/vsnprintf() are true + * to the standard. */ + +#if defined(HAS_SNPRINTF) && defined(HAS_C99_VARIADIC_MACROS) && !(defined(DEBUGGING) && !defined(PERL_USE_GCC_BRACE_GROUPS)) +# ifdef PERL_USE_GCC_BRACE_GROUPS +# define my_snprintf(buffer, len, ...) ({ int __len__ = snprintf(buffer, len, __VA_ARGS__); if ((len) > 0 && __len__ >= (len)) Perl_croak(aTHX_ "panic: snprintf buffer overflow"); __len__; }) +# define PERL_MY_SNPRINTF_GUARDED +# else +# define my_snprintf(buffer, len, ...) snprintf(buffer, len, __VA_ARGS__) +# endif +#else +# define my_snprintf Perl_my_snprintf +# define PERL_MY_SNPRINTF_GUARDED +#endif + +#if defined(HAS_VSNPRINTF) && defined(HAS_C99_VARIADIC_MACROS) && !(defined(DEBUGGING) && !defined(PERL_USE_GCC_BRACE_GROUPS)) +# ifdef PERL_USE_GCC_BRACE_GROUPS +# define my_vsnprintf(buffer, len, ...) ({ int __len__ = vsnprintf(buffer, len, __VA_ARGS__); if ((len) > 0 && __len__ >= (len)) Perl_croak(aTHX_ "panic: vsnprintf buffer overflow"); __len__; }) +# define PERL_MY_VSNPRINTF_GUARDED +# else +# define my_vsnprintf(buffer, len, ...) vsnprintf(buffer, len, __VA_ARGS__) +# endif +#else +# define my_vsnprintf Perl_my_vsnprintf +# define PERL_MY_VSNPRINTF_GUARDED +#endif + /* Configure gets this right but the UTS compiler gets it wrong. -- Hal Morris */ #ifdef UTS @@ -1489,20 +1588,25 @@ typedef UVTYPE UV; #else # if PTRSIZE == LONGSIZE # define PTRV unsigned long +# define PTR2ul(p) (unsigned long)(p) # else # define PTRV unsigned # endif +#endif + +#ifndef INT2PTR # define INT2PTR(any,d) (any)(PTRV)(d) #endif + +#ifndef PTR2ul +# define PTR2ul(p) INT2PTR(unsigned long,p) +#endif + #define NUM2PTR(any,d) (any)(PTRV)(d) #define PTR2IV(p) INT2PTR(IV,p) #define PTR2UV(p) INT2PTR(UV,p) #define PTR2NV(p) NUM2PTR(NV,p) -#if PTRSIZE == LONGSIZE -# define PTR2ul(p) (unsigned long)(p) -#else -# define PTR2ul(p) INT2PTR(unsigned long,p) -#endif +#define PTR2nat(p) (PTRV)(p) /* pointer to integer of PTRSIZE */ /* According to strict ANSI C89 one cannot freely cast between * data pointers and function (code) pointers. There are at least @@ -1514,8 +1618,8 @@ typedef UVTYPE UV; * The only feasible use is probably temporarily storing * function pointers in a data pointer (such as a void pointer). */ -#define DPTR2FPTR(t,p) ((t)PTR2UV(p)) /* data pointer to function pointer */ -#define FPTR2DPTR(t,p) ((t)PTR2UV(p)) /* function pointer to data pointer */ +#define DPTR2FPTR(t,p) ((t)PTR2nat(p)) /* data pointer to function pointer */ +#define FPTR2DPTR(t,p) ((t)PTR2nat(p)) /* function pointer to data pointer */ #ifdef USE_LONG_DOUBLE # if defined(HAS_LONG_DOUBLE) && LONG_DOUBLESIZE == DOUBLESIZE @@ -2097,6 +2201,11 @@ struct RExC_state_t; typedef MEM_SIZE STRLEN; +#ifdef PERL_MAD +typedef struct token TOKEN; +typedef struct madprop MADPROP; +typedef struct nexttoken NEXTTOKE; +#endif typedef struct op OP; typedef struct cop COP; typedef struct unop UNOP; @@ -2272,6 +2381,10 @@ typedef struct clone_params CLONE_PARAMS; #if defined(VMS) # include "vmsish.h" # include "embed.h" +# ifndef PERL_MAD +# undef op_getmad +# define op_getmad(arg,pegop,slot) NOOP +# endif # define ISHISH "vms" #endif @@ -2299,9 +2412,13 @@ typedef struct clone_params CLONE_PARAMS; # define ISHISH "epoc" #endif -#ifdef SYMBIAN +#ifdef __SYMBIAN32__ # include "symbian/symbianish.h" # include "embed.h" +# ifndef PERL_MAD +# undef op_getmad +# define op_getmad(arg,pegop,slot) NOOP +# endif # define ISHISH "symbian" #endif @@ -2323,6 +2440,64 @@ typedef struct clone_params CLONE_PARAMS; # define ISHISH "unix" #endif +/* NSIG logic from Configure --> */ +/* Strange style to avoid deeply-nested #if/#else/#endif */ +#ifndef NSIG +# ifdef _NSIG +# define NSIG (_NSIG) +# endif +#endif + +#ifndef NSIG +# ifdef SIGMAX +# define NSIG (SIGMAX+1) +# endif +#endif + +#ifndef NSIG +# ifdef SIG_MAX +# define NSIG (SIG_MAX+1) +# endif +#endif + +#ifndef NSIG +# ifdef _SIG_MAX +# define NSIG (_SIG_MAX+1) +# endif +#endif + +#ifndef NSIG +# ifdef MAXSIG +# define NSIG (MAXSIG+1) +# endif +#endif + +#ifndef NSIG +# ifdef MAX_SIG +# define NSIG (MAX_SIG+1) +# endif +#endif + +#ifndef NSIG +# ifdef SIGARRAYSIZE +# define NSIG SIGARRAYSIZE /* Assume ary[SIGARRAYSIZE] */ +# endif +#endif + +#ifndef NSIG +# ifdef _sys_nsig +# define NSIG (_sys_nsig) /* Solaris 2.5 */ +# endif +#endif + +/* Default to some arbitrary number that's big enough to get most + of the common signals. +*/ +#ifndef NSIG +# define NSIG 50 +#endif +/* <-- NSIG logic from Configure */ + #ifndef NO_ENVIRON_ARRAY # define USE_ENVIRON_ARRAY #endif @@ -2338,7 +2513,7 @@ typedef struct clone_params CLONE_PARAMS; # define PERL_FPU_INIT fpsetmask(0); # else # if defined(SIGFPE) && defined(SIG_IGN) && !defined(PERL_MICRO) -# define PERL_FPU_INIT PL_sigfpe_saved = signal(SIGFPE, SIG_IGN); +# define PERL_FPU_INIT PL_sigfpe_saved = (Sighandler_t) signal(SIGFPE, SIG_IGN); # define PERL_FPU_PRE_EXEC { Sigsave_t xfpe; rsignal_save(SIGFPE, PL_sigfpe_saved, &xfpe); # define PERL_FPU_POST_EXEC rsignal_restore(SIGFPE, &xfpe); } # else @@ -2385,6 +2560,41 @@ typedef struct clone_params CLONE_PARAMS; # endif #endif +/* In case Configure was not used (we are using a "canned config" + * such as Win32, or a cross-compilation setup, for example) try going + * by the gcc major and minor versions. One useful URL is + * http://www.ohse.de/uwe/articles/gcc-attributes.html, + * but contrary to this information warn_unused_result seems + * not to be in gcc 3.3.5, at least. --jhi + * Set these up now otherwise we get confused when some of the <*thread.h> + * includes below indirectly pull in (which needs to know if we + * have HASATTRIBUTE_FORMAT). + */ + +#if defined __GNUC__ && !defined(__INTEL_COMPILER) +# if __GNUC__ >= 3 /* 3.0 -> */ /* XXX Verify this version */ +# define HASATTRIBUTE_FORMAT +# endif +# if __GNUC__ >= 3 /* 3.0 -> */ +# define HASATTRIBUTE_MALLOC +# endif +# if __GNUC__ == 3 && __GNUC_MINOR__ >= 3 || __GNUC__ > 3 /* 3.3 -> */ +# define HASATTRIBUTE_NONNULL +# endif +# if __GNUC__ == 2 && __GNUC_MINOR__ >= 5 || __GNUC__ > 2 /* 2.5 -> */ +# define HASATTRIBUTE_NORETURN +# endif +# if __GNUC__ >= 3 /* gcc 3.0 -> */ +# define HASATTRIBUTE_PURE +# endif +# if __GNUC__ >= 3 /* gcc 3.0 -> */ /* XXX Verify this version */ +# define HASATTRIBUTE_UNUSED +# endif +# if __GNUC__ == 3 && __GNUC_MINOR__ >= 4 || __GNUC__ > 3 /* 3.4 -> */ +# define HASATTRIBUTE_WARN_UNUSED_RESULT +# endif +#endif + /* USE_5005THREADS needs to be after unixish.h as includes * which defines NSIG - which will stop inclusion of * this results in many functions being undeclared which bothers C++ @@ -2439,41 +2649,188 @@ typedef pthread_key_t perl_key; #define STATUS_UNIX PL_statusvalue #ifdef VMS # define STATUS_NATIVE PL_statusvalue_vms -# define STATUS_NATIVE_EXPORT \ - (((I32)PL_statusvalue_vms == -1 ? 44 : PL_statusvalue_vms) | (VMSISH_HUSHED ? 0x10000000 : 0)) -# define STATUS_NATIVE_SET(n) \ +/* + * vaxc$errno is only guaranteed to be valid if errno == EVMSERR, otherwise + * 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. + */ +# include +# include +/* Presume this because if VMS changes it, it will require a new + * set of APIs for waiting on children for binary compatibility. + */ +# define child_offset_bits (8) +# ifndef C_FAC_POSIX +# define C_FAC_POSIX 0x35A000 +# endif + +/* STATUS_EXIT - validates and returns a NATIVE exit status code for the + * platform from the existing UNIX or Native status values. + */ + +# define STATUS_EXIT \ + (((I32)PL_statusvalue_vms == -1 ? SS$_ABORT : PL_statusvalue_vms) | \ + (VMSISH_HUSHED ? STS$M_INHIB_MSG : 0)) + + +/* 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. + */ + +/* 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. + */ + +# define STATUS_NATIVE_CHILD_SET(n) \ STMT_START { \ - PL_statusvalue_vms = (n); \ - if ((I32)PL_statusvalue_vms == -1) \ + I32 evalue = (I32)n; \ + if (evalue == EVMSERR) { \ + PL_statusvalue_vms = vaxc$errno; \ + PL_statusvalue = evalue; \ + } else { \ + PL_statusvalue_vms = evalue; \ + if (evalue == -1) { \ PL_statusvalue = -1; \ - else if (PL_statusvalue_vms & STS$M_SUCCESS) \ - PL_statusvalue = 0; \ - else if ((PL_statusvalue_vms & STS$M_SEVERITY) == 0) \ - PL_statusvalue = 1 << 8; \ - else \ - PL_statusvalue = (PL_statusvalue_vms & STS$M_SEVERITY) << 8; \ + PL_statusvalue_vms = SS$_ABORT; /* Should not happen */ \ + } else \ + PL_statusvalue = Perl_vms_status_to_unix(evalue, 1); \ + set_vaxc_errno(evalue); \ + 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 + # ifdef VMSISH_STATUS # define STATUS_CURRENT (VMSISH_STATUS ? STATUS_NATIVE : STATUS_UNIX) # else # define STATUS_CURRENT STATUS_UNIX # endif + + /* STATUS_UNIX_SET - takes a UNIX/POSIX errno value and attempts to update + * the NATIVE status to an equivalent value. Can not be used to translate + * exit code values as exit code values are not guaranteed to have any + * relationship at all to errno values. + * This is used when Perl is forcing errno to have a specific value. + */ # define STATUS_UNIX_SET(n) \ STMT_START { \ - PL_statusvalue = (n); \ + I32 evalue = (I32)n; \ + PL_statusvalue = evalue; \ if (PL_statusvalue != -1) { \ - PL_statusvalue &= 0xFFFF; \ - PL_statusvalue_vms = PL_statusvalue ? 44 : 1; \ + 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 = -1; \ + else PL_statusvalue_vms = SS$_ABORT; \ + set_vaxc_errno(PL_statusvalue_vms); \ } STMT_END -# define STATUS_ALL_SUCCESS (PL_statusvalue = 0, PL_statusvalue_vms = 1) -# define STATUS_ALL_FAILURE (PL_statusvalue = 1, PL_statusvalue_vms = 44) + + /* 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, 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) \ + STMT_START { \ + I32 evalue = (I32)n; \ + PL_statusvalue = evalue; \ + 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 -# define STATUS_NATIVE_EXPORT STATUS_NATIVE # if defined(WCOREDUMP) -# define STATUS_NATIVE_SET(n) \ +# define STATUS_NATIVE_CHILD_SET(n) \ STMT_START { \ PL_statusvalue_posix = (n); \ if (PL_statusvalue_posix == -1) \ @@ -2486,7 +2843,7 @@ typedef pthread_key_t perl_key; } \ } STMT_END # elif defined(WIFEXITED) -# define STATUS_NATIVE_SET(n) \ +# define STATUS_NATIVE_CHILD_SET(n) \ STMT_START { \ PL_statusvalue_posix = (n); \ if (PL_statusvalue_posix == -1) \ @@ -2498,7 +2855,7 @@ typedef pthread_key_t perl_key; } \ } STMT_END # else -# define STATUS_NATIVE_SET(n) \ +# define STATUS_NATIVE_CHILD_SET(n) \ STMT_START { \ PL_statusvalue_posix = (n); \ if (PL_statusvalue_posix == -1) \ @@ -2512,11 +2869,13 @@ typedef pthread_key_t perl_key; # define STATUS_UNIX_SET(n) \ STMT_START { \ PL_statusvalue = (n); \ - PL_statusvalue_posix = PL_statusvalue; \ if (PL_statusvalue != -1) \ 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) # define STATUS_ALL_FAILURE (PL_statusvalue = 1, PL_statusvalue_posix = 1) #endif @@ -2572,71 +2931,58 @@ typedef pthread_key_t perl_key; # define PERL_SET_THX(t) PERL_SET_CONTEXT(t) #endif -/* This replaces the previous %_ "hack" by the "%-p" hack +/* + This replaces the previous %_ "hack" by the "%p" hacks. All that is required is that the perl source does not - use "%-p" or "%-p" format. These format will - still work in perl code. RMB 2005/05/17 + use "%-p" or "%-p" or "%p" formats. + These formats will still work in perl code. + See comments in sv.c for futher details. + + -DvdNUMBER= can be used to redefine VDf + + -DvdNUMBER=0 reverts VDf to "vd", as in perl5.8.7, + which works properly but gives compiler warnings + + Robin Barker 2005-07-14 */ -#ifndef SVf -# define SVf "-p" + +#ifndef SVf_ +# define SVf_(n) "-" STRINGIFY(n) "p" #endif -#ifndef SVf_precision -# define SVf_precision(n) "-" n "p" +#ifndef SVf +# define SVf "-p" #endif #ifndef SVf32 -# define SVf32 SVf_precision("32") +# define SVf32 SVf_(32) #endif #ifndef SVf256 -# define SVf256 SVf_precision("256") -#endif - -#ifndef UVf -# define UVf UVuf +# define SVf256 SVf_(256) #endif -#ifndef DieNull -# define DieNull Perl_vdie(aTHX_ Nullch, Null(va_list *)) +#ifndef vdNUMBER +# define vdNUMBER 1 #endif - -/* In case Configure was not used (we are using a "canned config" - * such as Win32, or a cross-compilation setup, for example) try going - * by the gcc major and minor versions. One useful URL is - * http://www.ohse.de/uwe/articles/gcc-attributes.html, - * but contrary to this information warn_unused_result seems - * not to be in gcc 3.3.5, at least. --jhi */ -#if defined __GNUC__ -# if __GNUC__ >= 3 /* 3.0 -> */ /* XXX Verify this version */ -# define HASATTRIBUTE_FORMAT -# endif -# if __GNUC__ >= 3 /* 3.0 -> */ -# define HASATTRIBUTE_MALLOC -# endif -# if __GNUC__ == 3 && __GNUC_MINOR__ >= 3 || __GNUC__ > 3 /* 3.3 -> */ -# define HASATTRIBUTE_NONNULL -# endif -# if __GNUC__ == 2 && __GNUC_MINOR__ >= 5 || __GNUC__ > 2 /* 2.5 -> */ -# define HASATTRIBUTE_NORETURN -# endif -# if __GNUC__ >= 3 /* gcc 3.0 -> */ -# define HASATTRIBUTE_PURE -# endif -# if __GNUC__ >= 3 /* gcc 3.0 -> */ /* XXX Verify this version */ -# define HASATTRIBUTE_UNUSED -# endif -# if __GNUC__ == 3 && __GNUC_MINOR__ >= 4 || __GNUC__ > 3 /* 3.4 -> */ -# define HASATTRIBUTE_WARN_UNUSED_RESULT + +#ifndef VDf +# if vdNUMBER +# define VDf STRINGIFY(vdNUMBER) "p" +# else +# define VDf "vd" # endif #endif - + +#ifndef UVf +# define UVf UVuf +#endif #ifdef HASATTRIBUTE_FORMAT # define __attribute__format__(x,y,z) __attribute__((format(x,y,z))) #endif #ifdef HASATTRIBUTE_MALLOC -# define __attribute__malloc__ __attribute__((malloc)) +# define __attribute__malloc__ __attribute__((__malloc__)) #endif #ifdef HASATTRIBUTE_NONNULL # define __attribute__nonnull__(a) __attribute__((nonnull(a))) @@ -2681,9 +3027,20 @@ typedef pthread_key_t perl_key; appropriate to call return. In either case, include the lint directive. */ #ifdef HASATTRIBUTE_NORETURN -# define NORETURN_FUNCTION_END /* NOT REACHED */ +# define NORETURN_FUNCTION_END /* NOTREACHED */ #else -# define NORETURN_FUNCTION_END /* NOT REACHED */ return 0 +# define NORETURN_FUNCTION_END /* NOTREACHED */ return 0 +#endif + +#ifdef HAS_BUILTIN_EXPECT +# define EXPECT(expr,val) __builtin_expect(expr,val) +#else +# define EXPECT(expr,val) (expr) +#endif +#define LIKELY(cond) EXPECT(cond,1) +#define UNLIKELY(cond) EXPECT(cond,0) +#ifdef HAS_BUILTIN_CHOOSE_EXPR +/* placeholder */ #endif /* Some unistd.h's give a prototype for pause() even though @@ -2698,11 +3055,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; except when we're not [perl #38223] */ +# define IOCPARM_LEN(x) (_IOC_SIZE(x) < 256 ? 256 : _IOC_SIZE(x)) +# else /* otherwise guess at what's safe */ -# define IOCPARM_LEN(x) 256 +# define IOCPARM_LEN(x) 256 +# endif # endif #endif @@ -2773,6 +3135,23 @@ typedef struct crypt_data { /* straight from /usr/include/crypt.h */ # define USE_HASH_SEED #endif +/* Win32 defines a type 'WORD' in windef.h. This conflicts with the enumerator + * 'WORD' defined in perly.h. The yytokentype enum is only a debugging aid, so + * it's not really needed. + */ +#if defined(WIN32) +# define YYTOKENTYPE +#endif +#include "perly.h" + +#ifdef PERL_MAD +struct nexttoken { + YYSTYPE next_val; /* value of next token, if any */ + I32 next_type; /* type of next token */ + MADPROP *next_mad; /* everything else about that token */ +}; +#endif + #include "regexp.h" #include "sv.h" #include "util.h" @@ -2782,27 +3161,14 @@ typedef struct crypt_data { /* straight from /usr/include/crypt.h */ #include "cv.h" #include "opnames.h" #include "op.h" +#include "hv.h" #include "cop.h" #include "av.h" -#include "hv.h" #include "mg.h" #include "scope.h" #include "warnings.h" #include "utf8.h" -/* Current curly descriptor */ -typedef struct curcur CURCUR; -struct curcur { - int parenfloor; /* how far back to strip paren data */ - int cur; /* how many instances of scan we've matched */ - int min; /* the minimal number of scans to match */ - int max; /* the maximal number of scans to match */ - int minmod; /* whether to work our way up or down */ - regnode * scan; /* the thing to match */ - regnode * next; /* what has to match after it */ - char * lastloc; /* where we started matching this scan */ - CURCUR * oldcc; /* current curly before we started this one */ -}; typedef struct _sublex_info SUBLEXINFO; struct _sublex_info { @@ -2818,11 +3184,12 @@ typedef struct magic_state MGS; /* struct magic_state defined in mg.c */ struct scan_data_t; /* Used in S_* functions in regcomp.c */ struct regnode_charclass_class; /* Used in S_* functions in regcomp.c */ -typedef I32 CHECKPOINT; - +/* Keep next first in this structure, because sv_free_arenas take + advantage of this to share code between the pte arenas and the SV + body arenas */ struct ptr_tbl_ent { struct ptr_tbl_ent* next; - void* oldval; + const void* oldval; void* newval; }; @@ -3158,7 +3525,7 @@ Gid_t getegid (void); #define DEBUG_SCOPE(where) \ DEBUG_l(WITH_THR(Perl_deb(aTHX_ "%s scope %ld at %s:%d\n", \ - where, PL_scopestack_ix, __FILE__, __LINE__))); + where, (long)PL_scopestack_ix, __FILE__, __LINE__))); @@ -3183,6 +3550,8 @@ Gid_t getegid (void); #define PERL_MAGIC_envelem 'e' /* %ENV hash element */ #define PERL_MAGIC_fm 'f' /* Formline ('compiled' format) */ #define PERL_MAGIC_regex_global 'g' /* m//g target / study()ed string */ +#define PERL_MAGIC_hints 'H' /* %^H hash */ +#define PERL_MAGIC_hintselem 'h' /* %^H hash element */ #define PERL_MAGIC_isa 'I' /* @ISA array */ #define PERL_MAGIC_isaelem 'i' /* @ISA array element */ #define PERL_MAGIC_nkeys 'k' /* scalar(keys()) lvalue */ @@ -3207,7 +3576,6 @@ Gid_t getegid (void); #define PERL_MAGIC_substr 'x' /* substr() lvalue */ #define PERL_MAGIC_defelem 'y' /* Shadow "foreach" iterator variable / smart parameter vivification */ -#define PERL_MAGIC_glob '*' /* GV (typeglob) */ #define PERL_MAGIC_arylen '#' /* Array length ($#ary) */ #define PERL_MAGIC_pos '.' /* pos() lvalue */ #define PERL_MAGIC_backref '<' /* for weak ref data */ @@ -3220,9 +3588,8 @@ 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))) #endif @@ -3370,9 +3737,11 @@ char *getlogin (void); #endif #endif /* !__cplusplus */ +/* Fixme on VMS. This needs to be a run-time, not build time options */ +/* Also rename() is affected by this */ #ifdef UNLINK_ALL_VERSIONS /* Currently only makes sense for VMS */ #define UNLINK unlnk -I32 unlnk (char*); +I32 unlnk (pTHX_ const char*); #else #define UNLINK PerlLIO_unlink #endif @@ -3442,6 +3811,34 @@ typedef Sighandler_t Sigsave_t; # define MALLOC_TERM #endif +#if defined(PERL_IMPLICIT_CONTEXT) + +struct perl_memory_debug_header; +struct perl_memory_debug_header { + tTHX interpreter; +# ifdef PERL_POISON + MEM_SIZE size; +# endif + struct perl_memory_debug_header *prev; + struct perl_memory_debug_header *next; +}; + +# define sTHX (sizeof(struct perl_memory_debug_header) + \ + (MEM_ALIGNBYTES - sizeof(struct perl_memory_debug_header) \ + %MEM_ALIGNBYTES) % MEM_ALIGNBYTES) + +#endif + +#ifdef PERL_TRACK_MEMPOOL +# define INIT_TRACK_MEMPOOL(header, interp) \ + STMT_START { \ + (header).interpreter = (interp); \ + (header).prev = (header).next = &(header); \ + } STMT_END +# else +# define INIT_TRACK_MEMPOOL(header, interp) +#endif + typedef int (CPERLscope(*runops_proc_t)) (pTHX); typedef void (CPERLscope(*share_proc_t)) (pTHX_ SV *sv); @@ -3512,13 +3909,11 @@ EXTCONST char PL_no_dir_func[] EXTCONST char PL_no_func[] INIT("The %s function is unimplemented"); EXTCONST char PL_no_myglob[] - INIT("\"my\" variable %s can't be in a package"); + INIT("\"%s\" 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[\\]^_"); @@ -3736,6 +4131,9 @@ EXTCONST char* const PL_block_type[] = { "LOOP", "SUBST", "BLOCK", + "FORMAT", + "GIVEN", + "WHEN" }; #else EXTCONST char* PL_block_type[]; @@ -3759,15 +4157,6 @@ END_EXTERN_C #endif #endif -/* Win32 defines a type 'WORD' in windef.h. This conflicts with the enumerator - * 'WORD' defined in perly.h. The yytokentype enum is only a debugging aid, so - * it's not really needed. - */ -#if defined(WIN32) -# define YYTOKENTYPE -#endif -#include "perly.h" - #define LEX_NOTPARSING 11 /* borrowed from toke.c */ typedef enum { @@ -3815,17 +4204,19 @@ enum { /* pass one of these to get_vtbl */ want_vtbl_backref, want_vtbl_utf8, want_vtbl_symtab, - want_vtbl_arylen_p + want_vtbl_arylen_p, + want_vtbl_hintselem }; - /* Note: the lowest 8 bits are reserved for - stuffing into op->op_private */ -#define HINT_PRIVATE_MASK 0x000000ff + +/* Hints are now stored in a dedicated U32, so the bottom 8 bits are no longer + special and there is no need for HINT_PRIVATE_MASK for COPs + However, bitops store HINT_INTEGER in their op_private. */ #define HINT_INTEGER 0x00000001 /* integer pragma */ #define HINT_STRICT_REFS 0x00000002 /* strict pragma */ #define HINT_LOCALE 0x00000004 /* locale pragma */ #define HINT_BYTES 0x00000008 /* bytes pragma */ -/* #define HINT_notused10 0x00000010 */ +#define HINT_ARYBASE 0x00000010 /* $[ is non-zero */ /* Note: 20,40,80 used for NATIVE_HINTS */ /* currently defined by vms/vmsish.h */ @@ -3840,6 +4231,7 @@ enum { /* pass one of these to get_vtbl */ #define HINT_NEW_STRING 0x00008000 #define HINT_NEW_RE 0x00010000 #define HINT_LOCALIZE_HH 0x00020000 /* %^H needs to be copied */ +#define HINT_LEXICAL_IO 0x00040000 /* ${^OPEN} is set */ #define HINT_RE_TAINT 0x00100000 /* re pragma */ #define HINT_RE_EVAL 0x00200000 /* re pragma */ @@ -3851,7 +4243,7 @@ enum { /* pass one of these to get_vtbl */ #define HINT_ASSERTING 0x01000000 #define HINT_ASSERTIONSSEEN 0x02000000 -/* The following are stored in $sort::hints, not in PL_hints */ +/* The following are stored in $^H{sort}, not in PL_hints */ #define HINT_SORT_SORT_BITS 0x000000FF /* allow 256 different ones */ #define HINT_SORT_QUICKSORT 0x00000001 #define HINT_SORT_MERGESORT 0x00000002 @@ -4000,6 +4392,12 @@ struct tempsym; /* defined in pp_pack.c */ #if !defined(PERL_FOR_X2P) # include "embedvar.h" #endif +#ifndef PERL_MAD +# undef PL_madskills +# undef PL_xmlfp +# define PL_madskills 0 +# define PL_xmlfp 0 +#endif /* Now include all the 'global' variables * If we don't have threads or multiple interpreters @@ -4022,6 +4420,10 @@ END_EXTERN_C #if defined(WIN32) /* Now all the config stuff is setup we can include embed.h */ # include "embed.h" +# ifndef PERL_MAD +# undef op_getmad +# define op_getmad(arg,pegop,slot) NOOP +# endif #endif #ifndef PERL_GLOBAL_STRUCT @@ -4040,9 +4442,13 @@ END_EXTERN_C START_EXTERN_C #ifdef DOINIT -# define MGVTBL_SET(var,a,b,c,d,e,f,g) EXTCONST MGVTBL var = {a,b,c,d,e,f,g} +# define MGVTBL_SET(var,a,b,c,d,e,f,g,h) EXT MGVTBL var = {a,b,c,d,e,f,g,h} +/* Like MGVTBL_SET but with the get magic having a const MG* */ +# define MGVTBL_SET_CONST_MAGIC_GET(var,a,b,c,d,e,f,g,h) EXT MGVTBL var \ + = {(int (*)(pTHX_ SV *, MAGIC *))a,b,c,d,e,f,g,h} #else -# define MGVTBL_SET(var,a,b,c,d,e,f,g) EXTCONST MGVTBL var +# define MGVTBL_SET(var,a,b,c,d,e,f,g,h) EXT MGVTBL var +# define MGVTBL_SET_CONST_MAGIC_GET(var,a,b,c,d,e,f,g,h) EXT MGVTBL var #endif MGVTBL_SET( @@ -4053,6 +4459,7 @@ MGVTBL_SET( NULL, NULL, NULL, + NULL, NULL ); @@ -4064,6 +4471,7 @@ MGVTBL_SET( MEMBER_TO_FPTR(Perl_magic_clear_all_env), NULL, NULL, + NULL, NULL ); @@ -4075,9 +4483,11 @@ MGVTBL_SET( MEMBER_TO_FPTR(Perl_magic_clearenv), NULL, NULL, + NULL, NULL ); +/* For now, hints magic will also use vtbl_sig, because it is all NULL */ MGVTBL_SET( PL_vtbl_sig, NULL, @@ -4086,13 +4496,21 @@ MGVTBL_SET( NULL, NULL, NULL, + NULL, NULL ); #ifdef PERL_MICRO MGVTBL_SET( PL_vtbl_sigelem, - NULL, NULL, NULL, NULL, NULL, NULL, NULL + NULL, + NULL, + NULL, + NULL, + NULL, + NULL, + NULL, + NULL ); #else @@ -4104,6 +4522,7 @@ MGVTBL_SET( MEMBER_TO_FPTR(Perl_magic_clearsig), NULL, NULL, + NULL, NULL ); #endif @@ -4116,6 +4535,7 @@ MGVTBL_SET( MEMBER_TO_FPTR(Perl_magic_wipepack), NULL, NULL, + NULL, NULL ); @@ -4127,6 +4547,7 @@ MGVTBL_SET( MEMBER_TO_FPTR(Perl_magic_clearpack), NULL, NULL, + NULL, NULL ); @@ -4138,6 +4559,7 @@ MGVTBL_SET( NULL, NULL, NULL, + NULL, NULL ); @@ -4149,6 +4571,7 @@ MGVTBL_SET( MEMBER_TO_FPTR(Perl_magic_setisa), NULL, NULL, + NULL, NULL ); @@ -4160,10 +4583,11 @@ MGVTBL_SET( NULL, NULL, NULL, + NULL, NULL ); -MGVTBL_SET( +MGVTBL_SET_CONST_MAGIC_GET( PL_vtbl_arylen, MEMBER_TO_FPTR(Perl_magic_getarylen), MEMBER_TO_FPTR(Perl_magic_setarylen), @@ -4171,6 +4595,7 @@ MGVTBL_SET( NULL, NULL, NULL, + NULL, NULL ); @@ -4182,16 +4607,6 @@ MGVTBL_SET( NULL, MEMBER_TO_FPTR(Perl_magic_freearylen_p), NULL, - NULL -); - -MGVTBL_SET( - PL_vtbl_glob, - MEMBER_TO_FPTR(Perl_magic_getglob), - MEMBER_TO_FPTR(Perl_magic_setglob), - NULL, - NULL, - NULL, NULL, NULL ); @@ -4204,6 +4619,7 @@ MGVTBL_SET( NULL, NULL, NULL, + NULL, NULL ); @@ -4215,6 +4631,7 @@ MGVTBL_SET( NULL, NULL, NULL, + NULL, NULL ); @@ -4226,6 +4643,7 @@ MGVTBL_SET( NULL, NULL, NULL, + NULL, NULL ); @@ -4237,6 +4655,7 @@ MGVTBL_SET( NULL, NULL, NULL, + NULL, NULL ); @@ -4248,6 +4667,7 @@ MGVTBL_SET( NULL, NULL, NULL, + NULL, NULL ); @@ -4259,6 +4679,7 @@ MGVTBL_SET( NULL, NULL, NULL, + NULL, NULL ); @@ -4270,6 +4691,7 @@ MGVTBL_SET( NULL, NULL, NULL, + NULL, NULL ); @@ -4281,6 +4703,7 @@ MGVTBL_SET( NULL, NULL, NULL, + NULL, NULL ); @@ -4292,6 +4715,7 @@ MGVTBL_SET( NULL, NULL, NULL, + NULL, NULL ); @@ -4303,6 +4727,7 @@ MGVTBL_SET( NULL, NULL, NULL, + NULL, NULL ); @@ -4314,6 +4739,7 @@ MGVTBL_SET( NULL, MEMBER_TO_FPTR(Perl_magic_freeregexp), NULL, + NULL, NULL ); @@ -4325,6 +4751,7 @@ MGVTBL_SET( NULL, NULL, NULL, + NULL, NULL ); @@ -4336,6 +4763,7 @@ MGVTBL_SET( NULL, NULL, NULL, + NULL, NULL ); @@ -4347,6 +4775,7 @@ MGVTBL_SET( NULL, MEMBER_TO_FPTR(Perl_magic_setamagic), NULL, + NULL, NULL ); @@ -4358,6 +4787,7 @@ MGVTBL_SET( NULL, MEMBER_TO_FPTR(Perl_magic_setamagic), NULL, + NULL, NULL ); @@ -4369,6 +4799,7 @@ MGVTBL_SET( NULL, MEMBER_TO_FPTR(Perl_magic_killbackrefs), NULL, + NULL, NULL ); @@ -4380,6 +4811,7 @@ MGVTBL_SET( NULL, MEMBER_TO_FPTR(Perl_magic_freeovrld), NULL, + NULL, NULL ); @@ -4391,6 +4823,7 @@ MGVTBL_SET( NULL, NULL, NULL, + NULL, NULL ); #ifdef USE_LOCALE_COLLATE @@ -4402,10 +4835,23 @@ MGVTBL_SET( NULL, NULL, NULL, + NULL, NULL ); #endif +MGVTBL_SET( + PL_vtbl_hintselem, + NULL, + MEMBER_TO_FPTR(Perl_magic_sethint), + NULL, + MEMBER_TO_FPTR(Perl_magic_clearhint), + NULL, + NULL, + NULL, + NULL +); + enum { fallback_amg, abs_amg, @@ -4440,7 +4886,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. */ }; @@ -4487,7 +4936,8 @@ EXTCONST char * const PL_AMG_names[NofAMmeth] = { "(${}", "(@{}", "(%{}", "(*{}", "(&{}", "(<>", - "(int", "DESTROY", + "(int", "(~~", + "DESTROY" }; #else EXTCONST char * PL_AMG_names[NofAMmeth]; @@ -4594,7 +5044,7 @@ typedef struct am_table_short AMTS; #define SET_NUMERIC_LOCAL() \ set_numeric_local(); -#define IN_LOCALE_RUNTIME (PL_curcop->op_private & HINT_LOCALE) +#define IN_LOCALE_RUNTIME (CopHINTS_get(PL_curcop) & HINT_LOCALE) #define IN_LOCALE_COMPILETIME (PL_hints & HINT_LOCALE) #define IN_LOCALE \ @@ -4684,7 +5134,7 @@ typedef struct am_table_short AMTS; # define Strtoul(s, e, b) strchr((s), '-') ? ULONG_MAX : (unsigned long)strtol((s), (e), (b)) #endif #ifndef Atoul -# define Atoul(s) Strtoul(s, (char **)NULL, 10) +# define Atoul(s) Strtoul(s, NULL, 10) #endif @@ -4744,26 +5194,6 @@ typedef struct am_table_short AMTS; #define PERL_ALLOC_CHECK(p) NOOP #endif -/* - * nice_chunk and nice_chunk size need to be set - * and queried under the protection of sv_mutex - */ -#define offer_nice_chunk(chunk, chunk_size) STMT_START { \ - void *new_chunk; \ - U32 new_chunk_size; \ - LOCK_SV_MUTEX; \ - new_chunk = (void *)(chunk); \ - new_chunk_size = (chunk_size); \ - if (new_chunk_size > PL_nice_chunk_size) { \ - if (PL_nice_chunk) Safefree(PL_nice_chunk); \ - PL_nice_chunk = (char *) new_chunk; \ - PL_nice_chunk_size = new_chunk_size; \ - } else { \ - Safefree(chunk); \ - } \ - UNLOCK_SV_MUTEX; \ - } STMT_END - #ifdef HAS_SEM # include # include @@ -4805,6 +5235,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. @@ -4821,35 +5252,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 */ @@ -4864,7 +5290,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 @@ -4880,7 +5306,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 @@ -5069,6 +5495,7 @@ extern void moncontrol(int); #define PERL_UNICODE_ARGV_FLAG 0x0020 #define PERL_UNICODE_LOCALE_FLAG 0x0040 #define PERL_UNICODE_WIDESYSCALLS_FLAG 0x0080 /* for Sarathy */ +#define PERL_UNICODE_UTF8CACHEASSERT_FLAG 0x0100 #define PERL_UNICODE_STD_FLAG \ (PERL_UNICODE_STDIN_FLAG | \ @@ -5084,7 +5511,7 @@ extern void moncontrol(int); PERL_UNICODE_INOUT_FLAG | \ PERL_UNICODE_LOCALE_FLAG) -#define PERL_UNICODE_ALL_FLAGS 0x00ff +#define PERL_UNICODE_ALL_FLAGS 0x01ff #define PERL_UNICODE_STDIN 'I' #define PERL_UNICODE_STDOUT 'O' @@ -5096,6 +5523,7 @@ extern void moncontrol(int); #define PERL_UNICODE_ARGV 'A' #define PERL_UNICODE_LOCALE 'L' #define PERL_UNICODE_WIDESYSCALLS 'W' +#define PERL_UNICODE_UTF8CACHEASSERT 'a' #define PERL_SIGNALS_UNSAFE_FLAG 0x0001 @@ -5137,6 +5565,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"