X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/d8fca4022b56f335fb492e336b5d155376eb1bf7..5233ad255ae7fe1debb56a6b67e408e699ea4fe0:/perl.h diff --git a/perl.h b/perl.h index 65b3a72..ccf89ad 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, 2006, 2007, by Larry Wall and others + * Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001 + * 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 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. @@ -28,7 +28,7 @@ #ifdef VOIDUSED # undef VOIDUSED -#endif +#endif #define VOIDUSED 1 #ifdef PERL_MICRO @@ -41,24 +41,6 @@ # endif #endif -/* This logic needs to come after reading config.h, but before including - proto.h */ -#ifdef IAMSUID -# ifndef DOSUID -# define DOSUID -# endif -#endif - -#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW -# ifdef DOSUID -# undef DOSUID -# endif -# ifdef IAMSUID -# undef IAMSUID -# define SETUID_SCRIPTS_ARE_SECURE_NOW_AND_IAMSUID -# endif -#endif - /* See L for detailed notes on * PERL_IMPLICIT_CONTEXT and PERL_IMPLICIT_SYS */ @@ -145,10 +127,35 @@ # endif #endif +#undef START_EXTERN_C +#undef END_EXTERN_C +#undef EXTERN_C +#ifdef __cplusplus +# define START_EXTERN_C extern "C" { +# define END_EXTERN_C } +# define EXTERN_C extern "C" +#else +# define START_EXTERN_C +# define END_EXTERN_C +# define EXTERN_C extern +#endif + +/* Fallback definitions in case we don't have definitions from config.h. + This should only matter for systems that don't use Configure and + haven't been modified to define PERL_STATIC_INLINE yet. +*/ +#if !defined(PERL_STATIC_INLINE) +# ifdef HAS_STATIC_INLINE +# define PERL_STATIC_INLINE static inline +# else +# define PERL_STATIC_INLINE static +# endif +#endif + #ifdef PERL_GLOBAL_STRUCT # ifndef PERL_GET_VARS # ifdef PERL_GLOBAL_STRUCT_PRIVATE - extern struct perl_vars* Perl_GetVarsPrivate(); + EXTERN_C struct perl_vars* Perl_GetVarsPrivate(); # define PERL_GET_VARS() Perl_GetVarsPrivate() /* see miniperlmain.c */ # ifndef PERLIO_FUNCS_CONST # define PERLIO_FUNCS_CONST /* Can't have these lying around. */ @@ -203,6 +210,13 @@ #endif #define STATIC static + +#ifndef PERL_CORE +/* Do not use these macros. They were part of PERL_OBJECT, which was an + * implementation of multiplicity using C++ objects. They have been left + * here solely for the sake of XS code which has incorrectly + * cargo-culted them. + */ #define CPERLscope(x) x #define CPERLarg void #define CPERLarg_ @@ -211,77 +225,77 @@ #define _PERL_OBJECT_THIS #define PERL_OBJECT_THIS_ #define CALL_FPTR(fptr) (*fptr) +#endif /* !PERL_CORE */ -#define CALLRUNOPS CALL_FPTR(PL_runops) +#define CALLRUNOPS PL_runops #define CALLREGCOMP(sv, flags) Perl_pregcomp(aTHX_ (sv),(flags)) -#define CALLREGCOMP_ENG(prog, sv, flags) \ - CALL_FPTR(((prog)->comp))(aTHX_ sv, flags) +#define CALLREGCOMP_ENG(prog, sv, flags) (prog)->comp(aTHX_ sv, flags) #define CALLREGEXEC(prog,stringarg,strend,strbeg,minend,screamer,data,flags) \ - CALL_FPTR(RX_ENGINE(prog)->exec)(aTHX_ (prog),(stringarg),(strend), \ + RX_ENGINE(prog)->exec(aTHX_ (prog),(stringarg),(strend), \ (strbeg),(minend),(screamer),(data),(flags)) #define CALLREG_INTUIT_START(prog,sv,strpos,strend,flags,data) \ - CALL_FPTR(RX_ENGINE(prog)->intuit)(aTHX_ (prog), (sv), (strpos), \ + RX_ENGINE(prog)->intuit(aTHX_ (prog), (sv), (strpos), \ (strend),(flags),(data)) #define CALLREG_INTUIT_STRING(prog) \ - CALL_FPTR(RX_ENGINE(prog)->checkstr)(aTHX_ (prog)) + RX_ENGINE(prog)->checkstr(aTHX_ (prog)) #define CALLREGFREE(prog) \ Perl_pregfree(aTHX_ (prog)) #define CALLREGFREE_PVT(prog) \ - if(prog) CALL_FPTR(RX_ENGINE(prog)->free)(aTHX_ (prog)) + if(prog) RX_ENGINE(prog)->free(aTHX_ (prog)) #define CALLREG_NUMBUF_FETCH(rx,paren,usesv) \ - CALL_FPTR(RX_ENGINE(rx)->numbered_buff_FETCH)(aTHX_ (rx),(paren),(usesv)) + RX_ENGINE(rx)->numbered_buff_FETCH(aTHX_ (rx),(paren),(usesv)) #define CALLREG_NUMBUF_STORE(rx,paren,value) \ - CALL_FPTR(RX_ENGINE(rx)->numbered_buff_STORE)(aTHX_ (rx),(paren),(value)) + RX_ENGINE(rx)->numbered_buff_STORE(aTHX_ (rx),(paren),(value)) #define CALLREG_NUMBUF_LENGTH(rx,sv,paren) \ - CALL_FPTR(RX_ENGINE(rx)->numbered_buff_LENGTH)(aTHX_ (rx),(sv),(paren)) + RX_ENGINE(rx)->numbered_buff_LENGTH(aTHX_ (rx),(sv),(paren)) #define CALLREG_NAMED_BUFF_FETCH(rx, key, flags) \ - CALL_FPTR(RX_ENGINE(rx)->named_buff)(aTHX_ (rx), (key), NULL, ((flags) | RXapif_FETCH)) + RX_ENGINE(rx)->named_buff(aTHX_ (rx), (key), NULL, ((flags) | RXapif_FETCH)) #define CALLREG_NAMED_BUFF_STORE(rx, key, value, flags) \ - CALL_FPTR(RX_ENGINE(rx)->named_buff)(aTHX_ (rx), (key), (value), ((flags) | RXapif_STORE)) + RX_ENGINE(rx)->named_buff(aTHX_ (rx), (key), (value), ((flags) | RXapif_STORE)) #define CALLREG_NAMED_BUFF_DELETE(rx, key, flags) \ - CALL_FPTR(RX_ENGINE(rx)->named_buff)(aTHX_ (rx),(key), NULL, ((flags) | RXapif_DELETE)) + RX_ENGINE(rx)->named_buff(aTHX_ (rx),(key), NULL, ((flags) | RXapif_DELETE)) #define CALLREG_NAMED_BUFF_CLEAR(rx, flags) \ - CALL_FPTR(RX_ENGINE(rx)->named_buff)(aTHX_ (rx), NULL, NULL, ((flags) | RXapif_CLEAR)) + RX_ENGINE(rx)->named_buff(aTHX_ (rx), NULL, NULL, ((flags) | RXapif_CLEAR)) #define CALLREG_NAMED_BUFF_EXISTS(rx, key, flags) \ - CALL_FPTR(RX_ENGINE(rx)->named_buff)(aTHX_ (rx), (key), NULL, ((flags) | RXapif_EXISTS)) + RX_ENGINE(rx)->named_buff(aTHX_ (rx), (key), NULL, ((flags) | RXapif_EXISTS)) #define CALLREG_NAMED_BUFF_FIRSTKEY(rx, flags) \ - CALL_FPTR(RX_ENGINE(rx)->named_buff_iter)(aTHX_ (rx), NULL, ((flags) | RXapif_FIRSTKEY)) + RX_ENGINE(rx)->named_buff_iter(aTHX_ (rx), NULL, ((flags) | RXapif_FIRSTKEY)) #define CALLREG_NAMED_BUFF_NEXTKEY(rx, lastkey, flags) \ - CALL_FPTR(RX_ENGINE(rx)->named_buff_iter)(aTHX_ (rx), (lastkey), ((flags) | RXapif_NEXTKEY)) + RX_ENGINE(rx)->named_buff_iter(aTHX_ (rx), (lastkey), ((flags) | RXapif_NEXTKEY)) #define CALLREG_NAMED_BUFF_SCALAR(rx, flags) \ - CALL_FPTR(RX_ENGINE(rx)->named_buff)(aTHX_ (rx), NULL, NULL, ((flags) | RXapif_SCALAR)) + RX_ENGINE(rx)->named_buff(aTHX_ (rx), NULL, NULL, ((flags) | RXapif_SCALAR)) #define CALLREG_NAMED_BUFF_COUNT(rx) \ - CALL_FPTR(RX_ENGINE(rx)->named_buff)(aTHX_ (rx), NULL, NULL, RXapif_REGNAMES_COUNT) + RX_ENGINE(rx)->named_buff(aTHX_ (rx), NULL, NULL, RXapif_REGNAMES_COUNT) #define CALLREG_NAMED_BUFF_ALL(rx, flags) \ - CALL_FPTR(RX_ENGINE(rx)->named_buff)(aTHX_ (rx), NULL, NULL, flags) + RX_ENGINE(rx)->named_buff(aTHX_ (rx), NULL, NULL, flags) #define CALLREG_PACKAGE(rx) \ - CALL_FPTR(RX_ENGINE(rx)->qr_package)(aTHX_ (rx)) + RX_ENGINE(rx)->qr_package(aTHX_ (rx)) -#if defined(USE_ITHREADS) +#if defined(USE_ITHREADS) #define CALLREGDUPE(prog,param) \ Perl_re_dup(aTHX_ (prog),(param)) #define CALLREGDUPE_PVT(prog,param) \ - (prog ? CALL_FPTR(RX_ENGINE(prog)->dupe)(aTHX_ (prog),(param)) \ - : (REGEXP *)NULL) + (prog ? RX_ENGINE(prog)->dupe(aTHX_ (prog),(param)) \ + : (REGEXP *)NULL) #endif @@ -315,7 +329,7 @@ # define PERL_UNUSED_DECL # endif #endif - + /* gcc -Wall: * 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 @@ -405,19 +419,6 @@ # endif #endif -#undef START_EXTERN_C -#undef END_EXTERN_C -#undef EXTERN_C -#ifdef __cplusplus -# define START_EXTERN_C extern "C" { -# define END_EXTERN_C } -# define EXTERN_C extern "C" -#else -# define START_EXTERN_C -# define END_EXTERN_C -# define EXTERN_C extern -#endif - /* Some platforms require marking function declarations * for them to be exportable. Used in perlio.h, proto.h * is handled either by the makedef.pl or by defining the @@ -677,6 +678,11 @@ register struct op *Perl_op asm(stringify(OP_IN_REGISTER)); # include #endif +/* for WCOREDUMP */ +#ifdef I_SYS_WAIT +# include +#endif + #ifdef __SYMBIAN32__ # undef _SC_ARG_MAX /* Symbian has _SC_ARG_MAX but no sysconf() */ #endif @@ -956,11 +962,11 @@ EXTERN_C int usleep(unsigned int); #define PERL_USES_PL_PIDSTATUS #endif -#if !defined(OS2) && !defined(WIN32) && !defined(DJGPP) && !defined(EPOC) && !defined(__SYMBIAN32__) && !defined(MACOS_TRADITIONAL) +#if !defined(OS2) && !defined(WIN32) && !defined(DJGPP) && !defined(EPOC) && !defined(__SYMBIAN32__) #define PERL_DEFAULT_DO_EXEC3_IMPLEMENTATION #endif -/* Cannot include embed.h here on Win32 as win32.h has not +/* 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)) @@ -980,6 +986,14 @@ EXTERN_C int usleep(unsigned int); #define PERL_STRLEN_ROUNDUP_QUANTUM Size_t_size #endif +/* sv_grow() will expand strings by at least a certain percentage of + the previously *used* length to avoid excessive calls to realloc(). + The default is 25% of the current length. +*/ +#ifndef PERL_STRLEN_EXPAND_SHIFT +# define PERL_STRLEN_EXPAND_SHIFT 2 +#endif + #if defined(STANDARD_C) && defined(I_STDDEF) # include # define STRUCT_OFFSET(s,m) offsetof(s,m) @@ -1040,6 +1054,7 @@ EXTERN_C int usleep(unsigned int); # define MALLOC_CHECK_TAINT(argc,argv,env) #endif /* MYMALLOC */ +/* diag_listed_as: "-T" is on the #! line, it must also be used on the command line */ #define TOO_LATE_FOR_(ch,what) Perl_croak(aTHX_ "\"-%c\" is on the #! line, it must also be used on the command line%s", (char)(ch), what) #define TOO_LATE_FOR(ch) TOO_LATE_FOR_(ch, "") #define MALLOC_TOO_LATE_FOR(ch) TOO_LATE_FOR_(ch, " with $ENV{PERL_MALLOC_OPT}") @@ -1156,6 +1171,13 @@ EXTERN_C int usleep(unsigned int); # include #endif +/* Microsoft VC's sys/stat.h defines all S_Ixxx macros except S_IFIFO. + This definition should ideally go into win32/win32.h, but S_IFIFO is + used later here in perl.h before win32/win32.h is being included. */ +#if !defined(S_IFIFO) && defined(_S_IFIFO) +# define S_IFIFO _S_IFIFO +#endif + /* The stat macros for Amdahl UTS, Unisoft System V/88 (and derivatives like UTekV) are broken, sometimes giving false positives. Undefine them here and let the code below set them to proper values. @@ -1203,7 +1225,7 @@ EXTERN_C int usleep(unsigned int); #endif /* In Tru64 use the 4.4BSD struct msghdr, not the 4.3 one. - * This is important for using IPv6. + * This is important for using IPv6. * For OSF/1 3.2, however, defining _SOCKADDR_LEN would be * a bad idea since it breaks send() and recv(). */ #if defined(__osf__) && defined(__alpha) && !defined(_SOCKADDR_LEN) && !defined(DEC_OSF1_3_X) @@ -1277,6 +1299,11 @@ EXTERN_C char *crypt(const char *, const char *); set_errno(errcode); \ set_vaxc_errno(vmserrcode); \ } STMT_END +# define dSAVEDERRNO int saved_errno; unsigned saved_vms_errno +# define dSAVE_ERRNO int saved_errno = errno; unsigned saved_vms_errno = vaxc$errno +# define SAVE_ERRNO ( saved_errno = errno, saved_vms_errno = vaxc$errno ) +# define RESTORE_ERRNO SETERRNO(saved_errno, saved_vms_errno) + # define LIB_INVARG LIB$_INVARG # define RMS_DIR RMS$_DIR # define RMS_FAC RMS$_FAC @@ -1291,6 +1318,11 @@ EXTERN_C char *crypt(const char *, const char *); # define SS_NORMAL SS$_NORMAL #else # define SETERRNO(errcode,vmserrcode) (errno = (errcode)) +# define dSAVEDERRNO int saved_errno +# define dSAVE_ERRNO int saved_errno = errno +# define SAVE_ERRNO (saved_errno = errno) +# define RESTORE_ERRNO (errno = saved_errno) + # define LIB_INVARG 0 # define RMS_DIR 0 # define RMS_FAC 0 @@ -1305,9 +1337,31 @@ EXTERN_C char *crypt(const char *, const char *); # define SS_NORMAL 0 #endif -#define ERRSV GvSV(PL_errgv) -/* FIXME? Change the assignments to PL_defgv to instantiate GvSV? */ -#define DEFSV GvSVn(PL_defgv) +#define ERRSV GvSVn(PL_errgv) + +#define CLEAR_ERRSV() STMT_START { \ + if (!GvSV(PL_errgv)) { \ + sv_setpvs(GvSV(gv_add_by_type(PL_errgv, SVt_PV)), ""); \ + } else if (SvREADONLY(GvSV(PL_errgv))) { \ + SvREFCNT_dec(GvSV(PL_errgv)); \ + GvSV(PL_errgv) = newSVpvs(""); \ + } else { \ + SV *const errsv = GvSV(PL_errgv); \ + sv_setpvs(errsv, ""); \ + if (SvMAGICAL(errsv)) { \ + mg_free(errsv); \ + } \ + SvPOK_only(errsv); \ + } \ + } STMT_END + + +#ifdef PERL_CORE +# define DEFSV (0 + GvSVn(PL_defgv)) +#else +# define DEFSV GvSVn(PL_defgv) +#endif +#define DEFSV_set(sv) (GvSV(PL_defgv) = (sv)) #define SAVE_DEFSV SAVESPTR(GvSV(PL_defgv)) #define ERRHV GvHV(PL_errgv) /* XXX unused, here for compatibility */ @@ -1539,15 +1593,15 @@ EXTERN_C char *crypt(const char *, const char *); # define S_IRWXO (S_IROTH|S_IWOTH|S_IXOTH) #endif -/* BeOS 5.0 seems to define S_IREAD and S_IWRITE in +/* BeOS 5.0 and Haiku R1 seem to define S_IREAD and S_IWRITE in * which would get included through , but that is 3000 * lines in the future. --jhi */ -#if !defined(S_IREAD) && !defined(__BEOS__) +#if !defined(S_IREAD) && !(defined(__BEOS__) || defined(__HAIKU__)) # define S_IREAD S_IRUSR #endif -#if !defined(S_IWRITE) && !defined(__BEOS__) +#if !defined(S_IWRITE) && !(defined(__BEOS__) || defined(__HAIKU__)) # define S_IWRITE S_IWUSR #endif @@ -2358,6 +2412,8 @@ typedef struct padop PADOP; typedef struct pvop PVOP; typedef struct loop LOOP; +typedef struct block_hooks BHK; + typedef struct interpreter PerlInterpreter; /* Amdahl's has struct sv */ @@ -2501,7 +2557,7 @@ typedef struct clone_params CLONE_PARAMS; # endif #endif -#if defined(OS2) || defined(MACOS_TRADITIONAL) +#if defined(OS2) # include "iperlsys.h" #endif @@ -2563,15 +2619,11 @@ typedef struct clone_params CLONE_PARAMS; # define ISHISH "symbian" #endif -#if defined(MACOS_TRADITIONAL) -# include "macos/macish.h" -# ifndef NO_ENVIRON_ARRAY -# define NO_ENVIRON_ARRAY -# endif -# define ISHISH "macos classic" -#endif -#if defined(__BEOS__) +#if defined(__HAIKU__) +# include "haiku/haikuish.h" +# define ISHISH "haiku" +#elif defined(__BEOS__) # include "beos/beosish.h" # define ISHISH "beos" #endif @@ -2651,7 +2703,11 @@ typedef struct clone_params CLONE_PARAMS; # if HAS_FLOATINGPOINT_H # include # endif -# define PERL_FPU_INIT fpsetmask(0) +/* Some operating systems have this as a macro, which in turn expands to a comma + expression, and the last sub-expression is something that gets calculated, + and then they have the gall to warn that a value computed is not used. Hence + cast to void. */ +# define PERL_FPU_INIT (void)fpsetmask(0) # else # if defined(SIGFPE) && defined(SIG_IGN) && !defined(PERL_MICRO) # define PERL_FPU_INIT PL_sigfpe_saved = (Sighandler_t) signal(SIGFPE, SIG_IGN) @@ -2672,6 +2728,25 @@ typedef struct clone_params CLONE_PARAMS; # define PERL_SYS_INIT3_BODY(argvp,argcp,envp) PERL_SYS_INIT_BODY(argvp,argcp) #endif +/* +=for apidoc Am|void|PERL_SYS_INIT|int argc|char** argv +Provides system-specific tune up of the C runtime environment necessary to +run Perl interpreters. This should be called only once, before creating +any Perl interpreters. + +=for apidoc Am|void|PERL_SYS_INIT3|int argc|char** argv|char** env +Provides system-specific tune up of the C runtime environment necessary to +run Perl interpreters. This should be called only once, before creating +any Perl interpreters. + +=for apidoc Am|void|PERL_SYS_TERM| +Provides system-specific clean up of the C runtime environment after +running Perl interpreters. This should be called only once, after +freeing any remaining Perl interpreters. + +=cut + */ + #define PERL_SYS_INIT(argc, argv) Perl_sys_init(argc, argv) #define PERL_SYS_INIT3(argc, argv, env) Perl_sys_init3(argc, argv, env) #define PERL_SYS_TERM() Perl_sys_term() @@ -2721,6 +2796,9 @@ typedef struct clone_params CLONE_PARAMS; #ifndef PERL_MICRO #if defined __GNUC__ && !defined(__INTEL_COMPILER) +# if __GNUC__ == 3 && __GNUC_MINOR__ >= 1 || __GNUC__ > 3 /* 3.1 -> */ +# define HASATTRIBUTE_DEPRECATED +# endif # if __GNUC__ >= 3 /* 3.0 -> */ /* XXX Verify this version */ # define HASATTRIBUTE_FORMAT # if defined __MINGW32__ @@ -2749,7 +2827,7 @@ typedef struct clone_params CLONE_PARAMS; # define HASATTRIBUTE_WARN_UNUSED_RESULT # endif #endif -#endif /* #ifndef PERL_MICRO */ +#endif /* #ifndef PERL_MICRO */ /* USE_5005THREADS needs to be after unixish.h as includes * which defines NSIG - which will stop inclusion of @@ -2840,7 +2918,7 @@ typedef pthread_key_t perl_key; /* 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. + 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 @@ -2904,11 +2982,11 @@ typedef pthread_key_t perl_key; } 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, 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. + * the NATIVE error status based on it. + * + * When in the default mode to comply with the Perl VMS documentation, + * 0 is a success and 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 @@ -2922,30 +3000,31 @@ typedef pthread_key_t perl_key; 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); \ + if (MY_POSIX_EXIT) { \ + if (evalue <= 0xFF00) { \ + if (evalue > 0xFF) \ + evalue = (evalue >> child_offset_bits) & 0xFF; \ + PL_statusvalue_vms = \ + (C_FAC_POSIX | (evalue << 3 ) | \ + ((evalue == 1) ? (STS$K_ERROR | STS$M_INHIB_MSG) : 1)); \ + } else /* forgive them Perl, for they have sinned */ \ + PL_statusvalue_vms = evalue; \ + } else { \ + if (evalue == 0) \ + PL_statusvalue_vms = SS$_NORMAL; \ + else if (evalue <= 0xFF00) \ + 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; \ + } \ + 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. @@ -2958,6 +3037,9 @@ typedef pthread_key_t perl_key; * actual exit code will can be retrieved by the calling program or * shell. * + * A POSIX exit code is from 0 to 255. If the exit code is higher + * than this, it needs to be assumed that it is a VMS exit code and + * passed through. */ # define STATUS_EXIT_SET(n) \ @@ -2965,9 +3047,10 @@ typedef pthread_key_t perl_key; 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); \ + if (evalue > 255) PL_statusvalue_vms = evalue; else { \ + 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); \ @@ -3044,10 +3127,18 @@ typedef pthread_key_t perl_key; # define MEMBER_TO_FPTR(name) name #endif +#ifndef PERL_CORE /* format to use for version numbers in file/directory names */ /* XXX move to Configure? */ -#ifndef PERL_FS_VER_FMT -# define PERL_FS_VER_FMT "%d.%d.%d" +/* This was only ever used for the current version, and that can be done at + compile time, as PERL_FS_VERSION, so should we just delete it? */ +# ifndef PERL_FS_VER_FMT +# define PERL_FS_VER_FMT "%d.%d.%d" +# endif +#endif + +#ifndef PERL_FS_VERSION +# define PERL_FS_VERSION PERL_VERSION_STRING #endif /* This defines a way to flush all output buffers. This may be a @@ -3087,16 +3178,16 @@ typedef pthread_key_t perl_key; # define PERL_SET_THX(t) PERL_SET_CONTEXT(t) #endif -/* +/* This replaces the previous %_ "hack" by the "%p" hacks. All that is required is that the perl source does not - use "%-p" or "%-p" or "%p" formats. - These formats will still work in perl code. + use "%-p" or "%-p" or "%p" formats. + These formats will still work in perl code. See comments in sv.c for futher details. Robin Barker 2005-07-14 - No longer use %1p for VDf = %vd. RMB 2007-10-19 + No longer use %1p for VDf = %vd. RMB 2007-10-19 */ #ifndef SVf_ @@ -3118,7 +3209,7 @@ typedef pthread_key_t perl_key; #define SVfARG(p) ((void*)(p)) #ifdef PERL_CORE -/* not used; but needed for backward compatibilty with XS code? - RMB */ +/* not used; but needed for backward compatibilty with XS code? - RMB */ # undef VDf #else # ifndef VDf @@ -3127,7 +3218,7 @@ typedef pthread_key_t perl_key; #endif #ifdef PERL_CORE -/* not used; but needed for backward compatibilty with XS code? - RMB */ +/* not used; but needed for backward compatibilty with XS code? - RMB */ # undef UVf #else # ifndef UVf @@ -3135,6 +3226,9 @@ typedef pthread_key_t perl_key; # endif #endif +#ifdef HASATTRIBUTE_DEPRECATED +# define __attribute__deprecated__ __attribute__((deprecated)) +#endif #ifdef HASATTRIBUTE_FORMAT # define __attribute__format__(x,y,z) __attribute__((format(x,y,z))) #endif @@ -3158,6 +3252,9 @@ typedef pthread_key_t perl_key; #endif /* If we haven't defined the attributes yet, define them to blank. */ +#ifndef __attribute__deprecated__ +# define __attribute__deprecated__ +#endif #ifndef __attribute__format__ # define __attribute__format__(x,y,z) #endif @@ -3193,7 +3290,7 @@ typedef pthread_key_t perl_key; #ifdef PRINTF_FORMAT_NULL_OK # define __attribute__format__null_ok__(x,y,z) __attribute__format__(x,y,z) #else -# define __attribute__format__null_ok__(x,y,z) +# define __attribute__format__null_ok__(x,y,z) #endif #ifdef HAS_BUILTIN_EXPECT @@ -3256,6 +3353,7 @@ union any { void* any_ptr; I32 any_i32; IV any_iv; + UV any_uv; long any_long; bool any_bool; void (*any_dptr) (void*); @@ -3291,12 +3389,12 @@ typedef struct crypt_data { /* straight from /usr/include/crypt.h */ #endif /* threading */ #endif /* AIX */ -#if !defined(OS2) && !defined(MACOS_TRADITIONAL) +#if !defined(OS2) # include "iperlsys.h" #endif #ifdef __LIBCATAMOUNT__ -#undef HAS_PASSWD /* unixish.h but not unixish enough. */ +#undef HAS_PASSWD /* unixish.h but not unixish enough. */ #undef HAS_GROUP #define FAKE_BIT_BUCKET #endif @@ -3356,8 +3454,11 @@ struct nexttoken { #include "warnings.h" #include "utf8.h" +/* these would be in doio.h if there was such a file */ +#define my_stat() my_stat_flags(SV_GMAGIC) +#define my_lstat() my_lstat_flags(SV_GMAGIC) + /* defined in sv.c, but also used in [ach]v.c */ -#undef _XPV_ALLOCATED_HEAD #undef _XPV_HEAD #undef _XPVMG_HEAD #undef _XPVCV_COMMON @@ -3378,9 +3479,6 @@ 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 */ -/* 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; const void* oldval; @@ -3391,6 +3489,9 @@ struct ptr_tbl { struct ptr_tbl_ent** tbl_ary; UV tbl_max; UV tbl_items; + struct ptr_tbl_arena *tbl_arena; + struct ptr_tbl_ent *tbl_arena_next; + struct ptr_tbl_ent *tbl_arena_end; }; #if defined(iAPX286) || defined(M_I286) || defined(I80286) @@ -3569,7 +3670,9 @@ Gid_t getegid (void); #define DEBUG_C_FLAG 0x00200000 /*2097152 */ #define DEBUG_A_FLAG 0x00400000 /*4194304 */ #define DEBUG_q_FLAG 0x00800000 /*8388608 */ -#define DEBUG_MASK 0x00FEEFFF /* mask of all the standard flags */ +#define DEBUG_M_FLAG 0x01000000 /*16777216*/ +#define DEBUG_B_FLAG 0x02000000 /*33554432*/ +#define DEBUG_MASK 0x03FEEFFF /* mask of all the standard flags */ #define DEBUG_DB_RECURSE_FLAG 0x40000000 #define DEBUG_TOP_FLAG 0x80000000 /* XXX what's this for ??? Signal @@ -3598,6 +3701,8 @@ Gid_t getegid (void); # define DEBUG_C_TEST_ (PL_debug & DEBUG_C_FLAG) # define DEBUG_A_TEST_ (PL_debug & DEBUG_A_FLAG) # define DEBUG_q_TEST_ (PL_debug & DEBUG_q_FLAG) +# define DEBUG_M_TEST_ (PL_debug & DEBUG_M_FLAG) +# define DEBUG_B_TEST_ (PL_debug & DEBUG_B_FLAG) # define DEBUG_Xv_TEST_ (DEBUG_X_TEST_ && DEBUG_v_TEST_) # define DEBUG_Uv_TEST_ (DEBUG_U_TEST_ && DEBUG_v_TEST_) @@ -3626,6 +3731,8 @@ Gid_t getegid (void); # define DEBUG_C_TEST DEBUG_C_TEST_ # define DEBUG_A_TEST DEBUG_A_TEST_ # define DEBUG_q_TEST DEBUG_q_TEST_ +# define DEBUG_M_TEST DEBUG_M_TEST_ +# define DEBUG_B_TEST DEBUG_B_TEST_ # define DEBUG_Xv_TEST DEBUG_Xv_TEST_ # define DEBUG_Uv_TEST DEBUG_Uv_TEST_ @@ -3672,6 +3779,8 @@ Gid_t getegid (void); # define DEBUG_C(a) DEBUG__(DEBUG_C_TEST, a) # define DEBUG_A(a) DEBUG__(DEBUG_A_TEST, a) # define DEBUG_q(a) DEBUG__(DEBUG_q_TEST, a) +# define DEBUG_M(a) DEBUG__(DEBUG_M_TEST, a) +# define DEBUG_B(a) DEBUG__(DEBUG_B_TEST, a) #else /* DEBUGGING */ @@ -3698,6 +3807,8 @@ Gid_t getegid (void); # define DEBUG_C_TEST (0) # define DEBUG_A_TEST (0) # define DEBUG_q_TEST (0) +# define DEBUG_M_TEST (0) +# define DEBUG_B_TEST (0) # define DEBUG_Xv_TEST (0) # define DEBUG_Uv_TEST (0) @@ -3725,14 +3836,18 @@ Gid_t getegid (void); # define DEBUG_C(a) # define DEBUG_A(a) # define DEBUG_q(a) +# define DEBUG_M(a) +# define DEBUG_B(a) # define DEBUG_Xv(a) # define DEBUG_Uv(a) #endif /* DEBUGGING */ #define DEBUG_SCOPE(where) \ - DEBUG_l(WITH_THR(Perl_deb(aTHX_ "%s scope %ld at %s:%d\n", \ - where, (long)PL_scopestack_ix, __FILE__, __LINE__))); + DEBUG_l( \ + Perl_deb(aTHX_ "%s scope %ld (savestack=%ld) at %s:%d\n", \ + where, (long)PL_scopestack_ix, (long)PL_savestack_ix, \ + __FILE__, __LINE__)); @@ -4073,27 +4188,41 @@ struct perl_memory_debug_header { # define INIT_TRACK_MEMPOOL(header, interp) #endif +#ifdef I_MALLOCMALLOC +/* Needed for malloc_size(), malloc_good_size() on some systems */ +# include +#endif + #ifdef MYMALLOC # define Perl_safesysmalloc_size(where) Perl_malloced_size(where) #else -# ifdef HAS_MALLOC_SIZE +# ifdef HAS_MALLOC_SIZE +# ifdef PERL_TRACK_MEMPOOL # define Perl_safesysmalloc_size(where) \ (malloc_size(((char *)(where)) - sTHX) - sTHX) -# endif -# ifdef HAS_MALLOC_GOOD_SIZE +# else +# define Perl_safesysmalloc_size(where) malloc_size(where) +# endif +# endif +# ifdef HAS_MALLOC_GOOD_SIZE +# ifdef PERL_TRACK_MEMPOOL # define Perl_malloc_good_size(how_much) \ (malloc_good_size((how_much) + sTHX) - sTHX) -# else +# else +# define Perl_malloc_good_size(how_much) malloc_good_size(how_much) +# endif +# else /* Having this as the identity operation makes some code simpler. */ # define Perl_malloc_good_size(how_much) (how_much) -# endif +# endif #endif -typedef int (CPERLscope(*runops_proc_t)) (pTHX); -typedef void (CPERLscope(*share_proc_t)) (pTHX_ SV *sv); -typedef int (CPERLscope(*thrhook_proc_t)) (pTHX); -typedef OP* (CPERLscope(*PPADDR_t)[]) (pTHX); -typedef bool (CPERLscope(*destroyable_proc_t)) (pTHX_ SV *sv); +typedef int (*runops_proc_t)(pTHX); +typedef void (*share_proc_t) (pTHX_ SV *sv); +typedef int (*thrhook_proc_t) (pTHX); +typedef OP* (*PPADDR_t[]) (pTHX); +typedef bool (*destroyable_proc_t) (pTHX_ SV *sv); +typedef void (*despatch_signals_proc_t) (pTHX); /* _ (for $_) must be first in the following list (DEFSV requires it) */ #define THREADSV_NAMES "_123456789&`'+/.,\\\";^-%=|~:\001\005!@" @@ -4136,9 +4265,11 @@ EXTCONST char PL_warn_nl[] INIT("Unsuccessful %s on filename containing newline"); EXTCONST char PL_no_wrongref[] INIT("Can't use %s ref as %s ref"); -EXTCONST char PL_no_symref[] +/* The core no longer needs these here. If you require the string constant, + please inline a copy into your own code. */ +EXTCONST char PL_no_symref[] __attribute__deprecated__ INIT("Can't use string (\"%.32s\") as %s ref while \"strict refs\" in use"); -EXTCONST char PL_no_symref_sv[] +EXTCONST char PL_no_symref_sv[] __attribute__deprecated__ INIT("Can't use string (\"%" SVf32 "\") as %s ref while \"strict refs\" in use"); EXTCONST char PL_no_usym[] INIT("Can't use an undefined value as %s reference"); @@ -4178,10 +4309,14 @@ EXTCONST char PL_uuemap[65] EXTCONST char PL_uudmap[256] = #include "uudmap.h" ; +EXTCONST char PL_bitcount[256] = +# include "bitcount.h" +; EXTCONST char* const PL_sig_name[] = { SIG_NAME }; EXTCONST int PL_sig_num[] = { SIG_NUM }; #else EXTCONST char PL_uudmap[256]; +EXTCONST char PL_bitcount[256]; EXTCONST char* const PL_sig_name[]; EXTCONST int PL_sig_num[]; #endif @@ -4259,9 +4394,85 @@ EXTCONST unsigned char PL_fold[] = { 240, 241, 242, 243, 244, 245, 246, 247, 248, 249, 250, 251, 252, 253, 254, 255 }; -#endif /* !EBCDIC */ -#else +#endif /* !EBCDIC, but still in DOINIT */ + +/* If these tables are accessed through ebcdic, the access will be converted to + * latin1 first */ +EXTCONST unsigned char PL_latin1_lc[] = { /* lowercasing */ + 0, 1, 2, 3, 4, 5, 6, 7, + 8, 9, 10, 11, 12, 13, 14, 15, + 16, 17, 18, 19, 20, 21, 22, 23, + 24, 25, 26, 27, 28, 29, 30, 31, + 32, 33, 34, 35, 36, 37, 38, 39, + 40, 41, 42, 43, 44, 45, 46, 47, + 48, 49, 50, 51, 52, 53, 54, 55, + 56, 57, 58, 59, 60, 61, 62, 63, + 64, 'a', 'b', 'c', 'd', 'e', 'f', 'g', + 'h', 'i', 'j', 'k', 'l', 'm', 'n', 'o', + 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', + 'x', 'y', 'z', 91, 92, 93, 94, 95, + 96, 97, 98, 99, 100, 101, 102, 103, + 104, 105, 106, 107, 108, 109, 110, 111, + 112, 113, 114, 115, 116, 117, 118, 119, + 120, 121, 122, 123, 124, 125, 126, 127, + 128, 129, 130, 131, 132, 133, 134, 135, + 136, 137, 138, 139, 140, 141, 142, 143, + 144, 145, 146, 147, 148, 149, 150, 151, + 152, 153, 154, 155, 156, 157, 158, 159, + 160, 161, 162, 163, 164, 165, 166, 167, + 168, 169, 170, 171, 172, 173, 174, 175, + 176, 177, 178, 179, 180, 181, 182, 183, + 184, 185, 186, 187, 188, 189, 190, 191, + 192+32, 193+32, 194+32, 195+32, 196+32, 197+32, 198+32, 199+32, + 200+32, 201+32, 202+32, 203+32, 204+32, 205+32, 206+32, 207+32, + 208+32, 209+32, 210+32, 211+32, 212+32, 213+32, 214+32, 215, + 216+32, 217+32, 218+32, 219+32, 220+32, 221+32, 222+32, 223, + 224, 225, 226, 227, 228, 229, 230, 231, + 232, 233, 234, 235, 236, 237, 238, 239, + 240, 241, 242, 243, 244, 245, 246, 247, + 248, 249, 250, 251, 252, 253, 254, 255 +}; + +/* upper and title case of latin1 characters, modified so that the three tricky + * ones are mapped to 255 (which is one of the three) */ +EXTCONST unsigned char PL_mod_latin1_uc[] = { + 0, 1, 2, 3, 4, 5, 6, 7, + 8, 9, 10, 11, 12, 13, 14, 15, + 16, 17, 18, 19, 20, 21, 22, 23, + 24, 25, 26, 27, 28, 29, 30, 31, + 32, 33, 34, 35, 36, 37, 38, 39, + 40, 41, 42, 43, 44, 45, 46, 47, + 48, 49, 50, 51, 52, 53, 54, 55, + 56, 57, 58, 59, 60, 61, 62, 63, + 64, 65, 66, 67, 68, 69, 70, 71, + 72, 73, 74, 75, 76, 77, 78, 79, + 80, 81, 82, 83, 84, 85, 86, 87, + 88, 89, 90, 91, 92, 93, 94, 95, + 96, 'A', 'B', 'C', 'D', 'E', 'F', 'G', + 'H', 'I', 'J', 'K', 'L', 'M', 'N', 'O', + 'P', 'Q', 'R', 'S', 'T', 'U', 'V', 'W', + 'X', 'Y', 'Z', 123, 124, 125, 126, 127, + 128, 129, 130, 131, 132, 133, 134, 135, + 136, 137, 138, 139, 140, 141, 142, 143, + 144, 145, 146, 147, 148, 149, 150, 151, + 152, 153, 154, 155, 156, 157, 158, 159, + 160, 161, 162, 163, 164, 165, 166, 167, + 168, 169, 170, 171, 172, 173, 174, 175, + 176, 177, 178, 179, 180, 255 /*micro*/, 182, 183, + 184, 185, 186, 187, 188, 189, 190, 191, + 192, 193, 194, 195, 196, 197, 198, 199, + 200, 201, 202, 203, 204, 205, 206, 207, + 208, 209, 210, 211, 212, 213, 214, 215, + 216, 217, 218, 219, 220, 221, 222, 255 /*sharp s*/, + 224-32, 225-32, 226-32, 227-32, 228-32, 229-32, 230-32, 231-32, + 232-32, 233-32, 234-32, 235-32, 236-32, 237-32, 238-32, 239-32, + 240-32, 241-32, 242-32, 243-32, 244-32, 245-32, 246-32, 247, + 248-32, 249-32, 250-32, 251-32, 252-32, 253-32, 254-32, 255 +}; +#else /* ! DOINIT */ EXTCONST unsigned char PL_fold[]; +EXTCONST unsigned char PL_mod_latin1_uc[]; +EXTCONST unsigned char PL_latin1_lc[]; #endif #ifndef PERL_GLOBAL_STRUCT /* or perlvars.h */ @@ -4572,7 +4783,8 @@ enum { /* pass one of these to get_vtbl */ want_vtbl_utf8, want_vtbl_symtab, want_vtbl_arylen_p, - want_vtbl_hintselem + want_vtbl_hintselem, + want_vtbl_hints }; @@ -4590,6 +4802,7 @@ enum { /* pass one of these to get_vtbl */ #define HINT_BLOCK_SCOPE 0x00000100 #define HINT_STRICT_SUBS 0x00000200 /* strict pragma */ #define HINT_STRICT_VARS 0x00000400 /* strict pragma */ +#define HINT_UNI_8_BIT 0x00000800 /* unicode_strings feature */ /* The HINT_NEW_* constants are used by the overload pragma */ #define HINT_NEW_INTEGER 0x00001000 @@ -4607,6 +4820,8 @@ enum { /* pass one of these to get_vtbl */ #define HINT_FILETEST_ACCESS 0x00400000 /* filetest pragma */ #define HINT_UTF8 0x00800000 /* utf8 pragma */ +#define HINT_NO_AMAGIC 0x01000000 /* overloading pragma */ + /* 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 @@ -4633,23 +4848,23 @@ struct perl_debug_pad { PERL_DEBUG_PAD(i)) /* Enable variables which are pointers to functions */ -typedef void (CPERLscope(*peep_t))(pTHX_ OP* o); -typedef regexp*(CPERLscope(*regcomp_t)) (pTHX_ char* exp, char* xend, PMOP* pm); -typedef I32 (CPERLscope(*regexec_t)) (pTHX_ regexp* prog, char* stringarg, +typedef void (*peep_t)(pTHX_ OP* o); +typedef regexp* (*regcomp_t) (pTHX_ char* exp, char* xend, PMOP* pm); +typedef I32 (*regexec_t) (pTHX_ regexp* prog, char* stringarg, char* strend, char* strbeg, I32 minend, SV* screamer, void* data, U32 flags); -typedef char* (CPERLscope(*re_intuit_start_t)) (pTHX_ regexp *prog, SV *sv, +typedef char* (*re_intuit_start_t) (pTHX_ regexp *prog, SV *sv, char *strpos, char *strend, U32 flags, re_scream_pos_data *d); -typedef SV* (CPERLscope(*re_intuit_string_t)) (pTHX_ regexp *prog); -typedef void (CPERLscope(*regfree_t)) (pTHX_ struct regexp* r); -typedef regexp*(CPERLscope(*regdupe_t)) (pTHX_ const regexp* r, CLONE_PARAMS *param); +typedef SV* (*re_intuit_string_t) (pTHX_ regexp *prog); +typedef void (*regfree_t) (pTHX_ struct regexp* r); +typedef regexp* (*regdupe_t) (pTHX_ const regexp* r, CLONE_PARAMS *param); typedef void (*DESTRUCTORFUNC_NOCONTEXT_t) (void*); typedef void (*DESTRUCTORFUNC_t) (pTHX_ void*); typedef void (*SVFUNC_t) (pTHX_ SV* const); -typedef I32 (*SVCOMPARE_t) (pTHX_ SV*, SV*); +typedef I32 (*SVCOMPARE_t) (pTHX_ SV* const, SV* const); typedef void (*XSINIT_t) (pTHX); typedef void (*ATEXIT_t) (pTHX_ void*); typedef void (*XSUBADDR_t) (pTHX_ CV *); @@ -4661,8 +4876,14 @@ typedef void (*XSUBADDR_t) (pTHX_ CV *); #define PERLVARIC(var,type,init) type var; #define PERLVARISC(var,init) const char var[sizeof(init)]; -typedef OP* (CPERLscope(*Perl_ppaddr_t))(pTHX); -typedef OP* (CPERLscope(*Perl_check_t)) (pTHX_ OP*); +typedef OP* (*Perl_ppaddr_t)(pTHX); +typedef OP* (*Perl_check_t) (pTHX_ OP*); +typedef void(*Perl_ophook_t)(pTHX_ OP*); +typedef int (*Perl_keyword_plugin_t)(pTHX_ char*, STRLEN, OP**); + +#define KEYWORD_PLUGIN_DECLINE 0 +#define KEYWORD_PLUGIN_STMT 1 +#define KEYWORD_PLUGIN_EXPR 2 /* Interpreter exitlist entry */ typedef struct exitlistentry { @@ -4684,6 +4905,14 @@ typedef struct exitlistentry { #include "patchlevel.h" #undef PERL_PATCHLEVEL_H_IMPLICIT +#define PERL_VERSION_STRING STRINGIFY(PERL_REVISION) "." \ + STRINGIFY(PERL_VERSION) "." \ + STRINGIFY(PERL_SUBVERSION) + +#define PERL_API_VERSION_STRING STRINGIFY(PERL_API_REVISION) "." \ + STRINGIFY(PERL_API_VERSION) "." \ + STRINGIFY(PERL_API_SUBVERSION) + #ifdef PERL_GLOBAL_STRUCT struct perl_vars { # include "perlvars.h" @@ -4834,6 +5063,19 @@ START_EXTERN_C * not the same beast. ANSI doesn't allow the assignment from one to the other. * (although most, but not all, compilers are prepared to do it) */ + +/* args are: + vtable + get + set + len + clear + free + copy + dup + local +*/ + MGVTBL_SET( PL_vtbl_sv, MEMBER_TO_FPTR(Perl_magic_get), @@ -4870,7 +5112,6 @@ MGVTBL_SET( 0 ); -/* For now, hints magic will also use vtbl_sig, because it is all 0 */ MGVTBL_SET( PL_vtbl_sig, 0, @@ -5235,6 +5476,18 @@ MGVTBL_SET( 0 ); +MGVTBL_SET( + PL_vtbl_hints, + 0, + 0, + 0, + MEMBER_TO_FPTR(Perl_magic_clearhints), + 0, + 0, + 0, + 0 +); + #include "overload.h" END_EXTERN_C @@ -5303,8 +5556,9 @@ typedef struct am_table_short AMTS; #define PERLDB_ALL (PERLDBf_SUB | PERLDBf_LINE | \ PERLDBf_NOOPT | PERLDBf_INTER | \ PERLDBf_SUBLINE| PERLDBf_SINGLE| \ - PERLDBf_NAMEEVAL| PERLDBf_NAMEANON ) - /* No _NONAME, _GOTO, _ASSERTION */ + PERLDBf_NAMEEVAL| PERLDBf_NAMEANON | \ + PERLDBf_SAVESRC) + /* No _NONAME, _GOTO */ #define PERLDBf_SUB 0x01 /* Debug sub enter/exit */ #define PERLDBf_LINE 0x02 /* Keep line # */ #define PERLDBf_NOOPT 0x04 /* Switch off optimizations */ @@ -5316,6 +5570,9 @@ typedef struct am_table_short AMTS; #define PERLDBf_GOTO 0x80 /* Report goto: call DB::goto */ #define PERLDBf_NAMEEVAL 0x100 /* Informative names for evals */ #define PERLDBf_NAMEANON 0x200 /* Informative names for anon subs */ +#define PERLDBf_SAVESRC 0x400 /* Save source lines into @{"_<$filename"} */ +#define PERLDBf_SAVESRC_NOSUBS 0x800 /* Including evals that generate no subrouties */ +#define PERLDBf_SAVESRC_INVALID 0x1000 /* Save source that did not compile */ #define PERLDB_SUB (PL_perldb && (PL_perldb & PERLDBf_SUB)) #define PERLDB_LINE (PL_perldb && (PL_perldb & PERLDBf_LINE)) @@ -5327,7 +5584,9 @@ typedef struct am_table_short AMTS; #define PERLDB_GOTO (PL_perldb && (PL_perldb & PERLDBf_GOTO)) #define PERLDB_NAMEEVAL (PL_perldb && (PL_perldb & PERLDBf_NAMEEVAL)) #define PERLDB_NAMEANON (PL_perldb && (PL_perldb & PERLDBf_NAMEANON)) -#define PERLDB_ASSERTION (PL_perldb && (PL_perldb & PERLDBf_ASSERTION)) +#define PERLDB_SAVESRC (PL_perldb && (PL_perldb & PERLDBf_SAVESRC)) +#define PERLDB_SAVESRC_NOSUBS (PL_perldb && (PL_perldb & PERLDBf_SAVESRC_NOSUBS)) +#define PERLDB_SAVESRC_INVALID (PL_perldb && (PL_perldb & PERLDBf_SAVESRC_INVALID)) #ifdef USE_LOCALE_NUMERIC @@ -5469,7 +5728,7 @@ typedef struct am_table_short AMTS; #ifndef PERL_MICRO # ifndef PERL_ASYNC_CHECK -# define PERL_ASYNC_CHECK() if (PL_sig_pending) despatch_signals() +# define PERL_ASYNC_CHECK() if (PL_sig_pending) PL_signalhook(aTHX) # endif #endif @@ -5543,98 +5802,72 @@ typedef struct am_table_short AMTS; #if defined(PERL_IMPLICIT_CONTEXT) -#ifdef PERL_GLOBAL_STRUCT_PRIVATE - -/* This must appear in all extensions that define a my_cxt_t structure, +/* START_MY_CXT 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 -#define MY_CXT_INDEX Perl_my_cxt_index(aTHX_ MY_CXT_KEY) +# ifdef PERL_GLOBAL_STRUCT_PRIVATE +# define START_MY_CXT +# define MY_CXT_INDEX Perl_my_cxt_index(aTHX_ MY_CXT_KEY) +# define MY_CXT_INIT_ARG MY_CXT_KEY +# else +# define START_MY_CXT static int my_cxt_index = -1; +# define MY_CXT_INDEX my_cxt_index +# define MY_CXT_INIT_ARG &my_cxt_index +# endif /* #ifdef PERL_GLOBAL_STRUCT_PRIVATE */ /* 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 \ +# define MY_CXT_INIT \ my_cxt_t *my_cxtp = \ - (my_cxt_t*)Perl_my_cxt_init(aTHX_ MY_CXT_KEY, sizeof(my_cxt_t)) -#define MY_CXT_INIT_INTERP(my_perl) \ + (my_cxt_t*)Perl_my_cxt_init(aTHX_ MY_CXT_INIT_ARG, 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_KEY, sizeof(my_cxt_t)) + (my_cxt_t*)Perl_my_cxt_init(my_perl, MY_CXT_INIT_ARG, sizeof(my_cxt_t)) /* This declaration should be used within all functions that use the * interpreter-local data. */ -#define dMY_CXT \ +# define dMY_CXT \ my_cxt_t *my_cxtp = (my_cxt_t *)PL_my_cxt_list[MY_CXT_INDEX] -#define dMY_CXT_INTERP(my_perl) \ +# define dMY_CXT_INTERP(my_perl) \ my_cxt_t *my_cxtp = (my_cxt_t *)(my_perl)->Imy_cxt_list[MY_CXT_INDEX] /* Clones the per-interpreter data. */ -#define MY_CXT_CLONE \ +# define MY_CXT_CLONE \ my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1));\ Copy(PL_my_cxt_list[MY_CXT_INDEX], my_cxtp, 1, my_cxt_t);\ PL_my_cxt_list[MY_CXT_INDEX] = my_cxtp \ -#else /* #ifdef PERL_GLOBAL_STRUCT_PRIVATE */ - -/* 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 static int my_cxt_index = -1; - -/* This declaration should be used within all functions that use the - * interpreter-local data. */ -#define dMY_CXT \ - 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 \ - 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 \ - my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1));\ - Copy(PL_my_cxt_list[my_cxt_index], my_cxtp, 1, my_cxt_t);\ - PL_my_cxt_list[my_cxt_index] = my_cxtp \ - -#endif /* #ifdef PERL_GLOBAL_STRUCT_PRIVATE */ /* This macro must be used to access members of the my_cxt_t structure. * e.g. MYCXT.some_data */ -#define MY_CXT (*my_cxtp) +# define MY_CXT (*my_cxtp) /* Judicious use of these macros can reduce the number of times dMY_CXT * is used. Use is similar to pTHX, aTHX etc. */ -#define pMY_CXT my_cxt_t *my_cxtp -#define pMY_CXT_ pMY_CXT, -#define _pMY_CXT ,pMY_CXT -#define aMY_CXT my_cxtp -#define aMY_CXT_ aMY_CXT, -#define _aMY_CXT ,aMY_CXT +# define pMY_CXT my_cxt_t *my_cxtp +# define pMY_CXT_ pMY_CXT, +# define _pMY_CXT ,pMY_CXT +# define aMY_CXT my_cxtp +# define aMY_CXT_ aMY_CXT, +# define _aMY_CXT ,aMY_CXT #else /* PERL_IMPLICIT_CONTEXT */ -#define START_MY_CXT static my_cxt_t my_cxt; -#define dMY_CXT_SV dNOOP -#define dMY_CXT dNOOP -#define dMY_CXT_INTERP(my_perl) dNOOP -#define MY_CXT_INIT NOOP -#define MY_CXT_CLONE NOOP -#define MY_CXT my_cxt - -#define pMY_CXT void -#define pMY_CXT_ -#define _pMY_CXT -#define aMY_CXT -#define aMY_CXT_ -#define _aMY_CXT +# define START_MY_CXT static my_cxt_t my_cxt; +# define dMY_CXT_SV dNOOP +# define dMY_CXT dNOOP +# define dMY_CXT_INTERP(my_perl) dNOOP +# define MY_CXT_INIT NOOP +# define MY_CXT_CLONE NOOP +# define MY_CXT my_cxt + +# define pMY_CXT void +# define pMY_CXT_ +# define _pMY_CXT +# define aMY_CXT +# define aMY_CXT_ +# define _aMY_CXT #endif /* !defined(PERL_IMPLICIT_CONTEXT) */ @@ -5673,9 +5906,10 @@ int flock(int fd, int op); #if O_TEXT != O_BINARY /* If you have different O_TEXT and O_BINARY and you are a CLRF shop, * that is, you are somehow DOSish. */ -# if defined(__BEOS__) || defined(__VOS__) || defined(__CYGWIN__) - /* BeOS has O_TEXT != O_BINARY but O_TEXT and O_BINARY have no effect; - * BeOS is always UNIXoid (LF), not DOSish (CRLF). */ +# if defined(__BEOS__) || defined(__HAIKU__) || defined(__VOS__) || \ + defined(__CYGWIN__) + /* BeOS/Haiku has O_TEXT != O_BINARY but O_TEXT and O_BINARY have no effect; + * BeOS/Haiku is always UNIXoid (LF), not DOSish (CRLF). */ /* VOS has O_TEXT != O_BINARY, and they have effect, * but VOS always uses LF, never CRLF. */ /* If you have O_TEXT different from your O_BINARY but you still are @@ -5687,64 +5921,6 @@ int flock(int fd, int op); # endif #endif -#ifdef IAMSUID - -#ifdef I_SYS_STATVFS -# if defined(PERL_SCO) && !defined(_SVID3) -# define _SVID3 -# endif -# include /* for f?statvfs() */ -#endif -#ifdef I_SYS_MOUNT -# include /* for *BSD f?statfs() */ -#endif -#ifdef I_MNTENT -# include /* for getmntent() */ -#endif -#ifdef I_SYS_STATFS -# include /* for some statfs() */ -#endif -#ifdef I_SYS_VFS -# ifdef __sgi -# define sv IRIX_sv /* kludge: IRIX has an sv of its own */ -# endif -# include /* for some statfs() */ -# ifdef __sgi -# undef IRIX_sv -# endif -#endif -#ifdef I_USTAT -# include /* for ustat() */ -#endif - -#if !defined(PERL_MOUNT_NOSUID) && defined(MOUNT_NOSUID) -# define PERL_MOUNT_NOSUID MOUNT_NOSUID -#endif -#if !defined(PERL_MOUNT_NOSUID) && defined(MNT_NOSUID) -# define PERL_MOUNT_NOSUID MNT_NOSUID -#endif -#if !defined(PERL_MOUNT_NOSUID) && defined(MS_NOSUID) -# define PERL_MOUNT_NOSUID MS_NOSUID -#endif -#if !defined(PERL_MOUNT_NOSUID) && defined(M_NOSUID) -# define PERL_MOUNT_NOSUID M_NOSUID -#endif - -#if !defined(PERL_MOUNT_NOEXEC) && defined(MOUNT_NOEXEC) -# define PERL_MOUNT_NOEXEC MOUNT_NOEXEC -#endif -#if !defined(PERL_MOUNT_NOEXEC) && defined(MNT_NOEXEC) -# define PERL_MOUNT_NOEXEC MNT_NOEXEC -#endif -#if !defined(PERL_MOUNT_NOEXEC) && defined(MS_NOEXEC) -# define PERL_MOUNT_NOEXEC MS_NOEXEC -#endif -#if !defined(PERL_MOUNT_NOEXEC) && defined(M_NOEXEC) -# define PERL_MOUNT_NOEXEC M_NOEXEC -#endif - -#endif /* IAMSUID */ - #ifdef I_LIBUTIL # include /* setproctitle() in some FreeBSDs */ #endif @@ -5910,8 +6086,8 @@ extern void moncontrol(int); #define NO_ENV_ARRAY_IN_MAIN #endif -/* These are used by Perl_pv_escape() and Perl_pv_pretty() - * are here so that they are available throughout the core +/* These are used by Perl_pv_escape() and Perl_pv_pretty() + * are here so that they are available throughout the core * NOTE that even though some are for _escape and some for _pretty * there must not be any clashes as the flags from _pretty are * passed straight through to _escape. @@ -5925,7 +6101,7 @@ extern void moncontrol(int); #define PERL_PV_ESCAPE_FIRSTCHAR 0x0008 -#define PERL_PV_ESCAPE_UNI 0x0100 +#define PERL_PV_ESCAPE_UNI 0x0100 #define PERL_PV_ESCAPE_UNI_DETECT 0x0200 #define PERL_PV_ESCAPE_ALL 0x1000