X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=ppport.h;h=703b6bc5a483c52a35f3a140dbd87def59b6842b;hb=e7a62a4071b77329ff736a31a956c77e9b664299;hp=a55cbbc282f520d0161be311844a9dc8cd90c80b;hpb=80e617244a6a4289380d25a971b6bb80d31ab6d5;p=p5sagit%2FSub-Name.git diff --git a/ppport.h b/ppport.h index a55cbbc..703b6bc 100644 --- a/ppport.h +++ b/ppport.h @@ -4,9 +4,9 @@ /* ---------------------------------------------------------------------- - ppport.h -- Perl/Pollution/Portability Version 3.35 + ppport.h -- Perl/Pollution/Portability Version 3.39 - Automatically created by Devel::PPPort running under perl 5.025005. + Automatically created by Devel::PPPort running under perl 5.027010. Do NOT edit this file directly! -- Edit PPPort_pm.PL and the includes in parts/inc/ instead. @@ -21,7 +21,7 @@ SKIP =head1 NAME -ppport.h - Perl/Pollution/Portability version 3.35 +ppport.h - Perl/Pollution/Portability version 3.39 =head1 SYNOPSIS @@ -46,8 +46,8 @@ ppport.h - Perl/Pollution/Portability version 3.35 --nochanges don't suggest changes --nofilter don't filter input files - --strip strip all script and doc functionality from - ppport.h + --strip strip all script and doc functionality + from ppport.h --list-provided list provided API --list-unsupported list unsupported API @@ -221,6 +221,8 @@ same function or variable in your project. PL_signals NEED_PL_signals NEED_PL_signals_GLOBAL SvRX() NEED_SvRX NEED_SvRX_GLOBAL caller_cx() NEED_caller_cx NEED_caller_cx_GLOBAL + croak_xs_usage() NEED_croak_xs_usage NEED_croak_xs_usage_GLOBAL + die_sv() NEED_die_sv NEED_die_sv_GLOBAL eval_pv() NEED_eval_pv NEED_eval_pv_GLOBAL grok_bin() NEED_grok_bin NEED_grok_bin_GLOBAL grok_hex() NEED_grok_hex NEED_grok_hex_GLOBAL @@ -229,6 +231,9 @@ same function or variable in your project. grok_oct() NEED_grok_oct NEED_grok_oct_GLOBAL gv_fetchpvn_flags() NEED_gv_fetchpvn_flags NEED_gv_fetchpvn_flags_GLOBAL load_module() NEED_load_module NEED_load_module_GLOBAL + mess() NEED_mess NEED_mess_GLOBAL + mess_nocontext() NEED_mess_nocontext NEED_mess_nocontext_GLOBAL + mess_sv() NEED_mess_sv NEED_mess_sv_GLOBAL mg_findext() NEED_mg_findext NEED_mg_findext_GLOBAL my_snprintf() NEED_my_snprintf NEED_my_snprintf_GLOBAL my_sprintf() NEED_my_sprintf NEED_my_sprintf_GLOBAL @@ -251,6 +256,7 @@ same function or variable in your project. sv_setpvf_mg_nocontext() NEED_sv_setpvf_mg_nocontext NEED_sv_setpvf_mg_nocontext_GLOBAL sv_unmagicext() NEED_sv_unmagicext NEED_sv_unmagicext_GLOBAL vload_module() NEED_vload_module NEED_vload_module_GLOBAL + vmess() NEED_vmess NEED_vmess_GLOBAL vnewSVpvf() NEED_vnewSVpvf NEED_vnewSVpvf_GLOBAL warner() NEED_warner NEED_warner_GLOBAL @@ -383,7 +389,7 @@ use strict; # Disable broken TRIE-optimization BEGIN { eval '${^RE_TRIE_MAXBUF} = -1' if $] >= 5.009004 && $] <= 5.009005 } -my $VERSION = 3.35; +my $VERSION = 3.39; my %opt = ( quiet => 0, @@ -597,6 +603,7 @@ PAD_SV||| PERLIO_FUNCS_CAST|5.009003||p PERLIO_FUNCS_DECL|5.009003||p PERL_ABS|5.008001||p +PERL_ARGS_ASSERT_CROAK_XS_USAGE|||p PERL_BCDVERSION|5.024000||p PERL_GCC_BRACE_GROUPS_FORBIDDEN|5.008001||p PERL_HASH|5.003070||p @@ -1309,13 +1316,13 @@ core_prototype||| coresub_op||| cr_textfilter||| create_eval_scope||| -croak_memory_wrap||5.019003|n +croak_memory_wrap|5.019003||pn croak_no_mem|||n -croak_no_modify||5.013003|n -croak_nocontext|||vn +croak_no_modify|5.013003||pn +croak_nocontext|||pvn croak_popstack|||n -croak_sv||5.013001| -croak_xs_usage||5.010001|n +croak_sv|5.013001||p +croak_xs_usage|5.010001||pn croak|||v csighandler||5.009003|n current_re_engine||| @@ -1402,7 +1409,7 @@ deprecate_commaless_var_list||| despatch_signals||5.007001| destroy_matcher||| die_nocontext|||vn -die_sv||5.013001| +die_sv|5.013001||p die_unwind||| die|||v dirp_dup||| @@ -1669,7 +1676,6 @@ handle_regex_sets||| he_dup||| hek_dup||| hfree_next_entry||| -hfreeentries||| hsplit||| hv_assert||| hv_auxinit_internal|||n @@ -1695,6 +1701,7 @@ hv_fetchs|5.009003||p hv_fetch||| hv_fill||5.013002| hv_free_ent_ret||| +hv_free_entries||| hv_free_ent||5.004000| hv_iterinit||| hv_iterkeysv||5.003070| @@ -1983,9 +1990,9 @@ mem_log_common|||n mem_log_free|||n mem_log_realloc|||n mess_alloc||| -mess_nocontext|||vn -mess_sv||5.013001| -mess||5.006000|v +mess_nocontext|||pvn +mess_sv|5.013001||p +mess|5.006000||pv mfree||5.007002|n mg_clear||| mg_copy||| @@ -2874,7 +2881,7 @@ visit||| vivify_defelem||| vivify_ref||| vload_module|5.006000||p -vmess||5.006000| +vmess|5.006000||p vnewSVpvf|5.006000|5.004000|p vnormal||5.009002| vnumify||5.009000| @@ -2883,8 +2890,8 @@ vverify||5.009003| vwarner||5.006000| vwarn||5.006000| wait4pid||| -warn_nocontext|||vn -warn_sv||5.013001| +warn_nocontext|||pvn +warn_sv|5.013001||p warner_nocontext|||vn warner|5.006000|5.004000|pv warn|||v @@ -4201,1032 +4208,877 @@ __DATA__ #ifndef Newxz # define Newxz(v,n,t) Newz(0,v,n,t) #endif -#ifndef PERL_MAGIC_qr -# define PERL_MAGIC_qr 'r' -#endif -#ifndef cBOOL -# define cBOOL(cbool) ((cbool) ? (bool)1 : (bool)0) +#ifndef SvGETMAGIC +# define SvGETMAGIC(x) STMT_START { if (SvGMAGICAL(x)) mg_get(x); } STMT_END #endif -#ifndef OpHAS_SIBLING -# define OpHAS_SIBLING(o) (cBOOL((o)->op_sibling)) +/* Some random bits for sv_unmagicext. These should probably be pulled in for + real and organized at some point */ +#ifndef HEf_SVKEY +# define HEf_SVKEY -2 #endif -#ifndef OpSIBLING -# define OpSIBLING(o) (0 + (o)->op_sibling) +#ifndef MUTABLE_PTR +#if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN) +# define MUTABLE_PTR(p) ({ void *_p = (p); _p; }) +#else +# define MUTABLE_PTR(p) ((void *) (p)) #endif - -#ifndef OpMORESIB_set -# define OpMORESIB_set(o, sib) ((o)->op_sibling = (sib)) +#endif +#ifndef MUTABLE_SV +# define MUTABLE_SV(p) ((SV *)MUTABLE_PTR(p)) #endif -#ifndef OpLASTSIB_set -# define OpLASTSIB_set(o, parent) ((o)->op_sibling = NULL) +/* end of random bits */ +#ifndef PERL_MAGIC_sv +# define PERL_MAGIC_sv '\0' #endif -#ifndef OpMAYBESIB_set -# define OpMAYBESIB_set(o, sib, parent) ((o)->op_sibling = (sib)) +#ifndef PERL_MAGIC_overload +# define PERL_MAGIC_overload 'A' #endif -#ifndef SvRX -#if defined(NEED_SvRX) -static void * DPPP_(my_SvRX)(pTHX_ SV *rv); -static -#else -extern void * DPPP_(my_SvRX)(pTHX_ SV *rv); +#ifndef PERL_MAGIC_overload_elem +# define PERL_MAGIC_overload_elem 'a' #endif -#ifdef SvRX -# undef SvRX +#ifndef PERL_MAGIC_overload_table +# define PERL_MAGIC_overload_table 'c' #endif -#define SvRX(a) DPPP_(my_SvRX)(aTHX_ a) -#if defined(NEED_SvRX) || defined(NEED_SvRX_GLOBAL) +#ifndef PERL_MAGIC_bm +# define PERL_MAGIC_bm 'B' +#endif -void * -DPPP_(my_SvRX)(pTHX_ SV *rv) -{ - if (SvROK(rv)) { - SV *sv = SvRV(rv); - if (SvMAGICAL(sv)) { - MAGIC *mg = mg_find(sv, PERL_MAGIC_qr); - if (mg && mg->mg_obj) { - return mg->mg_obj; - } - } - } - return 0; -} +#ifndef PERL_MAGIC_regdata +# define PERL_MAGIC_regdata 'D' #endif + +#ifndef PERL_MAGIC_regdatum +# define PERL_MAGIC_regdatum 'd' #endif -#ifndef SvRXOK -# define SvRXOK(sv) (!!SvRX(sv)) + +#ifndef PERL_MAGIC_env +# define PERL_MAGIC_env 'E' #endif -#ifndef PERL_UNUSED_DECL -# ifdef HASATTRIBUTE -# if (defined(__GNUC__) && defined(__cplusplus)) || defined(__INTEL_COMPILER) -# define PERL_UNUSED_DECL -# else -# define PERL_UNUSED_DECL __attribute__((unused)) -# endif -# else -# define PERL_UNUSED_DECL -# endif +#ifndef PERL_MAGIC_envelem +# define PERL_MAGIC_envelem 'e' #endif -#ifndef PERL_UNUSED_ARG -# if defined(lint) && defined(S_SPLINT_S) /* www.splint.org */ -# include -# define PERL_UNUSED_ARG(x) NOTE(ARGUNUSED(x)) -# else -# define PERL_UNUSED_ARG(x) ((void)x) -# endif +#ifndef PERL_MAGIC_fm +# define PERL_MAGIC_fm 'f' #endif -#ifndef PERL_UNUSED_VAR -# define PERL_UNUSED_VAR(x) ((void)x) +#ifndef PERL_MAGIC_regex_global +# define PERL_MAGIC_regex_global 'g' #endif -#ifndef PERL_UNUSED_CONTEXT -# ifdef USE_ITHREADS -# define PERL_UNUSED_CONTEXT PERL_UNUSED_ARG(my_perl) -# else -# define PERL_UNUSED_CONTEXT -# endif +#ifndef PERL_MAGIC_isa +# define PERL_MAGIC_isa 'I' #endif -#ifndef PERL_UNUSED_RESULT -# if defined(__GNUC__) && defined(HASATTRIBUTE_WARN_UNUSED_RESULT) -# define PERL_UNUSED_RESULT(v) STMT_START { __typeof__(v) z = (v); (void)sizeof(z); } STMT_END -# else -# define PERL_UNUSED_RESULT(v) ((void)(v)) -# endif +#ifndef PERL_MAGIC_isaelem +# define PERL_MAGIC_isaelem 'i' #endif -#ifndef NOOP -# define NOOP /*EMPTY*/(void)0 + +#ifndef PERL_MAGIC_nkeys +# define PERL_MAGIC_nkeys 'k' #endif -#ifndef dNOOP -# define dNOOP extern int /*@unused@*/ Perl___notused PERL_UNUSED_DECL +#ifndef PERL_MAGIC_dbfile +# define PERL_MAGIC_dbfile 'L' #endif -#ifndef NVTYPE -# if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE) -# define NVTYPE long double -# else -# define NVTYPE double -# endif -typedef NVTYPE NV; +#ifndef PERL_MAGIC_dbline +# define PERL_MAGIC_dbline 'l' #endif -#ifndef INT2PTR -# if (IVSIZE == PTRSIZE) && (UVSIZE == PTRSIZE) -# define PTRV UV -# define INT2PTR(any,d) (any)(d) -# else -# if PTRSIZE == LONGSIZE -# define PTRV unsigned long -# else -# define PTRV unsigned -# endif -# define INT2PTR(any,d) (any)(PTRV)(d) -# endif +#ifndef PERL_MAGIC_mutex +# define PERL_MAGIC_mutex 'm' #endif -#ifndef PTR2ul -# if PTRSIZE == LONGSIZE -# define PTR2ul(p) (unsigned long)(p) -# else -# define PTR2ul(p) INT2PTR(unsigned long,p) -# endif +#ifndef PERL_MAGIC_shared +# define PERL_MAGIC_shared 'N' #endif -#ifndef PTR2nat -# define PTR2nat(p) (PTRV)(p) + +#ifndef PERL_MAGIC_shared_scalar +# define PERL_MAGIC_shared_scalar 'n' #endif -#ifndef NUM2PTR -# define NUM2PTR(any,d) (any)PTR2nat(d) +#ifndef PERL_MAGIC_collxfrm +# define PERL_MAGIC_collxfrm 'o' #endif -#ifndef PTR2IV -# define PTR2IV(p) INT2PTR(IV,p) +#ifndef PERL_MAGIC_tied +# define PERL_MAGIC_tied 'P' #endif -#ifndef PTR2UV -# define PTR2UV(p) INT2PTR(UV,p) +#ifndef PERL_MAGIC_tiedelem +# define PERL_MAGIC_tiedelem 'p' #endif -#ifndef PTR2NV -# define PTR2NV(p) NUM2PTR(NV,p) +#ifndef PERL_MAGIC_tiedscalar +# define PERL_MAGIC_tiedscalar 'q' #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 +#ifndef PERL_MAGIC_qr +# define PERL_MAGIC_qr 'r' #endif -#if defined(PERL_GCC_PEDANTIC) -# ifndef PERL_GCC_BRACE_GROUPS_FORBIDDEN -# define PERL_GCC_BRACE_GROUPS_FORBIDDEN -# endif +#ifndef PERL_MAGIC_sig +# define PERL_MAGIC_sig 'S' #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 +#ifndef PERL_MAGIC_sigelem +# define PERL_MAGIC_sigelem 's' #endif -#undef STMT_START -#undef STMT_END -#ifdef PERL_USE_GCC_BRACE_GROUPS -# define STMT_START (void)( /* gcc supports ``({ STATEMENTS; })'' */ -# define STMT_END ) -#else -# if defined(VOIDFLAGS) && (VOIDFLAGS) && (defined(sun) || defined(__sun__)) && !defined(__GNUC__) -# define STMT_START if (1) -# define STMT_END else (void)0 -# else -# define STMT_START do -# define STMT_END while (0) -# endif +#ifndef PERL_MAGIC_taint +# define PERL_MAGIC_taint 't' #endif -#ifndef boolSV -# define boolSV(b) ((b) ? &PL_sv_yes : &PL_sv_no) + +#ifndef PERL_MAGIC_uvar +# define PERL_MAGIC_uvar 'U' #endif -/* DEFSV appears first in 5.004_56 */ -#ifndef DEFSV -# define DEFSV GvSV(PL_defgv) +#ifndef PERL_MAGIC_uvar_elem +# define PERL_MAGIC_uvar_elem 'u' #endif -#ifndef SAVE_DEFSV -# define SAVE_DEFSV SAVESPTR(GvSV(PL_defgv)) +#ifndef PERL_MAGIC_vstring +# define PERL_MAGIC_vstring 'V' #endif -#ifndef DEFSV_set -# define DEFSV_set(sv) (DEFSV = (sv)) +#ifndef PERL_MAGIC_vec +# define PERL_MAGIC_vec 'v' #endif -/* Older perls (<=5.003) lack AvFILLp */ -#ifndef AvFILLp -# define AvFILLp AvFILL +#ifndef PERL_MAGIC_utf8 +# define PERL_MAGIC_utf8 'w' #endif -#ifndef ERRSV -# define ERRSV get_sv("@",FALSE) + +#ifndef PERL_MAGIC_substr +# define PERL_MAGIC_substr 'x' #endif -/* Hint: gv_stashpvn - * This function's backport doesn't support the length parameter, but - * rather ignores it. Portability can only be ensured if the length - * parameter is used for speed reasons, but the length can always be - * correctly computed from the string argument. - */ -#ifndef gv_stashpvn -# define gv_stashpvn(str,len,create) gv_stashpv(str,create) +#ifndef PERL_MAGIC_defelem +# define PERL_MAGIC_defelem 'y' #endif -/* Replace: 1 */ -#ifndef get_cv -# define get_cv perl_get_cv -#endif - -#ifndef get_sv -# define get_sv perl_get_sv +#ifndef PERL_MAGIC_glob +# define PERL_MAGIC_glob '*' #endif -#ifndef get_av -# define get_av perl_get_av +#ifndef PERL_MAGIC_arylen +# define PERL_MAGIC_arylen '#' #endif -#ifndef get_hv -# define get_hv perl_get_hv +#ifndef PERL_MAGIC_pos +# define PERL_MAGIC_pos '.' #endif -/* Replace: 0 */ -#ifndef dUNDERBAR -# define dUNDERBAR dNOOP +#ifndef PERL_MAGIC_backref +# define PERL_MAGIC_backref '<' #endif -#ifndef UNDERBAR -# define UNDERBAR DEFSV -#endif -#ifndef dAX -# define dAX I32 ax = MARK - PL_stack_base + 1 +#ifndef PERL_MAGIC_ext +# define PERL_MAGIC_ext '~' #endif -#ifndef dITEMS -# define dITEMS I32 items = SP - MARK -#endif -#ifndef dXSTARG -# define dXSTARG SV * targ = sv_newmortal() -#endif -#ifndef dAXMARK -# define dAXMARK I32 ax = POPMARK; \ - register SV ** const mark = PL_stack_base + ax++ -#endif -#ifndef XSprePUSH -# define XSprePUSH (sp = PL_stack_base + ax - 1) +/* That's the best we can do... */ +#ifndef sv_catpvn_nomg +# define sv_catpvn_nomg sv_catpvn #endif -#if (PERL_BCDVERSION < 0x5005000) -# undef XSRETURN -# define XSRETURN(off) \ - STMT_START { \ - PL_stack_sp = PL_stack_base + ax + ((off) - 1); \ - return; \ - } STMT_END -#endif -#ifndef XSPROTO -# define XSPROTO(name) void name(pTHX_ CV* cv) +#ifndef sv_catsv_nomg +# define sv_catsv_nomg sv_catsv #endif -#ifndef SVfARG -# define SVfARG(p) ((void*)(p)) -#endif -#ifndef PERL_ABS -# define PERL_ABS(x) ((x) < 0 ? -(x) : (x)) -#endif -#ifndef dVAR -# define dVAR dNOOP -#endif -#ifndef SVf -# define SVf "_" -#endif -#ifndef UTF8_MAXBYTES -# define UTF8_MAXBYTES UTF8_MAXLEN -#endif -#ifndef CPERLscope -# define CPERLscope(x) x -#endif -#ifndef PERL_HASH -# define PERL_HASH(hash,str,len) \ - STMT_START { \ - const char *s_PeRlHaSh = str; \ - I32 i_PeRlHaSh = len; \ - U32 hash_PeRlHaSh = 0; \ - while (i_PeRlHaSh--) \ - hash_PeRlHaSh = hash_PeRlHaSh * 33 + *s_PeRlHaSh++; \ - (hash) = hash_PeRlHaSh; \ - } STMT_END +#ifndef sv_setsv_nomg +# define sv_setsv_nomg sv_setsv #endif -#ifndef PERLIO_FUNCS_DECL -# ifdef PERLIO_FUNCS_CONST -# define PERLIO_FUNCS_DECL(funcs) const PerlIO_funcs funcs -# define PERLIO_FUNCS_CAST(funcs) (PerlIO_funcs*)(funcs) -# else -# define PERLIO_FUNCS_DECL(funcs) PerlIO_funcs funcs -# define PERLIO_FUNCS_CAST(funcs) (funcs) -# endif +#ifndef sv_pvn_nomg +# define sv_pvn_nomg sv_pvn #endif -/* provide these typedefs for older perls */ -#if (PERL_BCDVERSION < 0x5009003) - -# ifdef ARGSproto -typedef OP* (CPERLscope(*Perl_ppaddr_t))(ARGSproto); -# else -typedef OP* (CPERLscope(*Perl_ppaddr_t))(pTHX); -# endif - -typedef OP* (CPERLscope(*Perl_check_t)) (pTHX_ OP*); - -#endif -#ifndef isPSXSPC -# define isPSXSPC(c) (isSPACE(c) || (c) == '\v') +#ifndef SvIV_nomg +# define SvIV_nomg SvIV #endif -#ifndef isBLANK -# define isBLANK(c) ((c) == ' ' || (c) == '\t') +#ifndef SvUV_nomg +# define SvUV_nomg SvUV #endif -#ifdef EBCDIC -#ifndef isALNUMC -# define isALNUMC(c) isalnum(c) +#ifndef sv_catpv_mg +# define sv_catpv_mg(sv, ptr) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_catpv(TeMpSv,ptr); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END #endif -#ifndef isASCII -# define isASCII(c) isascii(c) +#ifndef sv_catpvn_mg +# define sv_catpvn_mg(sv, ptr, len) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_catpvn(TeMpSv,ptr,len); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END #endif -#ifndef isCNTRL -# define isCNTRL(c) iscntrl(c) +#ifndef sv_catsv_mg +# define sv_catsv_mg(dsv, ssv) \ + STMT_START { \ + SV *TeMpSv = dsv; \ + sv_catsv(TeMpSv,ssv); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END #endif -#ifndef isGRAPH -# define isGRAPH(c) isgraph(c) +#ifndef sv_setiv_mg +# define sv_setiv_mg(sv, i) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_setiv(TeMpSv,i); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END #endif -#ifndef isPRINT -# define isPRINT(c) isprint(c) +#ifndef sv_setnv_mg +# define sv_setnv_mg(sv, num) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_setnv(TeMpSv,num); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END #endif -#ifndef isPUNCT -# define isPUNCT(c) ispunct(c) +#ifndef sv_setpv_mg +# define sv_setpv_mg(sv, ptr) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_setpv(TeMpSv,ptr); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END #endif -#ifndef isXDIGIT -# define isXDIGIT(c) isxdigit(c) +#ifndef sv_setpvn_mg +# define sv_setpvn_mg(sv, ptr, len) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_setpvn(TeMpSv,ptr,len); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END #endif -#else -# if (PERL_BCDVERSION < 0x5010000) -/* Hint: isPRINT - * The implementation in older perl versions includes all of the - * isSPACE() characters, which is wrong. The version provided by - * Devel::PPPort always overrides a present buggy version. - */ -# undef isPRINT -# endif - -#ifdef HAS_QUAD -# ifdef U64TYPE -# define WIDEST_UTYPE U64TYPE -# else -# define WIDEST_UTYPE Quad_t -# endif -#else -# define WIDEST_UTYPE U32 -#endif -#ifndef isALNUMC -# define isALNUMC(c) (isALPHA(c) || isDIGIT(c)) +#ifndef sv_setsv_mg +# define sv_setsv_mg(dsv, ssv) \ + STMT_START { \ + SV *TeMpSv = dsv; \ + sv_setsv(TeMpSv,ssv); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END #endif -#ifndef isASCII -# define isASCII(c) ((WIDEST_UTYPE) (c) <= 127) +#ifndef sv_setuv_mg +# define sv_setuv_mg(sv, i) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_setuv(TeMpSv,i); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END #endif -#ifndef isCNTRL -# define isCNTRL(c) ((WIDEST_UTYPE) (c) < ' ' || (c) == 127) +#ifndef sv_usepvn_mg +# define sv_usepvn_mg(sv, ptr, len) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_usepvn(TeMpSv,ptr,len); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END #endif - -#ifndef isGRAPH -# define isGRAPH(c) (isALNUM(c) || isPUNCT(c)) +#ifndef SvVSTRING_mg +# define SvVSTRING_mg(sv) (SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_vstring) : NULL) #endif -#ifndef isPRINT -# define isPRINT(c) (((c) >= 32 && (c) < 127)) -#endif +/* Hint: sv_magic_portable + * This is a compatibility function that is only available with + * Devel::PPPort. It is NOT in the perl core. + * Its purpose is to mimic the 5.8.0 behaviour of sv_magic() when + * it is being passed a name pointer with namlen == 0. In that + * case, perl 5.8.0 and later store the pointer, not a copy of it. + * The compatibility can be provided back to perl 5.004. With + * earlier versions, the code will not compile. + */ -#ifndef isPUNCT -# define isPUNCT(c) (((c) >= 33 && (c) <= 47) || ((c) >= 58 && (c) <= 64) || ((c) >= 91 && (c) <= 96) || ((c) >= 123 && (c) <= 126)) -#endif +#if (PERL_BCDVERSION < 0x5004000) -#ifndef isXDIGIT -# define isXDIGIT(c) (isDIGIT(c) || ((c) >= 'a' && (c) <= 'f') || ((c) >= 'A' && (c) <= 'F')) -#endif + /* code that uses sv_magic_portable will not compile */ -#endif +#elif (PERL_BCDVERSION < 0x5008000) -/* Until we figure out how to support this in older perls... */ -#if (PERL_BCDVERSION >= 0x5008000) -#ifndef HeUTF8 -# define HeUTF8(he) ((HeKLEN(he) == HEf_SVKEY) ? \ - SvUTF8(HeKEY_sv(he)) : \ - (U32)HeKUTF8(he)) -#endif +# define sv_magic_portable(sv, obj, how, name, namlen) \ + STMT_START { \ + SV *SvMp_sv = (sv); \ + char *SvMp_name = (char *) (name); \ + I32 SvMp_namlen = (namlen); \ + if (SvMp_name && SvMp_namlen == 0) \ + { \ + MAGIC *mg; \ + sv_magic(SvMp_sv, obj, how, 0, 0); \ + mg = SvMAGIC(SvMp_sv); \ + mg->mg_len = -42; /* XXX: this is the tricky part */ \ + mg->mg_ptr = SvMp_name; \ + } \ + else \ + { \ + sv_magic(SvMp_sv, obj, how, SvMp_name, SvMp_namlen); \ + } \ + } STMT_END + +#else + +# define sv_magic_portable(a, b, c, d, e) sv_magic(a, b, c, d, e) -#endif -#ifndef C_ARRAY_LENGTH -# define C_ARRAY_LENGTH(a) (sizeof(a)/sizeof((a)[0])) #endif -#ifndef C_ARRAY_END -# define C_ARRAY_END(a) ((a) + C_ARRAY_LENGTH(a)) +#if !defined(mg_findext) +#if defined(NEED_mg_findext) +static MAGIC * DPPP_(my_mg_findext)(SV * sv, int type, const MGVTBL *vtbl); +static +#else +extern MAGIC * DPPP_(my_mg_findext)(SV * sv, int type, const MGVTBL *vtbl); #endif -#ifndef PERL_SIGNALS_UNSAFE_FLAG +#define mg_findext DPPP_(my_mg_findext) +#define Perl_mg_findext DPPP_(my_mg_findext) -#define PERL_SIGNALS_UNSAFE_FLAG 0x0001 +#if defined(NEED_mg_findext) || defined(NEED_mg_findext_GLOBAL) -#if (PERL_BCDVERSION < 0x5008000) -# define D_PPP_PERL_SIGNALS_INIT PERL_SIGNALS_UNSAFE_FLAG -#else -# define D_PPP_PERL_SIGNALS_INIT 0 -#endif +MAGIC * +DPPP_(my_mg_findext)(SV * sv, int type, const MGVTBL *vtbl) { + if (sv) { + MAGIC *mg; -#if defined(NEED_PL_signals) -static U32 DPPP_(my_PL_signals) = D_PPP_PERL_SIGNALS_INIT; -#elif defined(NEED_PL_signals_GLOBAL) -U32 DPPP_(my_PL_signals) = D_PPP_PERL_SIGNALS_INIT; -#else -extern U32 DPPP_(my_PL_signals); +#ifdef AvPAD_NAMELIST + assert(!(SvTYPE(sv) == SVt_PVAV && AvPAD_NAMELIST(sv))); #endif -#define PL_signals DPPP_(my_PL_signals) -#endif + for (mg = SvMAGIC (sv); mg; mg = mg->mg_moremagic) { + if (mg->mg_type == type && mg->mg_virtual == vtbl) + return mg; + } + } -/* Hint: PL_ppaddr - * Calling an op via PL_ppaddr requires passing a context argument - * for threaded builds. Since the context argument is different for - * 5.005 perls, you can use aTHXR (supplied by ppport.h), which will - * automatically be defined as the correct argument. - */ + return NULL; +} -#if (PERL_BCDVERSION <= 0x5005005) -/* Replace: 1 */ -# define PL_ppaddr ppaddr -# define PL_no_modify no_modify -/* Replace: 0 */ #endif - -#if (PERL_BCDVERSION <= 0x5004005) -/* Replace: 1 */ -# define PL_DBsignal DBsignal -# define PL_DBsingle DBsingle -# define PL_DBsub DBsub -# define PL_DBtrace DBtrace -# define PL_Sv Sv -# define PL_bufend bufend -# define PL_bufptr bufptr -# define PL_compiling compiling -# define PL_copline copline -# define PL_curcop curcop -# define PL_curstash curstash -# define PL_debstash debstash -# define PL_defgv defgv -# define PL_diehook diehook -# define PL_dirty dirty -# define PL_dowarn dowarn -# define PL_errgv errgv -# define PL_error_count error_count -# define PL_expect expect -# define PL_hexdigit hexdigit -# define PL_hints hints -# define PL_in_my in_my -# define PL_laststatval laststatval -# define PL_lex_state lex_state -# define PL_lex_stuff lex_stuff -# define PL_linestr linestr -# define PL_na na -# define PL_perl_destruct_level perl_destruct_level -# define PL_perldb perldb -# define PL_rsfp_filters rsfp_filters -# define PL_rsfp rsfp -# define PL_stack_base stack_base -# define PL_stack_sp stack_sp -# define PL_statcache statcache -# define PL_stdingv stdingv -# define PL_sv_arenaroot sv_arenaroot -# define PL_sv_no sv_no -# define PL_sv_undef sv_undef -# define PL_sv_yes sv_yes -# define PL_tainted tainted -# define PL_tainting tainting -# define PL_tokenbuf tokenbuf -/* Replace: 0 */ #endif -/* Warning: PL_parser - * For perl versions earlier than 5.9.5, this is an always - * non-NULL dummy. Also, it cannot be dereferenced. Don't - * use it if you can avoid is and unless you absolutely know - * what you're doing. - * If you always check that PL_parser is non-NULL, you can - * define DPPP_PL_parser_NO_DUMMY to avoid the creation of - * a dummy parser structure. - */ - -#if (PERL_BCDVERSION >= 0x5009005) -# ifdef DPPP_PL_parser_NO_DUMMY -# define D_PPP_my_PL_parser_var(var) ((PL_parser ? PL_parser : \ - (croak("panic: PL_parser == NULL in %s:%d", \ - __FILE__, __LINE__), (yy_parser *) NULL))->var) -# else -# ifdef DPPP_PL_parser_NO_DUMMY_WARNING -# define D_PPP_parser_dummy_warning(var) -# else -# define D_PPP_parser_dummy_warning(var) \ - warn("warning: dummy PL_" #var " used in %s:%d", __FILE__, __LINE__), -# endif -# define D_PPP_my_PL_parser_var(var) ((PL_parser ? PL_parser : \ - (D_PPP_parser_dummy_warning(var) &DPPP_(dummy_PL_parser)))->var) -#if defined(NEED_PL_parser) -static yy_parser DPPP_(dummy_PL_parser); -#elif defined(NEED_PL_parser_GLOBAL) -yy_parser DPPP_(dummy_PL_parser); +#if !defined(sv_unmagicext) +#if defined(NEED_sv_unmagicext) +static int DPPP_(my_sv_unmagicext)(pTHX_ SV * const sv, const int type, MGVTBL * vtbl); +static #else -extern yy_parser DPPP_(dummy_PL_parser); +extern int DPPP_(my_sv_unmagicext)(pTHX_ SV * const sv, const int type, MGVTBL * vtbl); #endif -# endif - -/* PL_expect, PL_copline, PL_rsfp, PL_rsfp_filters, PL_linestr, PL_bufptr, PL_bufend, PL_lex_state, PL_lex_stuff, PL_tokenbuf depends on PL_parser */ -/* Warning: PL_expect, PL_copline, PL_rsfp, PL_rsfp_filters, PL_linestr, PL_bufptr, PL_bufend, PL_lex_state, PL_lex_stuff, PL_tokenbuf - * Do not use this variable unless you know exactly what you're - * doing. It is internal to the perl parser and may change or even - * be removed in the future. As of perl 5.9.5, you have to check - * for (PL_parser != NULL) for this variable to have any effect. - * An always non-NULL PL_parser dummy is provided for earlier - * perl versions. - * If PL_parser is NULL when you try to access this variable, a - * dummy is being accessed instead and a warning is issued unless - * you define DPPP_PL_parser_NO_DUMMY_WARNING. - * If DPPP_PL_parser_NO_DUMMY is defined, the code trying to access - * this variable will croak with a panic message. - */ - -# define PL_expect D_PPP_my_PL_parser_var(expect) -# define PL_copline D_PPP_my_PL_parser_var(copline) -# define PL_rsfp D_PPP_my_PL_parser_var(rsfp) -# define PL_rsfp_filters D_PPP_my_PL_parser_var(rsfp_filters) -# define PL_linestr D_PPP_my_PL_parser_var(linestr) -# define PL_bufptr D_PPP_my_PL_parser_var(bufptr) -# define PL_bufend D_PPP_my_PL_parser_var(bufend) -# define PL_lex_state D_PPP_my_PL_parser_var(lex_state) -# define PL_lex_stuff D_PPP_my_PL_parser_var(lex_stuff) -# define PL_tokenbuf D_PPP_my_PL_parser_var(tokenbuf) -# define PL_in_my D_PPP_my_PL_parser_var(in_my) -# define PL_in_my_stash D_PPP_my_PL_parser_var(in_my_stash) -# define PL_error_count D_PPP_my_PL_parser_var(error_count) +#ifdef sv_unmagicext +# undef sv_unmagicext +#endif +#define sv_unmagicext(a,b,c) DPPP_(my_sv_unmagicext)(aTHX_ a,b,c) +#define Perl_sv_unmagicext DPPP_(my_sv_unmagicext) +#if defined(NEED_sv_unmagicext) || defined(NEED_sv_unmagicext_GLOBAL) -#else +int +DPPP_(my_sv_unmagicext)(pTHX_ SV *const sv, const int type, MGVTBL *vtbl) +{ + MAGIC* mg; + MAGIC** mgp; -/* ensure that PL_parser != NULL and cannot be dereferenced */ -# define PL_parser ((void *) 1) + if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv)) + return 0; + mgp = &(SvMAGIC(sv)); + for (mg = *mgp; mg; mg = *mgp) { + const MGVTBL* const virt = mg->mg_virtual; + if (mg->mg_type == type && virt == vtbl) { + *mgp = mg->mg_moremagic; + if (virt && virt->svt_free) + virt->svt_free(aTHX_ sv, mg); + if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) { + if (mg->mg_len > 0) + Safefree(mg->mg_ptr); + else if (mg->mg_len == HEf_SVKEY) /* Questionable on older perls... */ + SvREFCNT_dec(MUTABLE_SV(mg->mg_ptr)); + else if (mg->mg_type == PERL_MAGIC_utf8) + Safefree(mg->mg_ptr); + } + if (mg->mg_flags & MGf_REFCOUNTED) + SvREFCNT_dec(mg->mg_obj); + Safefree(mg); + } + else + mgp = &mg->mg_moremagic; + } + if (SvMAGIC(sv)) { + if (SvMAGICAL(sv)) /* if we're under save_magic, wait for restore_magic; */ + mg_magical(sv); /* else fix the flags now */ + } + else { + SvMAGICAL_off(sv); + SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT; + } + return 0; +} #endif -#ifndef mPUSHs -# define mPUSHs(s) PUSHs(sv_2mortal(s)) #endif - -#ifndef PUSHmortal -# define PUSHmortal PUSHs(sv_newmortal()) +#ifndef cBOOL +# define cBOOL(cbool) ((cbool) ? (bool)1 : (bool)0) #endif -#ifndef mPUSHp -# define mPUSHp(p,l) sv_setpvn(PUSHmortal, (p), (l)) +#ifndef OpHAS_SIBLING +# define OpHAS_SIBLING(o) (cBOOL((o)->op_sibling)) #endif -#ifndef mPUSHn -# define mPUSHn(n) sv_setnv(PUSHmortal, (NV)(n)) +#ifndef OpSIBLING +# define OpSIBLING(o) (0 + (o)->op_sibling) #endif -#ifndef mPUSHi -# define mPUSHi(i) sv_setiv(PUSHmortal, (IV)(i)) +#ifndef OpMORESIB_set +# define OpMORESIB_set(o, sib) ((o)->op_sibling = (sib)) #endif -#ifndef mPUSHu -# define mPUSHu(u) sv_setuv(PUSHmortal, (UV)(u)) +#ifndef OpLASTSIB_set +# define OpLASTSIB_set(o, parent) ((o)->op_sibling = NULL) #endif -#ifndef mXPUSHs -# define mXPUSHs(s) XPUSHs(sv_2mortal(s)) + +#ifndef OpMAYBESIB_set +# define OpMAYBESIB_set(o, sib, parent) ((o)->op_sibling = (sib)) #endif -#ifndef XPUSHmortal -# define XPUSHmortal XPUSHs(sv_newmortal()) +#ifndef SvRX +#if defined(NEED_SvRX) +static void * DPPP_(my_SvRX)(pTHX_ SV *rv); +static +#else +extern void * DPPP_(my_SvRX)(pTHX_ SV *rv); #endif -#ifndef mXPUSHp -# define mXPUSHp(p,l) STMT_START { EXTEND(sp,1); sv_setpvn(PUSHmortal, (p), (l)); } STMT_END +#ifdef SvRX +# undef SvRX #endif +#define SvRX(a) DPPP_(my_SvRX)(aTHX_ a) -#ifndef mXPUSHn -# define mXPUSHn(n) STMT_START { EXTEND(sp,1); sv_setnv(PUSHmortal, (NV)(n)); } STMT_END +#if defined(NEED_SvRX) || defined(NEED_SvRX_GLOBAL) + +void * +DPPP_(my_SvRX)(pTHX_ SV *rv) +{ + if (SvROK(rv)) { + SV *sv = SvRV(rv); + if (SvMAGICAL(sv)) { + MAGIC *mg = mg_find(sv, PERL_MAGIC_qr); + if (mg && mg->mg_obj) { + return mg->mg_obj; + } + } + } + return 0; +} +#endif +#endif +#ifndef SvRXOK +# define SvRXOK(sv) (!!SvRX(sv)) #endif -#ifndef mXPUSHi -# define mXPUSHi(i) STMT_START { EXTEND(sp,1); sv_setiv(PUSHmortal, (IV)(i)); } STMT_END +#ifndef PERL_UNUSED_DECL +# ifdef HASATTRIBUTE +# if (defined(__GNUC__) && defined(__cplusplus)) || defined(__INTEL_COMPILER) +# define PERL_UNUSED_DECL +# else +# define PERL_UNUSED_DECL __attribute__((unused)) +# endif +# else +# define PERL_UNUSED_DECL +# endif #endif -#ifndef mXPUSHu -# define mXPUSHu(u) STMT_START { EXTEND(sp,1); sv_setuv(PUSHmortal, (UV)(u)); } STMT_END +#ifndef PERL_UNUSED_ARG +# if defined(lint) && defined(S_SPLINT_S) /* www.splint.org */ +# include +# define PERL_UNUSED_ARG(x) NOTE(ARGUNUSED(x)) +# else +# define PERL_UNUSED_ARG(x) ((void)x) +# endif #endif -/* Replace: 1 */ -#ifndef call_sv -# define call_sv perl_call_sv +#ifndef PERL_UNUSED_VAR +# define PERL_UNUSED_VAR(x) ((void)x) #endif -#ifndef call_pv -# define call_pv perl_call_pv +#ifndef PERL_UNUSED_CONTEXT +# ifdef USE_ITHREADS +# define PERL_UNUSED_CONTEXT PERL_UNUSED_ARG(my_perl) +# else +# define PERL_UNUSED_CONTEXT +# endif #endif -#ifndef call_argv -# define call_argv perl_call_argv +#ifndef PERL_UNUSED_RESULT +# if defined(__GNUC__) && defined(HASATTRIBUTE_WARN_UNUSED_RESULT) +# define PERL_UNUSED_RESULT(v) STMT_START { __typeof__(v) z = (v); (void)sizeof(z); } STMT_END +# else +# define PERL_UNUSED_RESULT(v) ((void)(v)) +# endif +#endif +#ifndef NOOP +# define NOOP /*EMPTY*/(void)0 #endif -#ifndef call_method -# define call_method perl_call_method +#ifndef dNOOP +# define dNOOP extern int /*@unused@*/ Perl___notused PERL_UNUSED_DECL #endif -#ifndef eval_sv -# define eval_sv perl_eval_sv + +#ifndef NVTYPE +# if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE) +# define NVTYPE long double +# else +# define NVTYPE double +# endif +typedef NVTYPE NV; #endif -/* Replace: 0 */ -#ifndef PERL_LOADMOD_DENY -# define PERL_LOADMOD_DENY 0x1 +#ifndef INT2PTR +# if (IVSIZE == PTRSIZE) && (UVSIZE == PTRSIZE) +# define PTRV UV +# define INT2PTR(any,d) (any)(d) +# else +# if PTRSIZE == LONGSIZE +# define PTRV unsigned long +# else +# define PTRV unsigned +# endif +# define INT2PTR(any,d) (any)(PTRV)(d) +# endif #endif -#ifndef PERL_LOADMOD_NOIMPORT -# define PERL_LOADMOD_NOIMPORT 0x2 +#ifndef PTR2ul +# if PTRSIZE == LONGSIZE +# define PTR2ul(p) (unsigned long)(p) +# else +# define PTR2ul(p) INT2PTR(unsigned long,p) +# endif +#endif +#ifndef PTR2nat +# define PTR2nat(p) (PTRV)(p) #endif -#ifndef PERL_LOADMOD_IMPORT_OPS -# define PERL_LOADMOD_IMPORT_OPS 0x4 +#ifndef NUM2PTR +# define NUM2PTR(any,d) (any)PTR2nat(d) #endif -#ifndef G_METHOD -# define G_METHOD 64 -# ifdef call_sv -# undef call_sv -# endif -# if (PERL_BCDVERSION < 0x5006000) -# define call_sv(sv, flags) ((flags) & G_METHOD ? perl_call_method((char *) SvPV_nolen_const(sv), \ - (flags) & ~G_METHOD) : perl_call_sv(sv, flags)) -# else -# define call_sv(sv, flags) ((flags) & G_METHOD ? Perl_call_method(aTHX_ (char *) SvPV_nolen_const(sv), \ - (flags) & ~G_METHOD) : Perl_call_sv(aTHX_ sv, flags)) -# endif +#ifndef PTR2IV +# define PTR2IV(p) INT2PTR(IV,p) #endif -/* Replace perl_eval_pv with eval_pv */ +#ifndef PTR2UV +# define PTR2UV(p) INT2PTR(UV,p) +#endif -#ifndef eval_pv -#if defined(NEED_eval_pv) -static SV* DPPP_(my_eval_pv)(char *p, I32 croak_on_error); -static -#else -extern SV* DPPP_(my_eval_pv)(char *p, I32 croak_on_error); +#ifndef PTR2NV +# define PTR2NV(p) NUM2PTR(NV,p) #endif -#ifdef eval_pv -# undef eval_pv +#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 -#define eval_pv(a,b) DPPP_(my_eval_pv)(aTHX_ a,b) -#define Perl_eval_pv DPPP_(my_eval_pv) -#if defined(NEED_eval_pv) || defined(NEED_eval_pv_GLOBAL) +#if defined(PERL_GCC_PEDANTIC) +# ifndef PERL_GCC_BRACE_GROUPS_FORBIDDEN +# define PERL_GCC_BRACE_GROUPS_FORBIDDEN +# endif +#endif -SV* -DPPP_(my_eval_pv)(char *p, I32 croak_on_error) -{ - dSP; - SV* sv = newSVpv(p, 0); +#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 - PUSHMARK(sp); - eval_sv(sv, G_SCALAR); - SvREFCNT_dec(sv); +#undef STMT_START +#undef STMT_END +#ifdef PERL_USE_GCC_BRACE_GROUPS +# define STMT_START (void)( /* gcc supports ``({ STATEMENTS; })'' */ +# define STMT_END ) +#else +# if defined(VOIDFLAGS) && (VOIDFLAGS) && (defined(sun) || defined(__sun__)) && !defined(__GNUC__) +# define STMT_START if (1) +# define STMT_END else (void)0 +# else +# define STMT_START do +# define STMT_END while (0) +# endif +#endif +#ifndef boolSV +# define boolSV(b) ((b) ? &PL_sv_yes : &PL_sv_no) +#endif - SPAGAIN; - sv = POPs; - PUTBACK; +/* DEFSV appears first in 5.004_56 */ +#ifndef DEFSV +# define DEFSV GvSV(PL_defgv) +#endif - if (croak_on_error && SvTRUE(GvSV(errgv))) - croak(SvPVx(GvSV(errgv), na)); +#ifndef SAVE_DEFSV +# define SAVE_DEFSV SAVESPTR(GvSV(PL_defgv)) +#endif - return sv; -} +#ifndef DEFSV_set +# define DEFSV_set(sv) (DEFSV = (sv)) +#endif +/* Older perls (<=5.003) lack AvFILLp */ +#ifndef AvFILLp +# define AvFILLp AvFILL #endif +#ifndef ERRSV +# define ERRSV get_sv("@",FALSE) #endif -#ifndef vload_module -#if defined(NEED_vload_module) -static void DPPP_(my_vload_module)(U32 flags, SV *name, SV *ver, va_list *args); -static -#else -extern void DPPP_(my_vload_module)(U32 flags, SV *name, SV *ver, va_list *args); +/* Hint: gv_stashpvn + * This function's backport doesn't support the length parameter, but + * rather ignores it. Portability can only be ensured if the length + * parameter is used for speed reasons, but the length can always be + * correctly computed from the string argument. + */ +#ifndef gv_stashpvn +# define gv_stashpvn(str,len,create) gv_stashpv(str,create) #endif -#ifdef vload_module -# undef vload_module +/* Replace: 1 */ +#ifndef get_cv +# define get_cv perl_get_cv #endif -#define vload_module(a,b,c,d) DPPP_(my_vload_module)(aTHX_ a,b,c,d) -#define Perl_vload_module DPPP_(my_vload_module) -#if defined(NEED_vload_module) || defined(NEED_vload_module_GLOBAL) +#ifndef get_sv +# define get_sv perl_get_sv +#endif -void -DPPP_(my_vload_module)(U32 flags, SV *name, SV *ver, va_list *args) -{ - dTHR; - dVAR; - OP *veop, *imop; +#ifndef get_av +# define get_av perl_get_av +#endif - OP * const modname = newSVOP(OP_CONST, 0, name); - /* 5.005 has a somewhat hacky force_normal that doesn't croak on - SvREADONLY() if PL_compling is true. Current perls take care in - ck_require() to correctly turn off SvREADONLY before calling - force_normal_flags(). This seems a better fix than fudging PL_compling - */ - SvREADONLY_off(((SVOP*)modname)->op_sv); - modname->op_private |= OPpCONST_BARE; - if (ver) { - veop = newSVOP(OP_CONST, 0, ver); - } - else - veop = NULL; - if (flags & PERL_LOADMOD_NOIMPORT) { - imop = sawparens(newNULLLIST()); - } - else if (flags & PERL_LOADMOD_IMPORT_OPS) { - imop = va_arg(*args, OP*); - } - else { - SV *sv; - imop = NULL; - sv = va_arg(*args, SV*); - while (sv) { - imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv)); - sv = va_arg(*args, SV*); - } - } - { - const line_t ocopline = PL_copline; - COP * const ocurcop = PL_curcop; - const int oexpect = PL_expect; +#ifndef get_hv +# define get_hv perl_get_hv +#endif -#if (PERL_BCDVERSION >= 0x5004000) - utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0), - veop, modname, imop); -#elif (PERL_BCDVERSION > 0x5003000) - utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(), - veop, modname, imop); -#else - utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(), - modname, imop); +/* Replace: 0 */ +#ifndef dUNDERBAR +# define dUNDERBAR dNOOP #endif - PL_expect = oexpect; - PL_copline = ocopline; - PL_curcop = ocurcop; - } -} +#ifndef UNDERBAR +# define UNDERBAR DEFSV #endif +#ifndef dAX +# define dAX I32 ax = MARK - PL_stack_base + 1 #endif -#ifndef load_module -#if defined(NEED_load_module) -static void DPPP_(my_load_module)(U32 flags, SV *name, SV *ver, ...); -static -#else -extern void DPPP_(my_load_module)(U32 flags, SV *name, SV *ver, ...); +#ifndef dITEMS +# define dITEMS I32 items = SP - MARK #endif - -#ifdef load_module -# undef load_module +#ifndef dXSTARG +# define dXSTARG SV * targ = sv_newmortal() +#endif +#ifndef dAXMARK +# define dAXMARK I32 ax = POPMARK; \ + register SV ** const mark = PL_stack_base + ax++ +#endif +#ifndef XSprePUSH +# define XSprePUSH (sp = PL_stack_base + ax - 1) #endif -#define load_module DPPP_(my_load_module) -#define Perl_load_module DPPP_(my_load_module) - -#if defined(NEED_load_module) || defined(NEED_load_module_GLOBAL) -void -DPPP_(my_load_module)(U32 flags, SV *name, SV *ver, ...) -{ - va_list args; - va_start(args, ver); - vload_module(flags, name, ver, &args); - va_end(args); -} +#if (PERL_BCDVERSION < 0x5005000) +# undef XSRETURN +# define XSRETURN(off) \ + STMT_START { \ + PL_stack_sp = PL_stack_base + ax + ((off) - 1); \ + return; \ + } STMT_END +#endif +#ifndef XSPROTO +# define XSPROTO(name) void name(pTHX_ CV* cv) +#endif +#ifndef SVfARG +# define SVfARG(p) ((void*)(p)) #endif +#ifndef PERL_ABS +# define PERL_ABS(x) ((x) < 0 ? -(x) : (x)) #endif -#ifndef newRV_inc -# define newRV_inc(sv) newRV(sv) /* Replace */ +#ifndef dVAR +# define dVAR dNOOP #endif - -#ifndef newRV_noinc -#if defined(NEED_newRV_noinc) -static SV * DPPP_(my_newRV_noinc)(SV *sv); -static -#else -extern SV * DPPP_(my_newRV_noinc)(SV *sv); +#ifndef SVf +# define SVf "_" +#endif +#ifndef UTF8_MAXBYTES +# define UTF8_MAXBYTES UTF8_MAXLEN +#endif +#ifndef CPERLscope +# define CPERLscope(x) x +#endif +#ifndef PERL_HASH +# define PERL_HASH(hash,str,len) \ + STMT_START { \ + const char *s_PeRlHaSh = str; \ + I32 i_PeRlHaSh = len; \ + U32 hash_PeRlHaSh = 0; \ + while (i_PeRlHaSh--) \ + hash_PeRlHaSh = hash_PeRlHaSh * 33 + *s_PeRlHaSh++; \ + (hash) = hash_PeRlHaSh; \ + } STMT_END #endif -#ifdef newRV_noinc -# undef newRV_noinc +#ifndef PERLIO_FUNCS_DECL +# ifdef PERLIO_FUNCS_CONST +# define PERLIO_FUNCS_DECL(funcs) const PerlIO_funcs funcs +# define PERLIO_FUNCS_CAST(funcs) (PerlIO_funcs*)(funcs) +# else +# define PERLIO_FUNCS_DECL(funcs) PerlIO_funcs funcs +# define PERLIO_FUNCS_CAST(funcs) (funcs) +# endif #endif -#define newRV_noinc(a) DPPP_(my_newRV_noinc)(aTHX_ a) -#define Perl_newRV_noinc DPPP_(my_newRV_noinc) -#if defined(NEED_newRV_noinc) || defined(NEED_newRV_noinc_GLOBAL) -SV * -DPPP_(my_newRV_noinc)(SV *sv) -{ - SV *rv = (SV *)newRV(sv); - SvREFCNT_dec(sv); - return rv; -} +/* provide these typedefs for older perls */ +#if (PERL_BCDVERSION < 0x5009003) + +# ifdef ARGSproto +typedef OP* (CPERLscope(*Perl_ppaddr_t))(ARGSproto); +# else +typedef OP* (CPERLscope(*Perl_ppaddr_t))(pTHX); +# endif + +typedef OP* (CPERLscope(*Perl_check_t)) (pTHX_ OP*); + #endif +#ifndef isPSXSPC +# define isPSXSPC(c) (isSPACE(c) || (c) == '\v') #endif -/* Hint: newCONSTSUB - * Returns a CV* as of perl-5.7.1. This return value is not supported - * by Devel::PPPort. - */ - -/* newCONSTSUB from IO.xs is in the core starting with 5.004_63 */ -#if (PERL_BCDVERSION < 0x5004063) && (PERL_BCDVERSION != 0x5004005) -#if defined(NEED_newCONSTSUB) -static void DPPP_(my_newCONSTSUB)(HV *stash, const char *name, SV *sv); -static -#else -extern void DPPP_(my_newCONSTSUB)(HV *stash, const char *name, SV *sv); +#ifndef isBLANK +# define isBLANK(c) ((c) == ' ' || (c) == '\t') #endif -#ifdef newCONSTSUB -# undef newCONSTSUB +#ifdef EBCDIC +#ifndef isALNUMC +# define isALNUMC(c) isalnum(c) #endif -#define newCONSTSUB(a,b,c) DPPP_(my_newCONSTSUB)(aTHX_ a,b,c) -#define Perl_newCONSTSUB DPPP_(my_newCONSTSUB) -#if defined(NEED_newCONSTSUB) || defined(NEED_newCONSTSUB_GLOBAL) +#ifndef isASCII +# define isASCII(c) isascii(c) +#endif -/* This is just a trick to avoid a dependency of newCONSTSUB on PL_parser */ -/* (There's no PL_parser in perl < 5.005, so this is completely safe) */ -#define D_PPP_PL_copline PL_copline +#ifndef isCNTRL +# define isCNTRL(c) iscntrl(c) +#endif -void -DPPP_(my_newCONSTSUB)(HV *stash, const char *name, SV *sv) -{ - U32 oldhints = PL_hints; - HV *old_cop_stash = PL_curcop->cop_stash; - HV *old_curstash = PL_curstash; - line_t oldline = PL_curcop->cop_line; - PL_curcop->cop_line = D_PPP_PL_copline; +#ifndef isGRAPH +# define isGRAPH(c) isgraph(c) +#endif - PL_hints &= ~HINT_BLOCK_SCOPE; - if (stash) - PL_curstash = PL_curcop->cop_stash = stash; +#ifndef isPRINT +# define isPRINT(c) isprint(c) +#endif - newSUB( +#ifndef isPUNCT +# define isPUNCT(c) ispunct(c) +#endif -#if (PERL_BCDVERSION < 0x5003022) - start_subparse(), -#elif (PERL_BCDVERSION == 0x5003022) - start_subparse(0), -#else /* 5.003_23 onwards */ - start_subparse(FALSE, 0), +#ifndef isXDIGIT +# define isXDIGIT(c) isxdigit(c) #endif - newSVOP(OP_CONST, 0, newSVpv((char *) name, 0)), - newSVOP(OP_CONST, 0, &PL_sv_no), /* SvPV(&PL_sv_no) == "" -- GMB */ - newSTATEOP(0, Nullch, newSVOP(OP_CONST, 0, sv)) - ); +#else +# if (PERL_BCDVERSION < 0x5010000) +/* Hint: isPRINT + * The implementation in older perl versions includes all of the + * isSPACE() characters, which is wrong. The version provided by + * Devel::PPPort always overrides a present buggy version. + */ +# undef isPRINT +# endif - PL_hints = oldhints; - PL_curcop->cop_stash = old_cop_stash; - PL_curstash = old_curstash; - PL_curcop->cop_line = oldline; -} +#ifndef WIDEST_UTYPE +# ifdef QUADKIND +# ifdef U64TYPE +# define WIDEST_UTYPE U64TYPE +# else +# define WIDEST_UTYPE Quad_t +# endif +# else +# define WIDEST_UTYPE U32 +# endif #endif +#ifndef isALNUMC +# define isALNUMC(c) (isALPHA(c) || isDIGIT(c)) #endif -/* - * Boilerplate macros for initializing and accessing interpreter-local - * data from C. All statics in extensions should be reworked to use - * this, if you want to make the extension thread-safe. See ext/re/re.xs - * for an example of the use of these macros. - * - * Code that uses these macros is responsible for the following: - * 1. #define MY_CXT_KEY to a unique string, e.g. "DynaLoader_guts" - * 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. - * 4. Use the MY_CXT_INIT macro such that it is called exactly once - * (typically put in the BOOT: section). - * 5. Use the members of the my_cxt_t structure everywhere as - * MY_CXT.member. - * 6. Use the dMY_CXT macro (a declaration) in all the functions that - * access MY_CXT. - */ - -#if defined(MULTIPLICITY) || defined(PERL_OBJECT) || \ - defined(PERL_CAPI) || defined(PERL_IMPLICIT_CONTEXT) - -#ifndef START_MY_CXT - -/* 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 - -#if (PERL_BCDVERSION < 0x5004068) -/* Fetches the SV that keeps the per-interpreter data. */ -#define dMY_CXT_SV \ - SV *my_cxt_sv = get_sv(MY_CXT_KEY, FALSE) -#else /* >= perl5.004_68 */ -#define dMY_CXT_SV \ - SV *my_cxt_sv = *hv_fetch(PL_modglobal, MY_CXT_KEY, \ - sizeof(MY_CXT_KEY)-1, TRUE) -#endif /* < perl5.004_68 */ - -/* 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)) - -/* 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)) - -/* This macro must be used to access members of the my_cxt_t structure. - * e.g. MYCXT.some_data */ -#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 +#ifndef isASCII +# define isASCII(c) ((WIDEST_UTYPE) (c) <= 127) +#endif -#endif /* START_MY_CXT */ +#ifndef isCNTRL +# define isCNTRL(c) ((WIDEST_UTYPE) (c) < ' ' || (c) == 127) +#endif -#ifndef MY_CXT_CLONE -/* 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)) +#ifndef isGRAPH +# define isGRAPH(c) (isALNUM(c) || isPUNCT(c)) #endif -#else /* single interpreter */ +#ifndef isPRINT +# define isPRINT(c) (((c) >= 32 && (c) < 127)) +#endif -#ifndef START_MY_CXT +#ifndef isPUNCT +# define isPUNCT(c) (((c) >= 33 && (c) <= 47) || ((c) >= 58 && (c) <= 64) || ((c) >= 91 && (c) <= 96) || ((c) >= 123 && (c) <= 126)) +#endif -#define START_MY_CXT static my_cxt_t my_cxt; -#define dMY_CXT_SV dNOOP -#define dMY_CXT dNOOP -#define MY_CXT_INIT NOOP -#define MY_CXT my_cxt +#ifndef isXDIGIT +# define isXDIGIT(c) (isDIGIT(c) || ((c) >= 'a' && (c) <= 'f') || ((c) >= 'A' && (c) <= 'F')) +#endif -#define pMY_CXT void -#define pMY_CXT_ -#define _pMY_CXT -#define aMY_CXT -#define aMY_CXT_ -#define _aMY_CXT +#endif -#endif /* START_MY_CXT */ +/* Until we figure out how to support this in older perls... */ +#if (PERL_BCDVERSION >= 0x5008000) +#ifndef HeUTF8 +# define HeUTF8(he) ((HeKLEN(he) == HEf_SVKEY) ? \ + SvUTF8(HeKEY_sv(he)) : \ + (U32)HeKUTF8(he)) +#endif -#ifndef MY_CXT_CLONE -#define MY_CXT_CLONE NOOP +#endif +#ifndef C_ARRAY_LENGTH +# define C_ARRAY_LENGTH(a) (sizeof(a)/sizeof((a)[0])) #endif +#ifndef C_ARRAY_END +# define C_ARRAY_END(a) ((a) + C_ARRAY_LENGTH(a)) #endif #ifndef IVdf @@ -5261,1462 +5113,1875 @@ DPPP_(my_newCONSTSUB)(HV *stash, const char *name, SV *sv) # endif #endif -#ifndef SvREFCNT_inc -# ifdef PERL_USE_GCC_BRACE_GROUPS -# define SvREFCNT_inc(sv) \ - ({ \ - SV * const _sv = (SV*)(sv); \ - if (_sv) \ - (SvREFCNT(_sv))++; \ - _sv; \ - }) -# else -# define SvREFCNT_inc(sv) \ - ((PL_Sv=(SV*)(sv)) ? (++(SvREFCNT(PL_Sv)),PL_Sv) : NULL) -# endif -#endif - -#ifndef SvREFCNT_inc_simple -# ifdef PERL_USE_GCC_BRACE_GROUPS -# define SvREFCNT_inc_simple(sv) \ - ({ \ - if (sv) \ - (SvREFCNT(sv))++; \ - (SV *)(sv); \ - }) -# else -# define SvREFCNT_inc_simple(sv) \ - ((sv) ? (SvREFCNT(sv)++,(SV*)(sv)) : NULL) -# endif +#ifdef NEED_mess_sv +#define NEED_mess #endif -#ifndef SvREFCNT_inc_NN -# ifdef PERL_USE_GCC_BRACE_GROUPS -# define SvREFCNT_inc_NN(sv) \ - ({ \ - SV * const _sv = (SV*)(sv); \ - SvREFCNT(_sv)++; \ - _sv; \ - }) -# else -# define SvREFCNT_inc_NN(sv) \ - (PL_Sv=(SV*)(sv),++(SvREFCNT(PL_Sv)),PL_Sv) -# endif +#ifdef NEED_mess +#define NEED_mess_nocontext +#define NEED_vmess #endif -#ifndef SvREFCNT_inc_void -# ifdef PERL_USE_GCC_BRACE_GROUPS -# define SvREFCNT_inc_void(sv) \ - ({ \ - SV * const _sv = (SV*)(sv); \ - if (_sv) \ - (void)(SvREFCNT(_sv)++); \ - }) +#ifndef croak_sv +#if (PERL_BCDVERSION >= 0x5007003) || ( (PERL_BCDVERSION >= 0x5006001) && (PERL_BCDVERSION < 0x5007000) ) +# if ( (PERL_BCDVERSION >= 0x5008000) && (PERL_BCDVERSION < 0x5008009) ) || ( (PERL_BCDVERSION >= 0x5009000) && (PERL_BCDVERSION < 0x5010001) ) +# define _dppp_fix_utf8_errsv(errsv, sv) \ + STMT_START { \ + if (sv != ERRSV) \ + SvFLAGS(ERRSV) = (SvFLAGS(ERRSV) & ~SVf_UTF8) | \ + (SvFLAGS(sv) & SVf_UTF8); \ + } STMT_END # else -# define SvREFCNT_inc_void(sv) \ - (void)((PL_Sv=(SV*)(sv)) ? ++(SvREFCNT(PL_Sv)) : 0) +# define _dppp_fix_utf8_errsv(errsv, sv) STMT_START {} STMT_END # endif +# define croak_sv(sv) \ + STMT_START { \ + if (SvROK(sv)) { \ + sv_setsv(ERRSV, sv); \ + croak(NULL); \ + } else { \ + _dppp_fix_utf8_errsv(ERRSV, sv); \ + croak("%" SVf, SVfARG(sv)); \ + } \ + } STMT_END +#elif (PERL_BCDVERSION >= 0x5004000) +# define croak_sv(sv) croak("%" SVf, SVfARG(sv)) +#else +# define croak_sv(sv) croak("%s", SvPV_nolen(sv)) #endif -#ifndef SvREFCNT_inc_simple_void -# define SvREFCNT_inc_simple_void(sv) STMT_START { if (sv) SvREFCNT(sv)++; } STMT_END #endif -#ifndef SvREFCNT_inc_simple_NN -# define SvREFCNT_inc_simple_NN(sv) (++SvREFCNT(sv), (SV*)(sv)) +#ifndef die_sv +#if defined(NEED_die_sv) +static OP * DPPP_(my_die_sv)(pTHX_ SV *sv); +static +#else +extern OP * DPPP_(my_die_sv)(pTHX_ SV *sv); #endif -#ifndef SvREFCNT_inc_void_NN -# define SvREFCNT_inc_void_NN(sv) (void)(++SvREFCNT((SV*)(sv))) +#ifdef die_sv +# undef die_sv #endif +#define die_sv(a) DPPP_(my_die_sv)(aTHX_ a) +#define Perl_die_sv DPPP_(my_die_sv) -#ifndef SvREFCNT_inc_simple_void_NN -# define SvREFCNT_inc_simple_void_NN(sv) (void)(++SvREFCNT((SV*)(sv))) +#if defined(NEED_die_sv) || defined(NEED_die_sv_GLOBAL) +OP * +DPPP_(my_die_sv)(pTHX_ SV *sv) +{ + croak_sv(sv); + return (OP *)NULL; +} +#endif #endif -#ifndef newSV_type +#ifndef warn_sv +#if (PERL_BCDVERSION >= 0x5004000) +# define warn_sv(sv) warn("%" SVf, SVfARG(sv)) +#else +# define warn_sv(sv) warn("%s", SvPV_nolen(sv)) +#endif +#endif -#if defined(NEED_newSV_type) -static SV* DPPP_(my_newSV_type)(pTHX_ svtype const t); +#ifndef vmess +#if defined(NEED_vmess) +static SV * DPPP_(my_vmess)(pTHX_ const char * pat, va_list * args); static #else -extern SV* DPPP_(my_newSV_type)(pTHX_ svtype const t); +extern SV * DPPP_(my_vmess)(pTHX_ const char * pat, va_list * args); #endif -#ifdef newSV_type -# undef newSV_type +#ifdef vmess +# undef vmess #endif -#define newSV_type(a) DPPP_(my_newSV_type)(aTHX_ a) -#define Perl_newSV_type DPPP_(my_newSV_type) - -#if defined(NEED_newSV_type) || defined(NEED_newSV_type_GLOBAL) +#define vmess(a,b) DPPP_(my_vmess)(aTHX_ a,b) +#define Perl_vmess DPPP_(my_vmess) +#if defined(NEED_vmess) || defined(NEED_vmess_GLOBAL) SV* -DPPP_(my_newSV_type)(pTHX_ svtype const t) +DPPP_(my_vmess)(pTHX_ const char* pat, va_list* args) { - SV* const sv = newSV(0); - sv_upgrade(sv, t); - return sv; + mess(pat, args); + return PL_mess_sv; } - #endif - #endif #if (PERL_BCDVERSION < 0x5006000) -# define D_PPP_CONSTPV_ARG(x) ((char *) (x)) -#else -# define D_PPP_CONSTPV_ARG(x) (x) +#undef mess #endif -#ifndef newSVpvn -# define newSVpvn(data,len) ((data) \ - ? ((len) ? newSVpv((data), (len)) : newSVpv("", 0)) \ - : newSV(0)) + +#if !defined(mess_nocontext) && !defined(Perl_mess_nocontext) +#if defined(NEED_mess_nocontext) +static SV * DPPP_(my_mess_nocontext)(const char * pat, ...); +static +#else +extern SV * DPPP_(my_mess_nocontext)(const char * pat, ...); #endif -#ifndef newSVpvn_utf8 -# define newSVpvn_utf8(s, len, u) newSVpvn_flags((s), (len), (u) ? SVf_UTF8 : 0) + +#define mess_nocontext DPPP_(my_mess_nocontext) +#define Perl_mess_nocontext DPPP_(my_mess_nocontext) + +#if defined(NEED_mess_nocontext) || defined(NEED_mess_nocontext_GLOBAL) +SV* +DPPP_(my_mess_nocontext)(const char* pat, ...) +{ + dTHX; + SV *sv; + va_list args; + va_start(args, pat); + sv = vmess(pat, &args); + va_end(args); + return sv; +} #endif -#ifndef SVf_UTF8 -# define SVf_UTF8 0 #endif -#ifndef newSVpvn_flags - -#if defined(NEED_newSVpvn_flags) -static SV * DPPP_(my_newSVpvn_flags)(pTHX_ const char *s, STRLEN len, U32 flags); +#ifndef mess +#if defined(NEED_mess) +static SV * DPPP_(my_mess)(pTHX_ const char * pat, ...); static #else -extern SV * DPPP_(my_newSVpvn_flags)(pTHX_ const char *s, STRLEN len, U32 flags); +extern SV * DPPP_(my_mess)(pTHX_ const char * pat, ...); #endif -#ifdef newSVpvn_flags -# undef newSVpvn_flags -#endif -#define newSVpvn_flags(a,b,c) DPPP_(my_newSVpvn_flags)(aTHX_ a,b,c) -#define Perl_newSVpvn_flags DPPP_(my_newSVpvn_flags) - -#if defined(NEED_newSVpvn_flags) || defined(NEED_newSVpvn_flags_GLOBAL) +#define Perl_mess DPPP_(my_mess) -SV * -DPPP_(my_newSVpvn_flags)(pTHX_ const char *s, STRLEN len, U32 flags) +#if defined(NEED_mess) || defined(NEED_mess_GLOBAL) +SV* +DPPP_(my_mess)(pTHX_ const char* pat, ...) { - SV *sv = newSVpvn(D_PPP_CONSTPV_ARG(s), len); - SvFLAGS(sv) |= (flags & SVf_UTF8); - return (flags & SVs_TEMP) ? sv_2mortal(sv) : sv; + SV *sv; + va_list args; + va_start(args, pat); + sv = vmess(pat, &args); + va_end(args); + return sv; } +#ifdef mess_nocontext +#define mess mess_nocontext +#else +#define mess Perl_mess_nocontext +#endif +#endif +#endif +#ifndef mess_sv +#if defined(NEED_mess_sv) +static SV * DPPP_(my_mess_sv)(pTHX_ SV * basemsg, bool consume); +static +#else +extern SV * DPPP_(my_mess_sv)(pTHX_ SV * basemsg, bool consume); #endif +#ifdef mess_sv +# undef mess_sv #endif +#define mess_sv(a,b) DPPP_(my_mess_sv)(aTHX_ a,b) +#define Perl_mess_sv DPPP_(my_mess_sv) -/* Backwards compatibility stuff... :-( */ -#if !defined(NEED_sv_2pv_flags) && defined(NEED_sv_2pv_nolen) -# define NEED_sv_2pv_flags +#if defined(NEED_mess_sv) || defined(NEED_mess_sv_GLOBAL) +SV * +DPPP_(my_mess_sv)(pTHX_ SV *basemsg, bool consume) +{ + SV *tmp; + SV *ret; + + if (SvPOK(basemsg) && SvCUR(basemsg) && *(SvEND(basemsg)-1) == '\n') { + if (consume) + return basemsg; + ret = mess(""); + SvSetSV_nosteal(ret, basemsg); + return ret; + } + + if (consume) { + sv_catsv(basemsg, mess("")); + return basemsg; + } + + ret = mess(""); + tmp = newSVsv(ret); + SvSetSV_nosteal(ret, basemsg); + sv_catsv(ret, tmp); + sv_dec(tmp); + return ret; +} #endif -#if !defined(NEED_sv_2pv_flags_GLOBAL) && defined(NEED_sv_2pv_nolen_GLOBAL) -# define NEED_sv_2pv_flags_GLOBAL #endif -/* Hint: sv_2pv_nolen - * Use the SvPV_nolen() or SvPV_nolen_const() macros instead of sv_2pv_nolen(). - */ -#ifndef sv_2pv_nolen -# define sv_2pv_nolen(sv) SvPV_nolen(sv) +#ifndef warn_nocontext +#define warn_nocontext warn #endif -#ifdef SvPVbyte - -/* Hint: SvPVbyte - * Does not work in perl-5.6.1, ppport.h implements a version - * borrowed from perl-5.7.3. - */ +#ifndef croak_nocontext +#define croak_nocontext croak +#endif -#if (PERL_BCDVERSION < 0x5007000) +#ifndef croak_no_modify +#define croak_no_modify() croak_nocontext("%s", PL_no_modify) +#define Perl_croak_no_modify() croak_no_modify() +#endif -#if defined(NEED_sv_2pvbyte) -static char * DPPP_(my_sv_2pvbyte)(pTHX_ SV *sv, STRLEN *lp); -static +#ifndef croak_memory_wrap +#if (PERL_BCDVERSION >= 0x5009002) || ( (PERL_BCDVERSION >= 0x5008006) && (PERL_BCDVERSION < 0x5009000) ) +# define croak_memory_wrap() croak_nocontext("%s", PL_memory_wrap) #else -extern char * DPPP_(my_sv_2pvbyte)(pTHX_ SV *sv, STRLEN *lp); +# define croak_memory_wrap() croak_nocontext("panic: memory wrap") +#endif #endif -#ifdef sv_2pvbyte -# undef sv_2pvbyte +#ifndef PERL_ARGS_ASSERT_CROAK_XS_USAGE +#define PERL_ARGS_ASSERT_CROAK_XS_USAGE assert(cv); assert(params) #endif -#define sv_2pvbyte(a,b) DPPP_(my_sv_2pvbyte)(aTHX_ a,b) -#define Perl_sv_2pvbyte DPPP_(my_sv_2pvbyte) -#if defined(NEED_sv_2pvbyte) || defined(NEED_sv_2pvbyte_GLOBAL) +#ifndef croak_xs_usage +#if defined(NEED_croak_xs_usage) +static void DPPP_(my_croak_xs_usage)(const CV * const cv, const char * const params); +static +#else +extern void DPPP_(my_croak_xs_usage)(const CV * const cv, const char * const params); +#endif -char * -DPPP_(my_sv_2pvbyte)(pTHX_ SV *sv, STRLEN *lp) +#define croak_xs_usage DPPP_(my_croak_xs_usage) +#define Perl_croak_xs_usage DPPP_(my_croak_xs_usage) + +#if defined(NEED_croak_xs_usage) || defined(NEED_croak_xs_usage_GLOBAL) +void +DPPP_(my_croak_xs_usage)(const CV *const cv, const char *const params) { - sv_utf8_downgrade(sv,0); - return SvPV(sv,*lp); + dTHX; + const GV *const gv = CvGV(cv); + + PERL_ARGS_ASSERT_CROAK_XS_USAGE; + + if (gv) { + const char *const gvname = GvNAME(gv); + const HV *const stash = GvSTASH(gv); + const char *const hvname = stash ? HvNAME(stash) : NULL; + + if (hvname) + croak("Usage: %s::%s(%s)", hvname, gvname, params); + else + croak("Usage: %s(%s)", gvname, params); + } else { + /* Pants. I don't think that it should be possible to get here. */ + croak("Usage: CODE(0x%" UVxf ")(%s)", PTR2UV(cv), params); + } } - +#endif #endif -/* Hint: sv_2pvbyte - * Use the SvPVbyte() macro instead of sv_2pvbyte(). - */ - -#undef SvPVbyte +#ifndef PERL_SIGNALS_UNSAFE_FLAG -#define SvPVbyte(sv, lp) \ - ((SvFLAGS(sv) & (SVf_POK|SVf_UTF8)) == (SVf_POK) \ - ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pvbyte(sv, &lp)) +#define PERL_SIGNALS_UNSAFE_FLAG 0x0001 +#if (PERL_BCDVERSION < 0x5008000) +# define D_PPP_PERL_SIGNALS_INIT PERL_SIGNALS_UNSAFE_FLAG +#else +# define D_PPP_PERL_SIGNALS_INIT 0 #endif +#if defined(NEED_PL_signals) +static U32 DPPP_(my_PL_signals) = D_PPP_PERL_SIGNALS_INIT; +#elif defined(NEED_PL_signals_GLOBAL) +U32 DPPP_(my_PL_signals) = D_PPP_PERL_SIGNALS_INIT; #else +extern U32 DPPP_(my_PL_signals); +#endif +#define PL_signals DPPP_(my_PL_signals) -# define SvPVbyte SvPV -# define sv_2pvbyte sv_2pv +#endif +/* Hint: PL_ppaddr + * Calling an op via PL_ppaddr requires passing a context argument + * for threaded builds. Since the context argument is different for + * 5.005 perls, you can use aTHXR (supplied by ppport.h), which will + * automatically be defined as the correct argument. + */ + +#if (PERL_BCDVERSION <= 0x5005005) +/* Replace: 1 */ +# define PL_ppaddr ppaddr +# define PL_no_modify no_modify +/* Replace: 0 */ #endif -#ifndef sv_2pvbyte_nolen -# define sv_2pvbyte_nolen(sv) sv_2pv_nolen(sv) + +#if (PERL_BCDVERSION <= 0x5004005) +/* Replace: 1 */ +# define PL_DBsignal DBsignal +# define PL_DBsingle DBsingle +# define PL_DBsub DBsub +# define PL_DBtrace DBtrace +# define PL_Sv Sv +# define PL_bufend bufend +# define PL_bufptr bufptr +# define PL_compiling compiling +# define PL_copline copline +# define PL_curcop curcop +# define PL_curstash curstash +# define PL_debstash debstash +# define PL_defgv defgv +# define PL_diehook diehook +# define PL_dirty dirty +# define PL_dowarn dowarn +# define PL_errgv errgv +# define PL_error_count error_count +# define PL_expect expect +# define PL_hexdigit hexdigit +# define PL_hints hints +# define PL_in_my in_my +# define PL_laststatval laststatval +# define PL_lex_state lex_state +# define PL_lex_stuff lex_stuff +# define PL_linestr linestr +# define PL_na na +# define PL_perl_destruct_level perl_destruct_level +# define PL_perldb perldb +# define PL_rsfp_filters rsfp_filters +# define PL_rsfp rsfp +# define PL_stack_base stack_base +# define PL_stack_sp stack_sp +# define PL_statcache statcache +# define PL_stdingv stdingv +# define PL_sv_arenaroot sv_arenaroot +# define PL_sv_no sv_no +# define PL_sv_undef sv_undef +# define PL_sv_yes sv_yes +# define PL_tainted tainted +# define PL_tainting tainting +# define PL_tokenbuf tokenbuf +/* Replace: 0 */ #endif -/* Hint: sv_pvn - * Always use the SvPV() macro instead of sv_pvn(). +/* Warning: PL_parser + * For perl versions earlier than 5.9.5, this is an always + * non-NULL dummy. Also, it cannot be dereferenced. Don't + * use it if you can avoid is and unless you absolutely know + * what you're doing. + * If you always check that PL_parser is non-NULL, you can + * define DPPP_PL_parser_NO_DUMMY to avoid the creation of + * a dummy parser structure. */ -/* Hint: sv_pvn_force - * Always use the SvPV_force() macro instead of sv_pvn_force(). +#if (PERL_BCDVERSION >= 0x5009005) +# ifdef DPPP_PL_parser_NO_DUMMY +# define D_PPP_my_PL_parser_var(var) ((PL_parser ? PL_parser : \ + (croak("panic: PL_parser == NULL in %s:%d", \ + __FILE__, __LINE__), (yy_parser *) NULL))->var) +# else +# ifdef DPPP_PL_parser_NO_DUMMY_WARNING +# define D_PPP_parser_dummy_warning(var) +# else +# define D_PPP_parser_dummy_warning(var) \ + warn("warning: dummy PL_" #var " used in %s:%d", __FILE__, __LINE__), +# endif +# define D_PPP_my_PL_parser_var(var) ((PL_parser ? PL_parser : \ + (D_PPP_parser_dummy_warning(var) &DPPP_(dummy_PL_parser)))->var) +#if defined(NEED_PL_parser) +static yy_parser DPPP_(dummy_PL_parser); +#elif defined(NEED_PL_parser_GLOBAL) +yy_parser DPPP_(dummy_PL_parser); +#else +extern yy_parser DPPP_(dummy_PL_parser); +#endif + +# endif + +/* PL_expect, PL_copline, PL_rsfp, PL_rsfp_filters, PL_linestr, PL_bufptr, PL_bufend, PL_lex_state, PL_lex_stuff, PL_tokenbuf depends on PL_parser */ +/* Warning: PL_expect, PL_copline, PL_rsfp, PL_rsfp_filters, PL_linestr, PL_bufptr, PL_bufend, PL_lex_state, PL_lex_stuff, PL_tokenbuf + * Do not use this variable unless you know exactly what you're + * doing. It is internal to the perl parser and may change or even + * be removed in the future. As of perl 5.9.5, you have to check + * for (PL_parser != NULL) for this variable to have any effect. + * An always non-NULL PL_parser dummy is provided for earlier + * perl versions. + * If PL_parser is NULL when you try to access this variable, a + * dummy is being accessed instead and a warning is issued unless + * you define DPPP_PL_parser_NO_DUMMY_WARNING. + * If DPPP_PL_parser_NO_DUMMY is defined, the code trying to access + * this variable will croak with a panic message. */ -/* If these are undefined, they're not handled by the core anyway */ -#ifndef SV_IMMEDIATE_UNREF -# define SV_IMMEDIATE_UNREF 0 -#endif +# define PL_expect D_PPP_my_PL_parser_var(expect) +# define PL_copline D_PPP_my_PL_parser_var(copline) +# define PL_rsfp D_PPP_my_PL_parser_var(rsfp) +# define PL_rsfp_filters D_PPP_my_PL_parser_var(rsfp_filters) +# define PL_linestr D_PPP_my_PL_parser_var(linestr) +# define PL_bufptr D_PPP_my_PL_parser_var(bufptr) +# define PL_bufend D_PPP_my_PL_parser_var(bufend) +# define PL_lex_state D_PPP_my_PL_parser_var(lex_state) +# define PL_lex_stuff D_PPP_my_PL_parser_var(lex_stuff) +# define PL_tokenbuf D_PPP_my_PL_parser_var(tokenbuf) +# define PL_in_my D_PPP_my_PL_parser_var(in_my) +# define PL_in_my_stash D_PPP_my_PL_parser_var(in_my_stash) +# define PL_error_count D_PPP_my_PL_parser_var(error_count) -#ifndef SV_GMAGIC -# define SV_GMAGIC 0 + +#else + +/* ensure that PL_parser != NULL and cannot be dereferenced */ +# define PL_parser ((void *) 1) + +#endif +#ifndef mPUSHs +# define mPUSHs(s) PUSHs(sv_2mortal(s)) #endif -#ifndef SV_COW_DROP_PV -# define SV_COW_DROP_PV 0 +#ifndef PUSHmortal +# define PUSHmortal PUSHs(sv_newmortal()) #endif -#ifndef SV_UTF8_NO_ENCODING -# define SV_UTF8_NO_ENCODING 0 +#ifndef mPUSHp +# define mPUSHp(p,l) sv_setpvn(PUSHmortal, (p), (l)) #endif -#ifndef SV_NOSTEAL -# define SV_NOSTEAL 0 +#ifndef mPUSHn +# define mPUSHn(n) sv_setnv(PUSHmortal, (NV)(n)) #endif -#ifndef SV_CONST_RETURN -# define SV_CONST_RETURN 0 +#ifndef mPUSHi +# define mPUSHi(i) sv_setiv(PUSHmortal, (IV)(i)) #endif -#ifndef SV_MUTABLE_RETURN -# define SV_MUTABLE_RETURN 0 +#ifndef mPUSHu +# define mPUSHu(u) sv_setuv(PUSHmortal, (UV)(u)) +#endif +#ifndef mXPUSHs +# define mXPUSHs(s) XPUSHs(sv_2mortal(s)) #endif -#ifndef SV_SMAGIC -# define SV_SMAGIC 0 +#ifndef XPUSHmortal +# define XPUSHmortal XPUSHs(sv_newmortal()) #endif -#ifndef SV_HAS_TRAILING_NUL -# define SV_HAS_TRAILING_NUL 0 +#ifndef mXPUSHp +# define mXPUSHp(p,l) STMT_START { EXTEND(sp,1); sv_setpvn(PUSHmortal, (p), (l)); } STMT_END #endif -#ifndef SV_COW_SHARED_HASH_KEYS -# define SV_COW_SHARED_HASH_KEYS 0 +#ifndef mXPUSHn +# define mXPUSHn(n) STMT_START { EXTEND(sp,1); sv_setnv(PUSHmortal, (NV)(n)); } STMT_END #endif -#if (PERL_BCDVERSION < 0x5007002) +#ifndef mXPUSHi +# define mXPUSHi(i) STMT_START { EXTEND(sp,1); sv_setiv(PUSHmortal, (IV)(i)); } STMT_END +#endif -#if defined(NEED_sv_2pv_flags) -static char * DPPP_(my_sv_2pv_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags); -static -#else -extern char * DPPP_(my_sv_2pv_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags); +#ifndef mXPUSHu +# define mXPUSHu(u) STMT_START { EXTEND(sp,1); sv_setuv(PUSHmortal, (UV)(u)); } STMT_END #endif -#ifdef sv_2pv_flags -# undef sv_2pv_flags +/* Replace: 1 */ +#ifndef call_sv +# define call_sv perl_call_sv #endif -#define sv_2pv_flags(a,b,c) DPPP_(my_sv_2pv_flags)(aTHX_ a,b,c) -#define Perl_sv_2pv_flags DPPP_(my_sv_2pv_flags) -#if defined(NEED_sv_2pv_flags) || defined(NEED_sv_2pv_flags_GLOBAL) +#ifndef call_pv +# define call_pv perl_call_pv +#endif -char * -DPPP_(my_sv_2pv_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags) -{ - STRLEN n_a = (STRLEN) flags; - return sv_2pv(sv, lp ? lp : &n_a); -} +#ifndef call_argv +# define call_argv perl_call_argv +#endif + +#ifndef call_method +# define call_method perl_call_method +#endif +#ifndef eval_sv +# define eval_sv perl_eval_sv +#endif +/* Replace: 0 */ +#ifndef PERL_LOADMOD_DENY +# define PERL_LOADMOD_DENY 0x1 #endif -#if defined(NEED_sv_pvn_force_flags) -static char * DPPP_(my_sv_pvn_force_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags); +#ifndef PERL_LOADMOD_NOIMPORT +# define PERL_LOADMOD_NOIMPORT 0x2 +#endif + +#ifndef PERL_LOADMOD_IMPORT_OPS +# define PERL_LOADMOD_IMPORT_OPS 0x4 +#endif + +#ifndef G_METHOD +# define G_METHOD 64 +# ifdef call_sv +# undef call_sv +# endif +# if (PERL_BCDVERSION < 0x5006000) +# define call_sv(sv, flags) ((flags) & G_METHOD ? perl_call_method((char *) SvPV_nolen_const(sv), \ + (flags) & ~G_METHOD) : perl_call_sv(sv, flags)) +# else +# define call_sv(sv, flags) ((flags) & G_METHOD ? Perl_call_method(aTHX_ (char *) SvPV_nolen_const(sv), \ + (flags) & ~G_METHOD) : Perl_call_sv(aTHX_ sv, flags)) +# endif +#endif + +/* Replace perl_eval_pv with eval_pv */ + +#ifndef eval_pv +#if defined(NEED_eval_pv) +static SV* DPPP_(my_eval_pv)(char *p, I32 croak_on_error); static #else -extern char * DPPP_(my_sv_pvn_force_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags); +extern SV* DPPP_(my_eval_pv)(char *p, I32 croak_on_error); #endif -#ifdef sv_pvn_force_flags -# undef sv_pvn_force_flags +#ifdef eval_pv +# undef eval_pv #endif -#define sv_pvn_force_flags(a,b,c) DPPP_(my_sv_pvn_force_flags)(aTHX_ a,b,c) -#define Perl_sv_pvn_force_flags DPPP_(my_sv_pvn_force_flags) +#define eval_pv(a,b) DPPP_(my_eval_pv)(aTHX_ a,b) +#define Perl_eval_pv DPPP_(my_eval_pv) -#if defined(NEED_sv_pvn_force_flags) || defined(NEED_sv_pvn_force_flags_GLOBAL) +#if defined(NEED_eval_pv) || defined(NEED_eval_pv_GLOBAL) -char * -DPPP_(my_sv_pvn_force_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags) +SV* +DPPP_(my_eval_pv)(char *p, I32 croak_on_error) { - STRLEN n_a = (STRLEN) flags; - return sv_pvn_force(sv, lp ? lp : &n_a); + dSP; + SV* sv = newSVpv(p, 0); + + PUSHMARK(sp); + eval_sv(sv, G_SCALAR); + SvREFCNT_dec(sv); + + SPAGAIN; + sv = POPs; + PUTBACK; + + if (croak_on_error && SvTRUEx(ERRSV)) + croak_sv(ERRSV); + + return sv; } #endif - #endif -#if (PERL_BCDVERSION < 0x5008008) || ( (PERL_BCDVERSION >= 0x5009000) && (PERL_BCDVERSION < 0x5009003) ) -# define DPPP_SVPV_NOLEN_LP_ARG &PL_na +#ifndef vload_module +#if defined(NEED_vload_module) +static void DPPP_(my_vload_module)(U32 flags, SV *name, SV *ver, va_list *args); +static #else -# define DPPP_SVPV_NOLEN_LP_ARG 0 -#endif -#ifndef SvPV_const -# define SvPV_const(sv, lp) SvPV_flags_const(sv, lp, SV_GMAGIC) +extern void DPPP_(my_vload_module)(U32 flags, SV *name, SV *ver, va_list *args); #endif -#ifndef SvPV_mutable -# define SvPV_mutable(sv, lp) SvPV_flags_mutable(sv, lp, SV_GMAGIC) -#endif -#ifndef SvPV_flags -# define SvPV_flags(sv, lp, flags) \ - ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ - ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pv_flags(sv, &lp, flags)) -#endif -#ifndef SvPV_flags_const -# define SvPV_flags_const(sv, lp, flags) \ - ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ - ? ((lp = SvCUR(sv)), SvPVX_const(sv)) : \ - (const char*) sv_2pv_flags(sv, &lp, flags|SV_CONST_RETURN)) +#ifdef vload_module +# undef vload_module #endif -#ifndef SvPV_flags_const_nolen -# define SvPV_flags_const_nolen(sv, flags) \ - ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ - ? SvPVX_const(sv) : \ - (const char*) sv_2pv_flags(sv, DPPP_SVPV_NOLEN_LP_ARG, flags|SV_CONST_RETURN)) +#define vload_module(a,b,c,d) DPPP_(my_vload_module)(aTHX_ a,b,c,d) +#define Perl_vload_module DPPP_(my_vload_module) + +#if defined(NEED_vload_module) || defined(NEED_vload_module_GLOBAL) + +void +DPPP_(my_vload_module)(U32 flags, SV *name, SV *ver, va_list *args) +{ + dTHR; + dVAR; + OP *veop, *imop; + + OP * const modname = newSVOP(OP_CONST, 0, name); + /* 5.005 has a somewhat hacky force_normal that doesn't croak on + SvREADONLY() if PL_compling is true. Current perls take care in + ck_require() to correctly turn off SvREADONLY before calling + force_normal_flags(). This seems a better fix than fudging PL_compling + */ + SvREADONLY_off(((SVOP*)modname)->op_sv); + modname->op_private |= OPpCONST_BARE; + if (ver) { + veop = newSVOP(OP_CONST, 0, ver); + } + else + veop = NULL; + if (flags & PERL_LOADMOD_NOIMPORT) { + imop = sawparens(newNULLLIST()); + } + else if (flags & PERL_LOADMOD_IMPORT_OPS) { + imop = va_arg(*args, OP*); + } + else { + SV *sv; + imop = NULL; + sv = va_arg(*args, SV*); + while (sv) { + imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv)); + sv = va_arg(*args, SV*); + } + } + { + const line_t ocopline = PL_copline; + COP * const ocurcop = PL_curcop; + const int oexpect = PL_expect; + +#if (PERL_BCDVERSION >= 0x5004000) + utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0), + veop, modname, imop); +#elif (PERL_BCDVERSION > 0x5003000) + utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(), + veop, modname, imop); +#else + utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(), + modname, imop); #endif -#ifndef SvPV_flags_mutable -# define SvPV_flags_mutable(sv, lp, flags) \ - ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ - ? ((lp = SvCUR(sv)), SvPVX_mutable(sv)) : \ - sv_2pv_flags(sv, &lp, flags|SV_MUTABLE_RETURN)) + PL_expect = oexpect; + PL_copline = ocopline; + PL_curcop = ocurcop; + } +} + #endif -#ifndef SvPV_force -# define SvPV_force(sv, lp) SvPV_force_flags(sv, lp, SV_GMAGIC) #endif -#ifndef SvPV_force_nolen -# define SvPV_force_nolen(sv) SvPV_force_flags_nolen(sv, SV_GMAGIC) +#ifndef load_module +#if defined(NEED_load_module) +static void DPPP_(my_load_module)(U32 flags, SV *name, SV *ver, ...); +static +#else +extern void DPPP_(my_load_module)(U32 flags, SV *name, SV *ver, ...); #endif -#ifndef SvPV_force_mutable -# define SvPV_force_mutable(sv, lp) SvPV_force_flags_mutable(sv, lp, SV_GMAGIC) +#ifdef load_module +# undef load_module #endif +#define load_module DPPP_(my_load_module) +#define Perl_load_module DPPP_(my_load_module) -#ifndef SvPV_force_nomg -# define SvPV_force_nomg(sv, lp) SvPV_force_flags(sv, lp, 0) -#endif +#if defined(NEED_load_module) || defined(NEED_load_module_GLOBAL) + +void +DPPP_(my_load_module)(U32 flags, SV *name, SV *ver, ...) +{ + va_list args; + va_start(args, ver); + vload_module(flags, name, ver, &args); + va_end(args); +} -#ifndef SvPV_force_nomg_nolen -# define SvPV_force_nomg_nolen(sv) SvPV_force_flags_nolen(sv, 0) #endif -#ifndef SvPV_force_flags -# define SvPV_force_flags(sv, lp, flags) \ - ((SvFLAGS(sv) & (SVf_POK|SVf_THINKFIRST)) == SVf_POK \ - ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_pvn_force_flags(sv, &lp, flags)) #endif -#ifndef SvPV_force_flags_nolen -# define SvPV_force_flags_nolen(sv, flags) \ - ((SvFLAGS(sv) & (SVf_POK|SVf_THINKFIRST)) == SVf_POK \ - ? SvPVX(sv) : sv_pvn_force_flags(sv, DPPP_SVPV_NOLEN_LP_ARG, flags)) +#ifndef newRV_inc +# define newRV_inc(sv) newRV(sv) /* Replace */ #endif -#ifndef SvPV_force_flags_mutable -# define SvPV_force_flags_mutable(sv, lp, flags) \ - ((SvFLAGS(sv) & (SVf_POK|SVf_THINKFIRST)) == SVf_POK \ - ? ((lp = SvCUR(sv)), SvPVX_mutable(sv)) \ - : sv_pvn_force_flags(sv, &lp, flags|SV_MUTABLE_RETURN)) + +#ifndef newRV_noinc +#if defined(NEED_newRV_noinc) +static SV * DPPP_(my_newRV_noinc)(SV *sv); +static +#else +extern SV * DPPP_(my_newRV_noinc)(SV *sv); #endif -#ifndef SvPV_nolen -# define SvPV_nolen(sv) \ - ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ - ? SvPVX(sv) : sv_2pv_flags(sv, DPPP_SVPV_NOLEN_LP_ARG, SV_GMAGIC)) + +#ifdef newRV_noinc +# undef newRV_noinc #endif -#ifndef SvPV_nolen_const -# define SvPV_nolen_const(sv) \ - ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ - ? SvPVX_const(sv) : sv_2pv_flags(sv, DPPP_SVPV_NOLEN_LP_ARG, SV_GMAGIC|SV_CONST_RETURN)) +#define newRV_noinc(a) DPPP_(my_newRV_noinc)(aTHX_ a) +#define Perl_newRV_noinc DPPP_(my_newRV_noinc) + +#if defined(NEED_newRV_noinc) || defined(NEED_newRV_noinc_GLOBAL) +SV * +DPPP_(my_newRV_noinc)(SV *sv) +{ + SV *rv = (SV *)newRV(sv); + SvREFCNT_dec(sv); + return rv; +} #endif -#ifndef SvPV_nomg -# define SvPV_nomg(sv, lp) SvPV_flags(sv, lp, 0) #endif -#ifndef SvPV_nomg_const -# define SvPV_nomg_const(sv, lp) SvPV_flags_const(sv, lp, 0) +/* Hint: newCONSTSUB + * Returns a CV* as of perl-5.7.1. This return value is not supported + * by Devel::PPPort. + */ + +/* newCONSTSUB from IO.xs is in the core starting with 5.004_63 */ +#if (PERL_BCDVERSION < 0x5004063) && (PERL_BCDVERSION != 0x5004005) +#if defined(NEED_newCONSTSUB) +static void DPPP_(my_newCONSTSUB)(HV *stash, const char *name, SV *sv); +static +#else +extern void DPPP_(my_newCONSTSUB)(HV *stash, const char *name, SV *sv); #endif -#ifndef SvPV_nomg_const_nolen -# define SvPV_nomg_const_nolen(sv) SvPV_flags_const_nolen(sv, 0) +#ifdef newCONSTSUB +# undef newCONSTSUB #endif +#define newCONSTSUB(a,b,c) DPPP_(my_newCONSTSUB)(aTHX_ a,b,c) +#define Perl_newCONSTSUB DPPP_(my_newCONSTSUB) -#ifndef SvPV_nomg_nolen -# define SvPV_nomg_nolen(sv) ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ - ? SvPVX(sv) : sv_2pv_flags(sv, DPPP_SVPV_NOLEN_LP_ARG, 0)) +#if defined(NEED_newCONSTSUB) || defined(NEED_newCONSTSUB_GLOBAL) + +/* This is just a trick to avoid a dependency of newCONSTSUB on PL_parser */ +/* (There's no PL_parser in perl < 5.005, so this is completely safe) */ +#define D_PPP_PL_copline PL_copline + +void +DPPP_(my_newCONSTSUB)(HV *stash, const char *name, SV *sv) +{ + U32 oldhints = PL_hints; + HV *old_cop_stash = PL_curcop->cop_stash; + HV *old_curstash = PL_curstash; + line_t oldline = PL_curcop->cop_line; + PL_curcop->cop_line = D_PPP_PL_copline; + + PL_hints &= ~HINT_BLOCK_SCOPE; + if (stash) + PL_curstash = PL_curcop->cop_stash = stash; + + newSUB( + +#if (PERL_BCDVERSION < 0x5003022) + start_subparse(), +#elif (PERL_BCDVERSION == 0x5003022) + start_subparse(0), +#else /* 5.003_23 onwards */ + start_subparse(FALSE, 0), #endif -#ifndef SvPV_renew -# define SvPV_renew(sv,n) STMT_START { SvLEN_set(sv, n); \ - SvPV_set((sv), (char *) saferealloc( \ - (Malloc_t)SvPVX(sv), (MEM_SIZE)((n)))); \ - } STMT_END + + newSVOP(OP_CONST, 0, newSVpv((char *) name, 0)), + newSVOP(OP_CONST, 0, &PL_sv_no), /* SvPV(&PL_sv_no) == "" -- GMB */ + newSTATEOP(0, Nullch, newSVOP(OP_CONST, 0, sv)) + ); + + PL_hints = oldhints; + PL_curcop->cop_stash = old_cop_stash; + PL_curstash = old_curstash; + PL_curcop->cop_line = oldline; +} #endif -#ifndef SvMAGIC_set -# define SvMAGIC_set(sv, val) \ - STMT_START { assert(SvTYPE(sv) >= SVt_PVMG); \ - (((XPVMG*) SvANY(sv))->xmg_magic = (val)); } STMT_END #endif -#if (PERL_BCDVERSION < 0x5009003) -#ifndef SvPVX_const -# define SvPVX_const(sv) ((const char*) (0 + SvPVX(sv))) +/* + * Boilerplate macros for initializing and accessing interpreter-local + * data from C. All statics in extensions should be reworked to use + * this, if you want to make the extension thread-safe. See ext/re/re.xs + * for an example of the use of these macros. + * + * Code that uses these macros is responsible for the following: + * 1. #define MY_CXT_KEY to a unique string, e.g. "DynaLoader_guts" + * 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. + * 4. Use the MY_CXT_INIT macro such that it is called exactly once + * (typically put in the BOOT: section). + * 5. Use the members of the my_cxt_t structure everywhere as + * MY_CXT.member. + * 6. Use the dMY_CXT macro (a declaration) in all the functions that + * access MY_CXT. + */ + +#if defined(MULTIPLICITY) || defined(PERL_OBJECT) || \ + defined(PERL_CAPI) || defined(PERL_IMPLICIT_CONTEXT) + +#ifndef START_MY_CXT + +/* 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 + +#if (PERL_BCDVERSION < 0x5004068) +/* Fetches the SV that keeps the per-interpreter data. */ +#define dMY_CXT_SV \ + SV *my_cxt_sv = get_sv(MY_CXT_KEY, FALSE) +#else /* >= perl5.004_68 */ +#define dMY_CXT_SV \ + SV *my_cxt_sv = *hv_fetch(PL_modglobal, MY_CXT_KEY, \ + sizeof(MY_CXT_KEY)-1, TRUE) +#endif /* < perl5.004_68 */ + +/* 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)) + +/* 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)) + +/* This macro must be used to access members of the my_cxt_t structure. + * e.g. MYCXT.some_data */ +#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 + +#endif /* START_MY_CXT */ + +#ifndef MY_CXT_CLONE +/* 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)) #endif -#ifndef SvPVX_mutable -# define SvPVX_mutable(sv) (0 + SvPVX(sv)) +#else /* single interpreter */ + +#ifndef START_MY_CXT + +#define START_MY_CXT static my_cxt_t my_cxt; +#define dMY_CXT_SV dNOOP +#define dMY_CXT dNOOP +#define MY_CXT_INIT 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 /* START_MY_CXT */ + +#ifndef MY_CXT_CLONE +#define MY_CXT_CLONE NOOP #endif -#ifndef SvRV_set -# define SvRV_set(sv, val) \ - STMT_START { assert(SvTYPE(sv) >= SVt_RV); \ - (((XRV*) SvANY(sv))->xrv_rv = (val)); } STMT_END + #endif -#else -#ifndef SvPVX_const -# define SvPVX_const(sv) ((const char*)((sv)->sv_u.svu_pv)) +#ifndef SvREFCNT_inc +# ifdef PERL_USE_GCC_BRACE_GROUPS +# define SvREFCNT_inc(sv) \ + ({ \ + SV * const _sv = (SV*)(sv); \ + if (_sv) \ + (SvREFCNT(_sv))++; \ + _sv; \ + }) +# else +# define SvREFCNT_inc(sv) \ + ((PL_Sv=(SV*)(sv)) ? (++(SvREFCNT(PL_Sv)),PL_Sv) : NULL) +# endif #endif -#ifndef SvPVX_mutable -# define SvPVX_mutable(sv) ((sv)->sv_u.svu_pv) +#ifndef SvREFCNT_inc_simple +# ifdef PERL_USE_GCC_BRACE_GROUPS +# define SvREFCNT_inc_simple(sv) \ + ({ \ + if (sv) \ + (SvREFCNT(sv))++; \ + (SV *)(sv); \ + }) +# else +# define SvREFCNT_inc_simple(sv) \ + ((sv) ? (SvREFCNT(sv)++,(SV*)(sv)) : NULL) +# endif #endif -#ifndef SvRV_set -# define SvRV_set(sv, val) \ - STMT_START { assert(SvTYPE(sv) >= SVt_RV); \ - ((sv)->sv_u.svu_rv = (val)); } STMT_END + +#ifndef SvREFCNT_inc_NN +# ifdef PERL_USE_GCC_BRACE_GROUPS +# define SvREFCNT_inc_NN(sv) \ + ({ \ + SV * const _sv = (SV*)(sv); \ + SvREFCNT(_sv)++; \ + _sv; \ + }) +# else +# define SvREFCNT_inc_NN(sv) \ + (PL_Sv=(SV*)(sv),++(SvREFCNT(PL_Sv)),PL_Sv) +# endif #endif +#ifndef SvREFCNT_inc_void +# ifdef PERL_USE_GCC_BRACE_GROUPS +# define SvREFCNT_inc_void(sv) \ + ({ \ + SV * const _sv = (SV*)(sv); \ + if (_sv) \ + (void)(SvREFCNT(_sv)++); \ + }) +# else +# define SvREFCNT_inc_void(sv) \ + (void)((PL_Sv=(SV*)(sv)) ? ++(SvREFCNT(PL_Sv)) : 0) +# endif #endif -#ifndef SvSTASH_set -# define SvSTASH_set(sv, val) \ - STMT_START { assert(SvTYPE(sv) >= SVt_PVMG); \ - (((XPVMG*) SvANY(sv))->xmg_stash = (val)); } STMT_END +#ifndef SvREFCNT_inc_simple_void +# define SvREFCNT_inc_simple_void(sv) STMT_START { if (sv) SvREFCNT(sv)++; } STMT_END #endif -#if (PERL_BCDVERSION < 0x5004000) -#ifndef SvUV_set -# define SvUV_set(sv, val) \ - STMT_START { assert(SvTYPE(sv) == SVt_IV || SvTYPE(sv) >= SVt_PVIV); \ - (((XPVIV*) SvANY(sv))->xiv_iv = (IV) (val)); } STMT_END +#ifndef SvREFCNT_inc_simple_NN +# define SvREFCNT_inc_simple_NN(sv) (++SvREFCNT(sv), (SV*)(sv)) #endif -#else -#ifndef SvUV_set -# define SvUV_set(sv, val) \ - STMT_START { assert(SvTYPE(sv) == SVt_IV || SvTYPE(sv) >= SVt_PVIV); \ - (((XPVUV*) SvANY(sv))->xuv_uv = (val)); } STMT_END +#ifndef SvREFCNT_inc_void_NN +# define SvREFCNT_inc_void_NN(sv) (void)(++SvREFCNT((SV*)(sv))) #endif +#ifndef SvREFCNT_inc_simple_void_NN +# define SvREFCNT_inc_simple_void_NN(sv) (void)(++SvREFCNT((SV*)(sv))) #endif -#if (PERL_BCDVERSION >= 0x5004000) && !defined(vnewSVpvf) -#if defined(NEED_vnewSVpvf) -static SV * DPPP_(my_vnewSVpvf)(pTHX_ const char *pat, va_list *args); +#ifndef newSV_type + +#if defined(NEED_newSV_type) +static SV* DPPP_(my_newSV_type)(pTHX_ svtype const t); static #else -extern SV * DPPP_(my_vnewSVpvf)(pTHX_ const char *pat, va_list *args); +extern SV* DPPP_(my_newSV_type)(pTHX_ svtype const t); #endif -#ifdef vnewSVpvf -# undef vnewSVpvf +#ifdef newSV_type +# undef newSV_type #endif -#define vnewSVpvf(a,b) DPPP_(my_vnewSVpvf)(aTHX_ a,b) -#define Perl_vnewSVpvf DPPP_(my_vnewSVpvf) +#define newSV_type(a) DPPP_(my_newSV_type)(aTHX_ a) +#define Perl_newSV_type DPPP_(my_newSV_type) -#if defined(NEED_vnewSVpvf) || defined(NEED_vnewSVpvf_GLOBAL) +#if defined(NEED_newSV_type) || defined(NEED_newSV_type_GLOBAL) -SV * -DPPP_(my_vnewSVpvf)(pTHX_ const char *pat, va_list *args) +SV* +DPPP_(my_newSV_type)(pTHX_ svtype const t) { - register SV *sv = newSV(0); - sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); + SV* const sv = newSV(0); + sv_upgrade(sv, t); return sv; } #endif -#endif - -#if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_vcatpvf) -# define sv_vcatpvf(sv, pat, args) sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)) -#endif -#if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_vsetpvf) -# define sv_vsetpvf(sv, pat, args) sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)) #endif -#if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_catpvf_mg) -#if defined(NEED_sv_catpvf_mg) -static void DPPP_(my_sv_catpvf_mg)(pTHX_ SV *sv, const char *pat, ...); -static +#if (PERL_BCDVERSION < 0x5006000) +# define D_PPP_CONSTPV_ARG(x) ((char *) (x)) #else -extern void DPPP_(my_sv_catpvf_mg)(pTHX_ SV *sv, const char *pat, ...); +# define D_PPP_CONSTPV_ARG(x) (x) #endif - -#define Perl_sv_catpvf_mg DPPP_(my_sv_catpvf_mg) - -#if defined(NEED_sv_catpvf_mg) || defined(NEED_sv_catpvf_mg_GLOBAL) - -void -DPPP_(my_sv_catpvf_mg)(pTHX_ SV *sv, const char *pat, ...) -{ - va_list args; - va_start(args, pat); - sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); - SvSETMAGIC(sv); - va_end(args); -} - +#ifndef newSVpvn +# define newSVpvn(data,len) ((data) \ + ? ((len) ? newSVpv((data), (len)) : newSVpv("", 0)) \ + : newSV(0)) +#endif +#ifndef newSVpvn_utf8 +# define newSVpvn_utf8(s, len, u) newSVpvn_flags((s), (len), (u) ? SVf_UTF8 : 0) #endif +#ifndef SVf_UTF8 +# define SVf_UTF8 0 #endif -#ifdef PERL_IMPLICIT_CONTEXT -#if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_catpvf_mg_nocontext) -#if defined(NEED_sv_catpvf_mg_nocontext) -static void DPPP_(my_sv_catpvf_mg_nocontext)(SV *sv, const char *pat, ...); +#ifndef newSVpvn_flags + +#if defined(NEED_newSVpvn_flags) +static SV * DPPP_(my_newSVpvn_flags)(pTHX_ const char *s, STRLEN len, U32 flags); static #else -extern void DPPP_(my_sv_catpvf_mg_nocontext)(SV *sv, const char *pat, ...); +extern SV * DPPP_(my_newSVpvn_flags)(pTHX_ const char *s, STRLEN len, U32 flags); #endif -#define sv_catpvf_mg_nocontext DPPP_(my_sv_catpvf_mg_nocontext) -#define Perl_sv_catpvf_mg_nocontext DPPP_(my_sv_catpvf_mg_nocontext) +#ifdef newSVpvn_flags +# undef newSVpvn_flags +#endif +#define newSVpvn_flags(a,b,c) DPPP_(my_newSVpvn_flags)(aTHX_ a,b,c) +#define Perl_newSVpvn_flags DPPP_(my_newSVpvn_flags) -#if defined(NEED_sv_catpvf_mg_nocontext) || defined(NEED_sv_catpvf_mg_nocontext_GLOBAL) +#if defined(NEED_newSVpvn_flags) || defined(NEED_newSVpvn_flags_GLOBAL) -void -DPPP_(my_sv_catpvf_mg_nocontext)(SV *sv, const char *pat, ...) +SV * +DPPP_(my_newSVpvn_flags)(pTHX_ const char *s, STRLEN len, U32 flags) { - dTHX; - va_list args; - va_start(args, pat); - sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); - SvSETMAGIC(sv); - va_end(args); + SV *sv = newSVpvn(D_PPP_CONSTPV_ARG(s), len); + SvFLAGS(sv) |= (flags & SVf_UTF8); + return (flags & SVs_TEMP) ? sv_2mortal(sv) : sv; } #endif -#endif + #endif -/* sv_catpvf_mg depends on sv_catpvf_mg_nocontext */ -#ifndef sv_catpvf_mg -# ifdef PERL_IMPLICIT_CONTEXT -# define sv_catpvf_mg Perl_sv_catpvf_mg_nocontext -# else -# define sv_catpvf_mg Perl_sv_catpvf_mg -# endif +/* Backwards compatibility stuff... :-( */ +#if !defined(NEED_sv_2pv_flags) && defined(NEED_sv_2pv_nolen) +# define NEED_sv_2pv_flags +#endif +#if !defined(NEED_sv_2pv_flags_GLOBAL) && defined(NEED_sv_2pv_nolen_GLOBAL) +# define NEED_sv_2pv_flags_GLOBAL #endif -#if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_vcatpvf_mg) -# define sv_vcatpvf_mg(sv, pat, args) \ - STMT_START { \ - sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); \ - SvSETMAGIC(sv); \ - } STMT_END +/* Hint: sv_2pv_nolen + * Use the SvPV_nolen() or SvPV_nolen_const() macros instead of sv_2pv_nolen(). + */ +#ifndef sv_2pv_nolen +# define sv_2pv_nolen(sv) SvPV_nolen(sv) #endif -#if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_setpvf_mg) -#if defined(NEED_sv_setpvf_mg) -static void DPPP_(my_sv_setpvf_mg)(pTHX_ SV *sv, const char *pat, ...); +#ifdef SvPVbyte + +/* Hint: SvPVbyte + * Does not work in perl-5.6.1, ppport.h implements a version + * borrowed from perl-5.7.3. + */ + +#if (PERL_BCDVERSION < 0x5007000) + +#if defined(NEED_sv_2pvbyte) +static char * DPPP_(my_sv_2pvbyte)(pTHX_ SV *sv, STRLEN *lp); static #else -extern void DPPP_(my_sv_setpvf_mg)(pTHX_ SV *sv, const char *pat, ...); +extern char * DPPP_(my_sv_2pvbyte)(pTHX_ SV *sv, STRLEN *lp); #endif -#define Perl_sv_setpvf_mg DPPP_(my_sv_setpvf_mg) +#ifdef sv_2pvbyte +# undef sv_2pvbyte +#endif +#define sv_2pvbyte(a,b) DPPP_(my_sv_2pvbyte)(aTHX_ a,b) +#define Perl_sv_2pvbyte DPPP_(my_sv_2pvbyte) -#if defined(NEED_sv_setpvf_mg) || defined(NEED_sv_setpvf_mg_GLOBAL) +#if defined(NEED_sv_2pvbyte) || defined(NEED_sv_2pvbyte_GLOBAL) -void -DPPP_(my_sv_setpvf_mg)(pTHX_ SV *sv, const char *pat, ...) +char * +DPPP_(my_sv_2pvbyte)(pTHX_ SV *sv, STRLEN *lp) { - va_list args; - va_start(args, pat); - sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); - SvSETMAGIC(sv); - va_end(args); + sv_utf8_downgrade(sv,0); + return SvPV(sv,*lp); } #endif + +/* Hint: sv_2pvbyte + * Use the SvPVbyte() macro instead of sv_2pvbyte(). + */ + +#undef SvPVbyte + +#define SvPVbyte(sv, lp) \ + ((SvFLAGS(sv) & (SVf_POK|SVf_UTF8)) == (SVf_POK) \ + ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pvbyte(sv, &lp)) + #endif -#ifdef PERL_IMPLICIT_CONTEXT -#if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_setpvf_mg_nocontext) -#if defined(NEED_sv_setpvf_mg_nocontext) -static void DPPP_(my_sv_setpvf_mg_nocontext)(SV *sv, const char *pat, ...); -static #else -extern void DPPP_(my_sv_setpvf_mg_nocontext)(SV *sv, const char *pat, ...); + +# define SvPVbyte SvPV +# define sv_2pvbyte sv_2pv + +#endif +#ifndef sv_2pvbyte_nolen +# define sv_2pvbyte_nolen(sv) sv_2pv_nolen(sv) #endif -#define sv_setpvf_mg_nocontext DPPP_(my_sv_setpvf_mg_nocontext) -#define Perl_sv_setpvf_mg_nocontext DPPP_(my_sv_setpvf_mg_nocontext) +/* Hint: sv_pvn + * Always use the SvPV() macro instead of sv_pvn(). + */ -#if defined(NEED_sv_setpvf_mg_nocontext) || defined(NEED_sv_setpvf_mg_nocontext_GLOBAL) +/* Hint: sv_pvn_force + * Always use the SvPV_force() macro instead of sv_pvn_force(). + */ -void -DPPP_(my_sv_setpvf_mg_nocontext)(SV *sv, const char *pat, ...) -{ - dTHX; - va_list args; - va_start(args, pat); - sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); - SvSETMAGIC(sv); - va_end(args); -} +/* If these are undefined, they're not handled by the core anyway */ +#ifndef SV_IMMEDIATE_UNREF +# define SV_IMMEDIATE_UNREF 0 +#endif + +#ifndef SV_GMAGIC +# define SV_GMAGIC 0 +#endif +#ifndef SV_COW_DROP_PV +# define SV_COW_DROP_PV 0 #endif + +#ifndef SV_UTF8_NO_ENCODING +# define SV_UTF8_NO_ENCODING 0 #endif + +#ifndef SV_NOSTEAL +# define SV_NOSTEAL 0 #endif -/* sv_setpvf_mg depends on sv_setpvf_mg_nocontext */ -#ifndef sv_setpvf_mg -# ifdef PERL_IMPLICIT_CONTEXT -# define sv_setpvf_mg Perl_sv_setpvf_mg_nocontext -# else -# define sv_setpvf_mg Perl_sv_setpvf_mg -# endif +#ifndef SV_CONST_RETURN +# define SV_CONST_RETURN 0 #endif -#if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_vsetpvf_mg) -# define sv_vsetpvf_mg(sv, pat, args) \ - STMT_START { \ - sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); \ - SvSETMAGIC(sv); \ - } STMT_END +#ifndef SV_MUTABLE_RETURN +# define SV_MUTABLE_RETURN 0 +#endif + +#ifndef SV_SMAGIC +# define SV_SMAGIC 0 #endif -/* Hint: newSVpvn_share - * The SVs created by this function only mimic the behaviour of - * shared PVs without really being shared. Only use if you know - * what you're doing. - */ +#ifndef SV_HAS_TRAILING_NUL +# define SV_HAS_TRAILING_NUL 0 +#endif -#ifndef newSVpvn_share +#ifndef SV_COW_SHARED_HASH_KEYS +# define SV_COW_SHARED_HASH_KEYS 0 +#endif -#if defined(NEED_newSVpvn_share) -static SV * DPPP_(my_newSVpvn_share)(pTHX_ const char *src, I32 len, U32 hash); +#if (PERL_BCDVERSION < 0x5007002) + +#if defined(NEED_sv_2pv_flags) +static char * DPPP_(my_sv_2pv_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags); static #else -extern SV * DPPP_(my_newSVpvn_share)(pTHX_ const char *src, I32 len, U32 hash); +extern char * DPPP_(my_sv_2pv_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags); #endif -#ifdef newSVpvn_share -# undef newSVpvn_share +#ifdef sv_2pv_flags +# undef sv_2pv_flags #endif -#define newSVpvn_share(a,b,c) DPPP_(my_newSVpvn_share)(aTHX_ a,b,c) -#define Perl_newSVpvn_share DPPP_(my_newSVpvn_share) +#define sv_2pv_flags(a,b,c) DPPP_(my_sv_2pv_flags)(aTHX_ a,b,c) +#define Perl_sv_2pv_flags DPPP_(my_sv_2pv_flags) -#if defined(NEED_newSVpvn_share) || defined(NEED_newSVpvn_share_GLOBAL) +#if defined(NEED_sv_2pv_flags) || defined(NEED_sv_2pv_flags_GLOBAL) -SV * -DPPP_(my_newSVpvn_share)(pTHX_ const char *src, I32 len, U32 hash) +char * +DPPP_(my_sv_2pv_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags) { - SV *sv; - if (len < 0) - len = -len; - if (!hash) - PERL_HASH(hash, (char*) src, len); - sv = newSVpvn((char *) src, len); - sv_upgrade(sv, SVt_PVIV); - SvIVX(sv) = hash; - SvREADONLY_on(sv); - SvPOK_on(sv); - return sv; + STRLEN n_a = (STRLEN) flags; + return sv_2pv(sv, lp ? lp : &n_a); } #endif -#endif -#ifndef SvSHARED_HASH -# define SvSHARED_HASH(sv) (0 + SvUVX(sv)) -#endif -#ifndef HvNAME_get -# define HvNAME_get(hv) HvNAME(hv) -#endif -#ifndef HvNAMELEN_get -# define HvNAMELEN_get(hv) (HvNAME_get(hv) ? (I32)strlen(HvNAME_get(hv)) : 0) -#endif - -#ifndef gv_fetchpvn_flags -#if defined(NEED_gv_fetchpvn_flags) -static GV* DPPP_(my_gv_fetchpvn_flags)(pTHX_ const char* name, STRLEN len, int flags, int types); +#if defined(NEED_sv_pvn_force_flags) +static char * DPPP_(my_sv_pvn_force_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags); static #else -extern GV* DPPP_(my_gv_fetchpvn_flags)(pTHX_ const char* name, STRLEN len, int flags, int types); +extern char * DPPP_(my_sv_pvn_force_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags); #endif -#ifdef gv_fetchpvn_flags -# undef gv_fetchpvn_flags +#ifdef sv_pvn_force_flags +# undef sv_pvn_force_flags #endif -#define gv_fetchpvn_flags(a,b,c,d) DPPP_(my_gv_fetchpvn_flags)(aTHX_ a,b,c,d) -#define Perl_gv_fetchpvn_flags DPPP_(my_gv_fetchpvn_flags) +#define sv_pvn_force_flags(a,b,c) DPPP_(my_sv_pvn_force_flags)(aTHX_ a,b,c) +#define Perl_sv_pvn_force_flags DPPP_(my_sv_pvn_force_flags) -#if defined(NEED_gv_fetchpvn_flags) || defined(NEED_gv_fetchpvn_flags_GLOBAL) +#if defined(NEED_sv_pvn_force_flags) || defined(NEED_sv_pvn_force_flags_GLOBAL) -GV* -DPPP_(my_gv_fetchpvn_flags)(pTHX_ const char* name, STRLEN len, int flags, int types) { - char *namepv = savepvn(name, len); - GV* stash = gv_fetchpv(namepv, TRUE, SVt_PVHV); - Safefree(namepv); - return stash; +char * +DPPP_(my_sv_pvn_force_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags) +{ + STRLEN n_a = (STRLEN) flags; + return sv_pvn_force(sv, lp ? lp : &n_a); } #endif -#endif -#ifndef GvSVn -# define GvSVn(gv) GvSV(gv) -#endif -#ifndef isGV_with_GP -# define isGV_with_GP(gv) isGV(gv) #endif -#ifndef gv_fetchsv -# define gv_fetchsv(name, flags, svt) gv_fetchpv(SvPV_nolen_const(name), flags, svt) +#if (PERL_BCDVERSION < 0x5008008) || ( (PERL_BCDVERSION >= 0x5009000) && (PERL_BCDVERSION < 0x5009003) ) +# define DPPP_SVPV_NOLEN_LP_ARG &PL_na +#else +# define DPPP_SVPV_NOLEN_LP_ARG 0 #endif -#ifndef get_cvn_flags -# define get_cvn_flags(name, namelen, flags) get_cv(name, flags) +#ifndef SvPV_const +# define SvPV_const(sv, lp) SvPV_flags_const(sv, lp, SV_GMAGIC) #endif -#ifndef gv_init_pvn -# define gv_init_pvn(gv, stash, ptr, len, flags) gv_init(gv, stash, ptr, len, flags & GV_ADDMULTI ? TRUE : FALSE) +#ifndef SvPV_mutable +# define SvPV_mutable(sv, lp) SvPV_flags_mutable(sv, lp, SV_GMAGIC) #endif -#ifndef WARN_ALL -# define WARN_ALL 0 +#ifndef SvPV_flags +# define SvPV_flags(sv, lp, flags) \ + ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ + ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pv_flags(sv, &lp, flags)) #endif - -#ifndef WARN_CLOSURE -# define WARN_CLOSURE 1 +#ifndef SvPV_flags_const +# define SvPV_flags_const(sv, lp, flags) \ + ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ + ? ((lp = SvCUR(sv)), SvPVX_const(sv)) : \ + (const char*) sv_2pv_flags(sv, &lp, flags|SV_CONST_RETURN)) #endif - -#ifndef WARN_DEPRECATED -# define WARN_DEPRECATED 2 +#ifndef SvPV_flags_const_nolen +# define SvPV_flags_const_nolen(sv, flags) \ + ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ + ? SvPVX_const(sv) : \ + (const char*) sv_2pv_flags(sv, DPPP_SVPV_NOLEN_LP_ARG, flags|SV_CONST_RETURN)) #endif - -#ifndef WARN_EXITING -# define WARN_EXITING 3 +#ifndef SvPV_flags_mutable +# define SvPV_flags_mutable(sv, lp, flags) \ + ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ + ? ((lp = SvCUR(sv)), SvPVX_mutable(sv)) : \ + sv_2pv_flags(sv, &lp, flags|SV_MUTABLE_RETURN)) #endif - -#ifndef WARN_GLOB -# define WARN_GLOB 4 +#ifndef SvPV_force +# define SvPV_force(sv, lp) SvPV_force_flags(sv, lp, SV_GMAGIC) #endif -#ifndef WARN_IO -# define WARN_IO 5 +#ifndef SvPV_force_nolen +# define SvPV_force_nolen(sv) SvPV_force_flags_nolen(sv, SV_GMAGIC) #endif -#ifndef WARN_CLOSED -# define WARN_CLOSED 6 +#ifndef SvPV_force_mutable +# define SvPV_force_mutable(sv, lp) SvPV_force_flags_mutable(sv, lp, SV_GMAGIC) #endif -#ifndef WARN_EXEC -# define WARN_EXEC 7 +#ifndef SvPV_force_nomg +# define SvPV_force_nomg(sv, lp) SvPV_force_flags(sv, lp, 0) #endif -#ifndef WARN_LAYER -# define WARN_LAYER 8 +#ifndef SvPV_force_nomg_nolen +# define SvPV_force_nomg_nolen(sv) SvPV_force_flags_nolen(sv, 0) #endif - -#ifndef WARN_NEWLINE -# define WARN_NEWLINE 9 +#ifndef SvPV_force_flags +# define SvPV_force_flags(sv, lp, flags) \ + ((SvFLAGS(sv) & (SVf_POK|SVf_THINKFIRST)) == SVf_POK \ + ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_pvn_force_flags(sv, &lp, flags)) #endif - -#ifndef WARN_PIPE -# define WARN_PIPE 10 +#ifndef SvPV_force_flags_nolen +# define SvPV_force_flags_nolen(sv, flags) \ + ((SvFLAGS(sv) & (SVf_POK|SVf_THINKFIRST)) == SVf_POK \ + ? SvPVX(sv) : sv_pvn_force_flags(sv, DPPP_SVPV_NOLEN_LP_ARG, flags)) #endif - -#ifndef WARN_UNOPENED -# define WARN_UNOPENED 11 +#ifndef SvPV_force_flags_mutable +# define SvPV_force_flags_mutable(sv, lp, flags) \ + ((SvFLAGS(sv) & (SVf_POK|SVf_THINKFIRST)) == SVf_POK \ + ? ((lp = SvCUR(sv)), SvPVX_mutable(sv)) \ + : sv_pvn_force_flags(sv, &lp, flags|SV_MUTABLE_RETURN)) #endif - -#ifndef WARN_MISC -# define WARN_MISC 12 +#ifndef SvPV_nolen +# define SvPV_nolen(sv) \ + ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ + ? SvPVX(sv) : sv_2pv_flags(sv, DPPP_SVPV_NOLEN_LP_ARG, SV_GMAGIC)) #endif - -#ifndef WARN_NUMERIC -# define WARN_NUMERIC 13 +#ifndef SvPV_nolen_const +# define SvPV_nolen_const(sv) \ + ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ + ? SvPVX_const(sv) : sv_2pv_flags(sv, DPPP_SVPV_NOLEN_LP_ARG, SV_GMAGIC|SV_CONST_RETURN)) #endif - -#ifndef WARN_ONCE -# define WARN_ONCE 14 +#ifndef SvPV_nomg +# define SvPV_nomg(sv, lp) SvPV_flags(sv, lp, 0) #endif -#ifndef WARN_OVERFLOW -# define WARN_OVERFLOW 15 +#ifndef SvPV_nomg_const +# define SvPV_nomg_const(sv, lp) SvPV_flags_const(sv, lp, 0) #endif -#ifndef WARN_PACK -# define WARN_PACK 16 +#ifndef SvPV_nomg_const_nolen +# define SvPV_nomg_const_nolen(sv) SvPV_flags_const_nolen(sv, 0) #endif -#ifndef WARN_PORTABLE -# define WARN_PORTABLE 17 +#ifndef SvPV_nomg_nolen +# define SvPV_nomg_nolen(sv) ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ + ? SvPVX(sv) : sv_2pv_flags(sv, DPPP_SVPV_NOLEN_LP_ARG, 0)) #endif - -#ifndef WARN_RECURSION -# define WARN_RECURSION 18 +#ifndef SvPV_renew +# define SvPV_renew(sv,n) STMT_START { SvLEN_set(sv, n); \ + SvPV_set((sv), (char *) saferealloc( \ + (Malloc_t)SvPVX(sv), (MEM_SIZE)((n)))); \ + } STMT_END #endif - -#ifndef WARN_REDEFINE -# define WARN_REDEFINE 19 +#ifndef SvMAGIC_set +# define SvMAGIC_set(sv, val) \ + STMT_START { assert(SvTYPE(sv) >= SVt_PVMG); \ + (((XPVMG*) SvANY(sv))->xmg_magic = (val)); } STMT_END #endif -#ifndef WARN_REGEXP -# define WARN_REGEXP 20 +#if (PERL_BCDVERSION < 0x5009003) +#ifndef SvPVX_const +# define SvPVX_const(sv) ((const char*) (0 + SvPVX(sv))) #endif -#ifndef WARN_SEVERE -# define WARN_SEVERE 21 +#ifndef SvPVX_mutable +# define SvPVX_mutable(sv) (0 + SvPVX(sv)) #endif - -#ifndef WARN_DEBUGGING -# define WARN_DEBUGGING 22 +#ifndef SvRV_set +# define SvRV_set(sv, val) \ + STMT_START { assert(SvTYPE(sv) >= SVt_RV); \ + (((XRV*) SvANY(sv))->xrv_rv = (val)); } STMT_END #endif -#ifndef WARN_INPLACE -# define WARN_INPLACE 23 +#else +#ifndef SvPVX_const +# define SvPVX_const(sv) ((const char*)((sv)->sv_u.svu_pv)) #endif -#ifndef WARN_INTERNAL -# define WARN_INTERNAL 24 +#ifndef SvPVX_mutable +# define SvPVX_mutable(sv) ((sv)->sv_u.svu_pv) +#endif +#ifndef SvRV_set +# define SvRV_set(sv, val) \ + STMT_START { assert(SvTYPE(sv) >= SVt_RV); \ + ((sv)->sv_u.svu_rv = (val)); } STMT_END #endif -#ifndef WARN_MALLOC -# define WARN_MALLOC 25 #endif - -#ifndef WARN_SIGNAL -# define WARN_SIGNAL 26 +#ifndef SvSTASH_set +# define SvSTASH_set(sv, val) \ + STMT_START { assert(SvTYPE(sv) >= SVt_PVMG); \ + (((XPVMG*) SvANY(sv))->xmg_stash = (val)); } STMT_END #endif -#ifndef WARN_SUBSTR -# define WARN_SUBSTR 27 +#if (PERL_BCDVERSION < 0x5004000) +#ifndef SvUV_set +# define SvUV_set(sv, val) \ + STMT_START { assert(SvTYPE(sv) == SVt_IV || SvTYPE(sv) >= SVt_PVIV); \ + (((XPVIV*) SvANY(sv))->xiv_iv = (IV) (val)); } STMT_END #endif -#ifndef WARN_SYNTAX -# define WARN_SYNTAX 28 +#else +#ifndef SvUV_set +# define SvUV_set(sv, val) \ + STMT_START { assert(SvTYPE(sv) == SVt_IV || SvTYPE(sv) >= SVt_PVIV); \ + (((XPVUV*) SvANY(sv))->xuv_uv = (val)); } STMT_END #endif -#ifndef WARN_AMBIGUOUS -# define WARN_AMBIGUOUS 29 #endif -#ifndef WARN_BAREWORD -# define WARN_BAREWORD 30 +#if (PERL_BCDVERSION >= 0x5004000) && !defined(vnewSVpvf) +#if defined(NEED_vnewSVpvf) +static SV * DPPP_(my_vnewSVpvf)(pTHX_ const char *pat, va_list *args); +static +#else +extern SV * DPPP_(my_vnewSVpvf)(pTHX_ const char *pat, va_list *args); #endif -#ifndef WARN_DIGIT -# define WARN_DIGIT 31 +#ifdef vnewSVpvf +# undef vnewSVpvf #endif +#define vnewSVpvf(a,b) DPPP_(my_vnewSVpvf)(aTHX_ a,b) +#define Perl_vnewSVpvf DPPP_(my_vnewSVpvf) -#ifndef WARN_PARENTHESIS -# define WARN_PARENTHESIS 32 -#endif +#if defined(NEED_vnewSVpvf) || defined(NEED_vnewSVpvf_GLOBAL) -#ifndef WARN_PRECEDENCE -# define WARN_PRECEDENCE 33 -#endif +SV * +DPPP_(my_vnewSVpvf)(pTHX_ const char *pat, va_list *args) +{ + register SV *sv = newSV(0); + sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); + return sv; +} -#ifndef WARN_PRINTF -# define WARN_PRINTF 34 #endif - -#ifndef WARN_PROTOTYPE -# define WARN_PROTOTYPE 35 #endif -#ifndef WARN_QW -# define WARN_QW 36 +#if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_vcatpvf) +# define sv_vcatpvf(sv, pat, args) sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)) #endif -#ifndef WARN_RESERVED -# define WARN_RESERVED 37 +#if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_vsetpvf) +# define sv_vsetpvf(sv, pat, args) sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)) #endif -#ifndef WARN_SEMICOLON -# define WARN_SEMICOLON 38 +#if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_catpvf_mg) +#if defined(NEED_sv_catpvf_mg) +static void DPPP_(my_sv_catpvf_mg)(pTHX_ SV *sv, const char *pat, ...); +static +#else +extern void DPPP_(my_sv_catpvf_mg)(pTHX_ SV *sv, const char *pat, ...); #endif -#ifndef WARN_TAINT -# define WARN_TAINT 39 -#endif +#define Perl_sv_catpvf_mg DPPP_(my_sv_catpvf_mg) -#ifndef WARN_THREADS -# define WARN_THREADS 40 -#endif +#if defined(NEED_sv_catpvf_mg) || defined(NEED_sv_catpvf_mg_GLOBAL) -#ifndef WARN_UNINITIALIZED -# define WARN_UNINITIALIZED 41 -#endif +void +DPPP_(my_sv_catpvf_mg)(pTHX_ SV *sv, const char *pat, ...) +{ + va_list args; + va_start(args, pat); + sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); + SvSETMAGIC(sv); + va_end(args); +} -#ifndef WARN_UNPACK -# define WARN_UNPACK 42 #endif - -#ifndef WARN_UNTIE -# define WARN_UNTIE 43 #endif -#ifndef WARN_UTF8 -# define WARN_UTF8 44 +#ifdef PERL_IMPLICIT_CONTEXT +#if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_catpvf_mg_nocontext) +#if defined(NEED_sv_catpvf_mg_nocontext) +static void DPPP_(my_sv_catpvf_mg_nocontext)(SV *sv, const char *pat, ...); +static +#else +extern void DPPP_(my_sv_catpvf_mg_nocontext)(SV *sv, const char *pat, ...); #endif -#ifndef WARN_VOID -# define WARN_VOID 45 -#endif +#define sv_catpvf_mg_nocontext DPPP_(my_sv_catpvf_mg_nocontext) +#define Perl_sv_catpvf_mg_nocontext DPPP_(my_sv_catpvf_mg_nocontext) + +#if defined(NEED_sv_catpvf_mg_nocontext) || defined(NEED_sv_catpvf_mg_nocontext_GLOBAL) + +void +DPPP_(my_sv_catpvf_mg_nocontext)(SV *sv, const char *pat, ...) +{ + dTHX; + va_list args; + va_start(args, pat); + sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); + SvSETMAGIC(sv); + va_end(args); +} -#ifndef WARN_ASSERTIONS -# define WARN_ASSERTIONS 46 #endif -#ifndef packWARN -# define packWARN(a) (a) +#endif #endif -#ifndef ckWARN -# ifdef G_WARN_ON -# define ckWARN(a) (PL_dowarn & G_WARN_ON) +/* sv_catpvf_mg depends on sv_catpvf_mg_nocontext */ +#ifndef sv_catpvf_mg +# ifdef PERL_IMPLICIT_CONTEXT +# define sv_catpvf_mg Perl_sv_catpvf_mg_nocontext # else -# define ckWARN(a) PL_dowarn +# define sv_catpvf_mg Perl_sv_catpvf_mg # endif #endif -#if (PERL_BCDVERSION >= 0x5004000) && !defined(warner) -#if defined(NEED_warner) -static void DPPP_(my_warner)(U32 err, const char *pat, ...); +#if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_vcatpvf_mg) +# define sv_vcatpvf_mg(sv, pat, args) \ + STMT_START { \ + sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); \ + SvSETMAGIC(sv); \ + } STMT_END +#endif + +#if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_setpvf_mg) +#if defined(NEED_sv_setpvf_mg) +static void DPPP_(my_sv_setpvf_mg)(pTHX_ SV *sv, const char *pat, ...); static #else -extern void DPPP_(my_warner)(U32 err, const char *pat, ...); +extern void DPPP_(my_sv_setpvf_mg)(pTHX_ SV *sv, const char *pat, ...); #endif -#define Perl_warner DPPP_(my_warner) +#define Perl_sv_setpvf_mg DPPP_(my_sv_setpvf_mg) -#if defined(NEED_warner) || defined(NEED_warner_GLOBAL) +#if defined(NEED_sv_setpvf_mg) || defined(NEED_sv_setpvf_mg_GLOBAL) void -DPPP_(my_warner)(U32 err, const char *pat, ...) +DPPP_(my_sv_setpvf_mg)(pTHX_ SV *sv, const char *pat, ...) { - SV *sv; va_list args; - - PERL_UNUSED_ARG(err); - va_start(args, pat); - sv = vnewSVpvf(pat, &args); + sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); + SvSETMAGIC(sv); va_end(args); - sv_2mortal(sv); - warn("%s", SvPV_nolen(sv)); } -#define warner Perl_warner - -#define Perl_warner_nocontext Perl_warner - -#endif -#endif - -/* concatenating with "" ensures that only literal strings are accepted as argument - * note that STR_WITH_LEN() can't be used as argument to macros or functions that - * under some configurations might be macros - */ -#ifndef STR_WITH_LEN -# define STR_WITH_LEN(s) (s ""), (sizeof(s)-1) #endif -#ifndef newSVpvs -# define newSVpvs(str) newSVpvn(str "", sizeof(str) - 1) #endif -#ifndef newSVpvs_flags -# define newSVpvs_flags(str, flags) newSVpvn_flags(str "", sizeof(str) - 1, flags) +#ifdef PERL_IMPLICIT_CONTEXT +#if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_setpvf_mg_nocontext) +#if defined(NEED_sv_setpvf_mg_nocontext) +static void DPPP_(my_sv_setpvf_mg_nocontext)(SV *sv, const char *pat, ...); +static +#else +extern void DPPP_(my_sv_setpvf_mg_nocontext)(SV *sv, const char *pat, ...); #endif -#ifndef newSVpvs_share -# define newSVpvs_share(str) newSVpvn_share(str "", sizeof(str) - 1, 0) -#endif +#define sv_setpvf_mg_nocontext DPPP_(my_sv_setpvf_mg_nocontext) +#define Perl_sv_setpvf_mg_nocontext DPPP_(my_sv_setpvf_mg_nocontext) -#ifndef sv_catpvs -# define sv_catpvs(sv, str) sv_catpvn(sv, str "", sizeof(str) - 1) -#endif +#if defined(NEED_sv_setpvf_mg_nocontext) || defined(NEED_sv_setpvf_mg_nocontext_GLOBAL) -#ifndef sv_setpvs -# define sv_setpvs(sv, str) sv_setpvn(sv, str "", sizeof(str) - 1) -#endif +void +DPPP_(my_sv_setpvf_mg_nocontext)(SV *sv, const char *pat, ...) +{ + dTHX; + va_list args; + va_start(args, pat); + sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); + SvSETMAGIC(sv); + va_end(args); +} -#ifndef hv_fetchs -# define hv_fetchs(hv, key, lval) hv_fetch(hv, key "", sizeof(key) - 1, lval) #endif - -#ifndef hv_stores -# define hv_stores(hv, key, val) hv_store(hv, key "", sizeof(key) - 1, val, 0) #endif -#ifndef gv_fetchpvs -# define gv_fetchpvs(name, flags, svt) gv_fetchpvn_flags(name "", sizeof(name) - 1, flags, svt) #endif -#ifndef gv_stashpvs -# define gv_stashpvs(name, flags) gv_stashpvn(name "", sizeof(name) - 1, flags) -#endif -#ifndef get_cvs -# define get_cvs(name, flags) get_cvn_flags(name "", sizeof(name)-1, flags) -#endif -#ifndef SvGETMAGIC -# define SvGETMAGIC(x) STMT_START { if (SvGMAGICAL(x)) mg_get(x); } STMT_END +/* sv_setpvf_mg depends on sv_setpvf_mg_nocontext */ +#ifndef sv_setpvf_mg +# ifdef PERL_IMPLICIT_CONTEXT +# define sv_setpvf_mg Perl_sv_setpvf_mg_nocontext +# else +# define sv_setpvf_mg Perl_sv_setpvf_mg +# endif #endif -/* Some random bits for sv_unmagicext. These should probably be pulled in for - real and organized at some point */ -#ifndef HEf_SVKEY -# define HEf_SVKEY -2 +#if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_vsetpvf_mg) +# define sv_vsetpvf_mg(sv, pat, args) \ + STMT_START { \ + sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); \ + SvSETMAGIC(sv); \ + } STMT_END #endif -#ifndef MUTABLE_PTR -#if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN) -# define MUTABLE_PTR(p) ({ void *_p = (p); _p; }) +/* Hint: newSVpvn_share + * The SVs created by this function only mimic the behaviour of + * shared PVs without really being shared. Only use if you know + * what you're doing. + */ + +#ifndef newSVpvn_share + +#if defined(NEED_newSVpvn_share) +static SV * DPPP_(my_newSVpvn_share)(pTHX_ const char *src, I32 len, U32 hash); +static #else -# define MUTABLE_PTR(p) ((void *) (p)) -#endif -#endif -#ifndef MUTABLE_SV -# define MUTABLE_SV(p) ((SV *)MUTABLE_PTR(p)) +extern SV * DPPP_(my_newSVpvn_share)(pTHX_ const char *src, I32 len, U32 hash); #endif -/* end of random bits */ -#ifndef PERL_MAGIC_sv -# define PERL_MAGIC_sv '\0' +#ifdef newSVpvn_share +# undef newSVpvn_share #endif +#define newSVpvn_share(a,b,c) DPPP_(my_newSVpvn_share)(aTHX_ a,b,c) +#define Perl_newSVpvn_share DPPP_(my_newSVpvn_share) -#ifndef PERL_MAGIC_overload -# define PERL_MAGIC_overload 'A' -#endif +#if defined(NEED_newSVpvn_share) || defined(NEED_newSVpvn_share_GLOBAL) -#ifndef PERL_MAGIC_overload_elem -# define PERL_MAGIC_overload_elem 'a' -#endif +SV * +DPPP_(my_newSVpvn_share)(pTHX_ const char *src, I32 len, U32 hash) +{ + SV *sv; + if (len < 0) + len = -len; + if (!hash) + PERL_HASH(hash, (char*) src, len); + sv = newSVpvn((char *) src, len); + sv_upgrade(sv, SVt_PVIV); + SvIVX(sv) = hash; + SvREADONLY_on(sv); + SvPOK_on(sv); + return sv; +} -#ifndef PERL_MAGIC_overload_table -# define PERL_MAGIC_overload_table 'c' #endif -#ifndef PERL_MAGIC_bm -# define PERL_MAGIC_bm 'B' #endif - -#ifndef PERL_MAGIC_regdata -# define PERL_MAGIC_regdata 'D' +#ifndef SvSHARED_HASH +# define SvSHARED_HASH(sv) (0 + SvUVX(sv)) #endif - -#ifndef PERL_MAGIC_regdatum -# define PERL_MAGIC_regdatum 'd' +#ifndef HvNAME_get +# define HvNAME_get(hv) HvNAME(hv) #endif - -#ifndef PERL_MAGIC_env -# define PERL_MAGIC_env 'E' +#ifndef HvNAMELEN_get +# define HvNAMELEN_get(hv) (HvNAME_get(hv) ? (I32)strlen(HvNAME_get(hv)) : 0) #endif -#ifndef PERL_MAGIC_envelem -# define PERL_MAGIC_envelem 'e' +#ifndef gv_fetchpvn_flags +#if defined(NEED_gv_fetchpvn_flags) +static GV* DPPP_(my_gv_fetchpvn_flags)(pTHX_ const char* name, STRLEN len, int flags, int types); +static +#else +extern GV* DPPP_(my_gv_fetchpvn_flags)(pTHX_ const char* name, STRLEN len, int flags, int types); #endif -#ifndef PERL_MAGIC_fm -# define PERL_MAGIC_fm 'f' +#ifdef gv_fetchpvn_flags +# undef gv_fetchpvn_flags #endif +#define gv_fetchpvn_flags(a,b,c,d) DPPP_(my_gv_fetchpvn_flags)(aTHX_ a,b,c,d) +#define Perl_gv_fetchpvn_flags DPPP_(my_gv_fetchpvn_flags) -#ifndef PERL_MAGIC_regex_global -# define PERL_MAGIC_regex_global 'g' -#endif +#if defined(NEED_gv_fetchpvn_flags) || defined(NEED_gv_fetchpvn_flags_GLOBAL) -#ifndef PERL_MAGIC_isa -# define PERL_MAGIC_isa 'I' -#endif +GV* +DPPP_(my_gv_fetchpvn_flags)(pTHX_ const char* name, STRLEN len, int flags, int types) { + char *namepv = savepvn(name, len); + GV* stash = gv_fetchpv(namepv, TRUE, SVt_PVHV); + Safefree(namepv); + return stash; +} -#ifndef PERL_MAGIC_isaelem -# define PERL_MAGIC_isaelem 'i' +#endif +#endif +#ifndef GvSVn +# define GvSVn(gv) GvSV(gv) #endif -#ifndef PERL_MAGIC_nkeys -# define PERL_MAGIC_nkeys 'k' +#ifndef isGV_with_GP +# define isGV_with_GP(gv) isGV(gv) #endif -#ifndef PERL_MAGIC_dbfile -# define PERL_MAGIC_dbfile 'L' +#ifndef gv_fetchsv +# define gv_fetchsv(name, flags, svt) gv_fetchpv(SvPV_nolen_const(name), flags, svt) +#endif +#ifndef get_cvn_flags +# define get_cvn_flags(name, namelen, flags) get_cv(name, flags) #endif -#ifndef PERL_MAGIC_dbline -# define PERL_MAGIC_dbline 'l' +#ifndef gv_init_pvn +# define gv_init_pvn(gv, stash, ptr, len, flags) gv_init(gv, stash, ptr, len, flags & GV_ADDMULTI ? TRUE : FALSE) +#endif +#ifndef WARN_ALL +# define WARN_ALL 0 #endif -#ifndef PERL_MAGIC_mutex -# define PERL_MAGIC_mutex 'm' +#ifndef WARN_CLOSURE +# define WARN_CLOSURE 1 #endif -#ifndef PERL_MAGIC_shared -# define PERL_MAGIC_shared 'N' +#ifndef WARN_DEPRECATED +# define WARN_DEPRECATED 2 #endif -#ifndef PERL_MAGIC_shared_scalar -# define PERL_MAGIC_shared_scalar 'n' +#ifndef WARN_EXITING +# define WARN_EXITING 3 #endif -#ifndef PERL_MAGIC_collxfrm -# define PERL_MAGIC_collxfrm 'o' +#ifndef WARN_GLOB +# define WARN_GLOB 4 #endif -#ifndef PERL_MAGIC_tied -# define PERL_MAGIC_tied 'P' +#ifndef WARN_IO +# define WARN_IO 5 #endif -#ifndef PERL_MAGIC_tiedelem -# define PERL_MAGIC_tiedelem 'p' +#ifndef WARN_CLOSED +# define WARN_CLOSED 6 #endif -#ifndef PERL_MAGIC_tiedscalar -# define PERL_MAGIC_tiedscalar 'q' +#ifndef WARN_EXEC +# define WARN_EXEC 7 #endif -#ifndef PERL_MAGIC_qr -# define PERL_MAGIC_qr 'r' +#ifndef WARN_LAYER +# define WARN_LAYER 8 #endif -#ifndef PERL_MAGIC_sig -# define PERL_MAGIC_sig 'S' +#ifndef WARN_NEWLINE +# define WARN_NEWLINE 9 #endif -#ifndef PERL_MAGIC_sigelem -# define PERL_MAGIC_sigelem 's' +#ifndef WARN_PIPE +# define WARN_PIPE 10 #endif -#ifndef PERL_MAGIC_taint -# define PERL_MAGIC_taint 't' +#ifndef WARN_UNOPENED +# define WARN_UNOPENED 11 #endif -#ifndef PERL_MAGIC_uvar -# define PERL_MAGIC_uvar 'U' +#ifndef WARN_MISC +# define WARN_MISC 12 #endif -#ifndef PERL_MAGIC_uvar_elem -# define PERL_MAGIC_uvar_elem 'u' +#ifndef WARN_NUMERIC +# define WARN_NUMERIC 13 #endif -#ifndef PERL_MAGIC_vstring -# define PERL_MAGIC_vstring 'V' +#ifndef WARN_ONCE +# define WARN_ONCE 14 #endif -#ifndef PERL_MAGIC_vec -# define PERL_MAGIC_vec 'v' +#ifndef WARN_OVERFLOW +# define WARN_OVERFLOW 15 #endif -#ifndef PERL_MAGIC_utf8 -# define PERL_MAGIC_utf8 'w' +#ifndef WARN_PACK +# define WARN_PACK 16 #endif -#ifndef PERL_MAGIC_substr -# define PERL_MAGIC_substr 'x' +#ifndef WARN_PORTABLE +# define WARN_PORTABLE 17 #endif -#ifndef PERL_MAGIC_defelem -# define PERL_MAGIC_defelem 'y' +#ifndef WARN_RECURSION +# define WARN_RECURSION 18 #endif -#ifndef PERL_MAGIC_glob -# define PERL_MAGIC_glob '*' +#ifndef WARN_REDEFINE +# define WARN_REDEFINE 19 #endif -#ifndef PERL_MAGIC_arylen -# define PERL_MAGIC_arylen '#' +#ifndef WARN_REGEXP +# define WARN_REGEXP 20 #endif -#ifndef PERL_MAGIC_pos -# define PERL_MAGIC_pos '.' +#ifndef WARN_SEVERE +# define WARN_SEVERE 21 #endif -#ifndef PERL_MAGIC_backref -# define PERL_MAGIC_backref '<' +#ifndef WARN_DEBUGGING +# define WARN_DEBUGGING 22 #endif -#ifndef PERL_MAGIC_ext -# define PERL_MAGIC_ext '~' +#ifndef WARN_INPLACE +# define WARN_INPLACE 23 #endif -/* That's the best we can do... */ -#ifndef sv_catpvn_nomg -# define sv_catpvn_nomg sv_catpvn +#ifndef WARN_INTERNAL +# define WARN_INTERNAL 24 #endif -#ifndef sv_catsv_nomg -# define sv_catsv_nomg sv_catsv +#ifndef WARN_MALLOC +# define WARN_MALLOC 25 #endif -#ifndef sv_setsv_nomg -# define sv_setsv_nomg sv_setsv +#ifndef WARN_SIGNAL +# define WARN_SIGNAL 26 #endif -#ifndef sv_pvn_nomg -# define sv_pvn_nomg sv_pvn +#ifndef WARN_SUBSTR +# define WARN_SUBSTR 27 #endif -#ifndef SvIV_nomg -# define SvIV_nomg SvIV +#ifndef WARN_SYNTAX +# define WARN_SYNTAX 28 #endif -#ifndef SvUV_nomg -# define SvUV_nomg SvUV +#ifndef WARN_AMBIGUOUS +# define WARN_AMBIGUOUS 29 #endif -#ifndef sv_catpv_mg -# define sv_catpv_mg(sv, ptr) \ - STMT_START { \ - SV *TeMpSv = sv; \ - sv_catpv(TeMpSv,ptr); \ - SvSETMAGIC(TeMpSv); \ - } STMT_END +#ifndef WARN_BAREWORD +# define WARN_BAREWORD 30 #endif -#ifndef sv_catpvn_mg -# define sv_catpvn_mg(sv, ptr, len) \ - STMT_START { \ - SV *TeMpSv = sv; \ - sv_catpvn(TeMpSv,ptr,len); \ - SvSETMAGIC(TeMpSv); \ - } STMT_END +#ifndef WARN_DIGIT +# define WARN_DIGIT 31 #endif -#ifndef sv_catsv_mg -# define sv_catsv_mg(dsv, ssv) \ - STMT_START { \ - SV *TeMpSv = dsv; \ - sv_catsv(TeMpSv,ssv); \ - SvSETMAGIC(TeMpSv); \ - } STMT_END +#ifndef WARN_PARENTHESIS +# define WARN_PARENTHESIS 32 #endif -#ifndef sv_setiv_mg -# define sv_setiv_mg(sv, i) \ - STMT_START { \ - SV *TeMpSv = sv; \ - sv_setiv(TeMpSv,i); \ - SvSETMAGIC(TeMpSv); \ - } STMT_END +#ifndef WARN_PRECEDENCE +# define WARN_PRECEDENCE 33 #endif -#ifndef sv_setnv_mg -# define sv_setnv_mg(sv, num) \ - STMT_START { \ - SV *TeMpSv = sv; \ - sv_setnv(TeMpSv,num); \ - SvSETMAGIC(TeMpSv); \ - } STMT_END +#ifndef WARN_PRINTF +# define WARN_PRINTF 34 #endif -#ifndef sv_setpv_mg -# define sv_setpv_mg(sv, ptr) \ - STMT_START { \ - SV *TeMpSv = sv; \ - sv_setpv(TeMpSv,ptr); \ - SvSETMAGIC(TeMpSv); \ - } STMT_END +#ifndef WARN_PROTOTYPE +# define WARN_PROTOTYPE 35 #endif -#ifndef sv_setpvn_mg -# define sv_setpvn_mg(sv, ptr, len) \ - STMT_START { \ - SV *TeMpSv = sv; \ - sv_setpvn(TeMpSv,ptr,len); \ - SvSETMAGIC(TeMpSv); \ - } STMT_END +#ifndef WARN_QW +# define WARN_QW 36 #endif -#ifndef sv_setsv_mg -# define sv_setsv_mg(dsv, ssv) \ - STMT_START { \ - SV *TeMpSv = dsv; \ - sv_setsv(TeMpSv,ssv); \ - SvSETMAGIC(TeMpSv); \ - } STMT_END +#ifndef WARN_RESERVED +# define WARN_RESERVED 37 #endif -#ifndef sv_setuv_mg -# define sv_setuv_mg(sv, i) \ - STMT_START { \ - SV *TeMpSv = sv; \ - sv_setuv(TeMpSv,i); \ - SvSETMAGIC(TeMpSv); \ - } STMT_END +#ifndef WARN_SEMICOLON +# define WARN_SEMICOLON 38 #endif -#ifndef sv_usepvn_mg -# define sv_usepvn_mg(sv, ptr, len) \ - STMT_START { \ - SV *TeMpSv = sv; \ - sv_usepvn(TeMpSv,ptr,len); \ - SvSETMAGIC(TeMpSv); \ - } STMT_END -#endif -#ifndef SvVSTRING_mg -# define SvVSTRING_mg(sv) (SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_vstring) : NULL) +#ifndef WARN_TAINT +# define WARN_TAINT 39 #endif -/* Hint: sv_magic_portable - * This is a compatibility function that is only available with - * Devel::PPPort. It is NOT in the perl core. - * Its purpose is to mimic the 5.8.0 behaviour of sv_magic() when - * it is being passed a name pointer with namlen == 0. In that - * case, perl 5.8.0 and later store the pointer, not a copy of it. - * The compatibility can be provided back to perl 5.004. With - * earlier versions, the code will not compile. - */ +#ifndef WARN_THREADS +# define WARN_THREADS 40 +#endif -#if (PERL_BCDVERSION < 0x5004000) +#ifndef WARN_UNINITIALIZED +# define WARN_UNINITIALIZED 41 +#endif - /* code that uses sv_magic_portable will not compile */ +#ifndef WARN_UNPACK +# define WARN_UNPACK 42 +#endif -#elif (PERL_BCDVERSION < 0x5008000) +#ifndef WARN_UNTIE +# define WARN_UNTIE 43 +#endif -# define sv_magic_portable(sv, obj, how, name, namlen) \ - STMT_START { \ - SV *SvMp_sv = (sv); \ - char *SvMp_name = (char *) (name); \ - I32 SvMp_namlen = (namlen); \ - if (SvMp_name && SvMp_namlen == 0) \ - { \ - MAGIC *mg; \ - sv_magic(SvMp_sv, obj, how, 0, 0); \ - mg = SvMAGIC(SvMp_sv); \ - mg->mg_len = -42; /* XXX: this is the tricky part */ \ - mg->mg_ptr = SvMp_name; \ - } \ - else \ - { \ - sv_magic(SvMp_sv, obj, how, SvMp_name, SvMp_namlen); \ - } \ - } STMT_END +#ifndef WARN_UTF8 +# define WARN_UTF8 44 +#endif -#else +#ifndef WARN_VOID +# define WARN_VOID 45 +#endif -# define sv_magic_portable(a, b, c, d, e) sv_magic(a, b, c, d, e) +#ifndef WARN_ASSERTIONS +# define WARN_ASSERTIONS 46 +#endif +#ifndef packWARN +# define packWARN(a) (a) +#endif +#ifndef ckWARN +# ifdef G_WARN_ON +# define ckWARN(a) (PL_dowarn & G_WARN_ON) +# else +# define ckWARN(a) PL_dowarn +# endif #endif -#if !defined(mg_findext) -#if defined(NEED_mg_findext) -static MAGIC * DPPP_(my_mg_findext)(SV * sv, int type, const MGVTBL *vtbl); +#if (PERL_BCDVERSION >= 0x5004000) && !defined(warner) +#if defined(NEED_warner) +static void DPPP_(my_warner)(U32 err, const char *pat, ...); static #else -extern MAGIC * DPPP_(my_mg_findext)(SV * sv, int type, const MGVTBL *vtbl); +extern void DPPP_(my_warner)(U32 err, const char *pat, ...); #endif -#define mg_findext DPPP_(my_mg_findext) -#define Perl_mg_findext DPPP_(my_mg_findext) - -#if defined(NEED_mg_findext) || defined(NEED_mg_findext_GLOBAL) +#define Perl_warner DPPP_(my_warner) -MAGIC * -DPPP_(my_mg_findext)(SV * sv, int type, const MGVTBL *vtbl) { - if (sv) { - MAGIC *mg; +#if defined(NEED_warner) || defined(NEED_warner_GLOBAL) -#ifdef AvPAD_NAMELIST - assert(!(SvTYPE(sv) == SVt_PVAV && AvPAD_NAMELIST(sv))); -#endif +void +DPPP_(my_warner)(U32 err, const char *pat, ...) +{ + SV *sv; + va_list args; - for (mg = SvMAGIC (sv); mg; mg = mg->mg_moremagic) { - if (mg->mg_type == type && mg->mg_virtual == vtbl) - return mg; - } - } + PERL_UNUSED_ARG(err); - return NULL; + va_start(args, pat); + sv = vnewSVpvf(pat, &args); + va_end(args); + sv_2mortal(sv); + warn("%s", SvPV_nolen(sv)); } +#define warner Perl_warner + +#define Perl_warner_nocontext Perl_warner + #endif #endif -#if !defined(sv_unmagicext) -#if defined(NEED_sv_unmagicext) -static int DPPP_(my_sv_unmagicext)(pTHX_ SV * const sv, const int type, MGVTBL * vtbl); -static -#else -extern int DPPP_(my_sv_unmagicext)(pTHX_ SV * const sv, const int type, MGVTBL * vtbl); +/* concatenating with "" ensures that only literal strings are accepted as argument + * note that STR_WITH_LEN() can't be used as argument to macros or functions that + * under some configurations might be macros + */ +#ifndef STR_WITH_LEN +# define STR_WITH_LEN(s) (s ""), (sizeof(s)-1) +#endif +#ifndef newSVpvs +# define newSVpvs(str) newSVpvn(str "", sizeof(str) - 1) #endif -#ifdef sv_unmagicext -# undef sv_unmagicext +#ifndef newSVpvs_flags +# define newSVpvs_flags(str, flags) newSVpvn_flags(str "", sizeof(str) - 1, flags) #endif -#define sv_unmagicext(a,b,c) DPPP_(my_sv_unmagicext)(aTHX_ a,b,c) -#define Perl_sv_unmagicext DPPP_(my_sv_unmagicext) -#if defined(NEED_sv_unmagicext) || defined(NEED_sv_unmagicext_GLOBAL) +#ifndef newSVpvs_share +# define newSVpvs_share(str) newSVpvn_share(str "", sizeof(str) - 1, 0) +#endif -int -DPPP_(my_sv_unmagicext)(pTHX_ SV *const sv, const int type, MGVTBL *vtbl) -{ - MAGIC* mg; - MAGIC** mgp; +#ifndef sv_catpvs +# define sv_catpvs(sv, str) sv_catpvn(sv, str "", sizeof(str) - 1) +#endif - if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv)) - return 0; - mgp = &(SvMAGIC(sv)); - for (mg = *mgp; mg; mg = *mgp) { - const MGVTBL* const virt = mg->mg_virtual; - if (mg->mg_type == type && virt == vtbl) { - *mgp = mg->mg_moremagic; - if (virt && virt->svt_free) - virt->svt_free(aTHX_ sv, mg); - if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) { - if (mg->mg_len > 0) - Safefree(mg->mg_ptr); - else if (mg->mg_len == HEf_SVKEY) /* Questionable on older perls... */ - SvREFCNT_dec(MUTABLE_SV(mg->mg_ptr)); - else if (mg->mg_type == PERL_MAGIC_utf8) - Safefree(mg->mg_ptr); - } - if (mg->mg_flags & MGf_REFCOUNTED) - SvREFCNT_dec(mg->mg_obj); - Safefree(mg); - } - else - mgp = &mg->mg_moremagic; - } - if (SvMAGIC(sv)) { - if (SvMAGICAL(sv)) /* if we're under save_magic, wait for restore_magic; */ - mg_magical(sv); /* else fix the flags now */ - } - else { - SvMAGICAL_off(sv); - SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT; - } - return 0; -} +#ifndef sv_setpvs +# define sv_setpvs(sv, str) sv_setpvn(sv, str "", sizeof(str) - 1) +#endif + +#ifndef hv_fetchs +# define hv_fetchs(hv, key, lval) hv_fetch(hv, key "", sizeof(key) - 1, lval) +#endif + +#ifndef hv_stores +# define hv_stores(hv, key, val) hv_store(hv, key "", sizeof(key) - 1, val, 0) +#endif +#ifndef gv_fetchpvs +# define gv_fetchpvs(name, flags, svt) gv_fetchpvn_flags(name "", sizeof(name) - 1, flags, svt) +#endif +#ifndef gv_stashpvs +# define gv_stashpvs(name, flags) gv_stashpvn(name "", sizeof(name) - 1, flags) #endif +#ifndef get_cvs +# define get_cvs(name, flags) get_cvn_flags(name "", sizeof(name)-1, flags) #endif #ifdef USE_ITHREADS