1/* vi: set ft=c : */ 2 3#ifndef av_count 4# define av_count(av) (AvFILL(av) + 1) 5#endif 6 7#if HAVE_PERL_VERSION(5, 22, 0) 8# define PadnameIsNULL(pn) (!(pn)) 9#else 10# define PadnameIsNULL(pn) (!(pn) || (pn) == &PL_sv_undef) 11#endif 12 13#ifndef hv_deletes 14# define hv_deletes(hv, skey, flags) hv_delete((hv), ("" skey ""), (sizeof(skey) - 1), flags) 15#endif 16 17#if HAVE_PERL_VERSION(5, 22, 0) 18# define PadnameOUTER_off(pn) (PadnameFLAGS(pn) &= ~PADNAMEt_OUTER) 19#else 20 /* PadnameOUTER is really the SvFAKE flag */ 21# define PadnameOUTER_off(pn) SvFAKE_off(pn) 22#endif 23 24#define save_strndup(s, l) S_save_strndup(aTHX_ s, l) 25static char *S_save_strndup(pTHX_ char *s, STRLEN l) 26{ 27 /* savepvn doesn't put anything on the save stack, despite its name */ 28 char *ret = savepvn(s, l); 29 SAVEFREEPV(ret); 30 return ret; 31} 32 33static char *PL_savetype_name[] PERL_UNUSED_DECL = { 34 /* These have been present since 5.16 */ 35 [SAVEt_ADELETE] = "ADELETE", 36 [SAVEt_AELEM] = "AELEM", 37 [SAVEt_ALLOC] = "ALLOC", 38 [SAVEt_APTR] = "APTR", 39 [SAVEt_AV] = "AV", 40 [SAVEt_BOOL] = "BOOL", 41 [SAVEt_CLEARSV] = "CLEARSV", 42 [SAVEt_COMPILE_WARNINGS] = "COMPILE_WARNINGS", 43 [SAVEt_COMPPAD] = "COMPPAD", 44 [SAVEt_DELETE] = "DELETE", 45 [SAVEt_DESTRUCTOR] = "DESTRUCTOR", 46 [SAVEt_DESTRUCTOR_X] = "DESTRUCTOR_X", 47 [SAVEt_FREECOPHH] = "FREECOPHH", 48 [SAVEt_FREEOP] = "FREEOP", 49 [SAVEt_FREEPV] = "FREEPV", 50 [SAVEt_FREESV] = "FREESV", 51 [SAVEt_GENERIC_PVREF] = "GENERIC_PVREF", 52 [SAVEt_GENERIC_SVREF] = "GENERIC_SVREF", 53 [SAVEt_GP] = "GP", 54 [SAVEt_GVSV] = "GVSV", 55 [SAVEt_HELEM] = "HELEM", 56 [SAVEt_HINTS] = "HINTS", 57 [SAVEt_HPTR] = "HPTR", 58 [SAVEt_HV] = "HV", 59 [SAVEt_I16] = "I16", 60 [SAVEt_I32] = "I32", 61 [SAVEt_I32_SMALL] = "I32_SMALL", 62 [SAVEt_I8] = "I8", 63 [SAVEt_INT] = "INT", 64 [SAVEt_INT_SMALL] = "INT_SMALL", 65 [SAVEt_ITEM] = "ITEM", 66 [SAVEt_IV] = "IV", 67 [SAVEt_LONG] = "LONG", 68 [SAVEt_MORTALIZESV] = "MORTALIZESV", 69 [SAVEt_NSTAB] = "NSTAB", 70 [SAVEt_OP] = "OP", 71 [SAVEt_PADSV_AND_MORTALIZE] = "PADSV_AND_MORTALIZE", 72 [SAVEt_PARSER] = "PARSER", 73 [SAVEt_PPTR] = "PPTR", 74 [SAVEt_REGCONTEXT] = "REGCONTEXT", 75 [SAVEt_SAVESWITCHSTACK] = "SAVESWITCHSTACK", 76 [SAVEt_SET_SVFLAGS] = "SET_SVFLAGS", 77 [SAVEt_SHARED_PVREF] = "SHARED_PVREF", 78 [SAVEt_SPTR] = "SPTR", 79 [SAVEt_STACK_POS] = "STACK_POS", 80 [SAVEt_SVREF] = "SVREF", 81 [SAVEt_SV] = "SV", 82 [SAVEt_VPTR] = "VPTR", 83 84#if HAVE_PERL_VERSION(5,18,0) 85 [SAVEt_CLEARPADRANGE] = "CLEARPADRANGE", 86 [SAVEt_GVSLOT] = "GVSLOT", 87#endif 88 89#if HAVE_PERL_VERSION(5,20,0) 90 [SAVEt_READONLY_OFF] = "READONLY_OFF", 91 [SAVEt_STRLEN] = "STRLEN", 92#endif 93 94#if HAVE_PERL_VERSION(5,22,0) 95 [SAVEt_FREEPADNAME] = "FREEPADNAME", 96#endif 97 98#if HAVE_PERL_VERSION(5,24,0) 99 [SAVEt_TMPSFLOOR] = "TMPSFLOOR", 100#endif 101 102#if HAVE_PERL_VERSION(5,34,0) 103 [SAVEt_STRLEN_SMALL] = "STRLEN_SMALL", 104 [SAVEt_HINTS_HH] = "HINTS_HH", 105#endif 106}; 107 108#define dKWARG(count) \ 109 U32 kwargi = count; \ 110 U32 kwarg; \ 111 SV *kwval; \ 112 /* TODO: complain about odd number of args */ 113 114#define KWARG_NEXT(args) \ 115 S_kwarg_next(aTHX_ args, &kwargi, items, ax, &kwarg, &kwval) 116static bool S_kwarg_next(pTHX_ const char *args[], U32 *kwargi, U32 argc, U32 ax, U32 *kwarg, SV **kwval) 117{ 118 if(*kwargi >= argc) 119 return FALSE; 120 121 SV *argname = ST(*kwargi); (*kwargi)++; 122 if(!SvOK(argname)) 123 croak("Expected string for next argument name, got undef"); 124 125 *kwarg = 0; 126 while(args[*kwarg]) { 127 if(strEQ(SvPV_nolen(argname), args[*kwarg])) { 128 *kwval = ST(*kwargi); (*kwargi)++; 129 return TRUE; 130 } 131 (*kwarg)++; 132 } 133 134 croak("Unrecognised argument name '%" SVf "'", SVfARG(argname)); 135} 136 137#define import_pragma(pragma, arg) S_import_pragma(aTHX_ pragma, arg) 138static void S_import_pragma(pTHX_ const char *pragma, const char *arg) 139{ 140 dSP; 141 bool unimport = FALSE; 142 143 if(pragma[0] == '-') { 144 unimport = TRUE; 145 pragma++; 146 } 147 148 SAVETMPS; 149 150 EXTEND(SP, 2); 151 PUSHMARK(SP); 152 mPUSHp(pragma, strlen(pragma)); 153 if(arg) 154 mPUSHp(arg, strlen(arg)); 155 PUTBACK; 156 157 call_method(unimport ? "unimport" : "import", G_VOID); 158 159 FREETMPS; 160} 161 162#define ensure_module_version(module, version) S_ensure_module_version(aTHX_ module, version) 163static void S_ensure_module_version(pTHX_ SV *module, SV *version) 164{ 165 dSP; 166 167 ENTER; 168 169 PUSHMARK(SP); 170 PUSHs(module); 171 PUSHs(version); 172 PUTBACK; 173 174 call_method("VERSION", G_VOID); 175 176 LEAVE; 177} 178 179#define fetch_superclass_method_pv(stash, pv, len, level) S_fetch_superclass_method_pv(aTHX_ stash, pv, len, level) 180static CV *S_fetch_superclass_method_pv(pTHX_ HV *stash, const char *pv, STRLEN len, U32 level) 181{ 182#if HAVE_PERL_VERSION(5, 18, 0) 183 GV *gv = gv_fetchmeth_pvn(stash, pv, len, level, GV_SUPER); 184#else 185 SV *superclassname = newSVpvf("%*s::SUPER", HvNAMELEN_get(stash), HvNAME_get(stash)); 186 if(HvNAMEUTF8(stash)) 187 SvUTF8_on(superclassname); 188 SAVEFREESV(superclassname); 189 190 HV *superstash = gv_stashsv(superclassname, GV_ADD); 191 GV *gv = gv_fetchmeth_pvn(superstash, pv, len, level, 0); 192#endif 193 194 if(!gv) 195 return NULL; 196 return GvCV(gv); 197} 198 199#define get_class_isa(stash) S_get_class_isa(aTHX_ stash) 200static AV *S_get_class_isa(pTHX_ HV *stash) 201{ 202 GV **gvp = (GV **)hv_fetchs(stash, "ISA", 0); 203 if(!gvp || !GvAV(*gvp)) 204 croak("Expected %s to have a @ISA list", HvNAME(stash)); 205 206 return GvAV(*gvp); 207} 208 209#define find_cop_for_lvintro(padix, o, copp) S_find_cop_for_lvintro(aTHX_ padix, o, copp) 210static COP *S_find_cop_for_lvintro(pTHX_ PADOFFSET padix, OP *o, COP **copp) 211{ 212 for( ; o; o = OpSIBLING(o)) { 213 if(OP_CLASS(o) == OA_COP) { 214 *copp = (COP *)o; 215 } 216 else if(o->op_type == OP_PADSV && o->op_targ == padix && o->op_private & OPpLVAL_INTRO) { 217 return *copp; 218 } 219 else if(o->op_flags & OPf_KIDS) { 220 COP *ret = find_cop_for_lvintro(padix, cUNOPx(o)->op_first, copp); 221 if(ret) 222 return ret; 223 } 224 } 225 226 return NULL; 227} 228 229#define lex_consume_unichar(c) MY_lex_consume_unichar(aTHX_ c) 230static bool MY_lex_consume_unichar(pTHX_ U32 c) 231{ 232 if(lex_peek_unichar(0) != c) 233 return FALSE; 234 235 lex_read_unichar(0); 236 return TRUE; 237} 238 239#define sv_derived_from_hv(sv, hv) MY_sv_derived_from_hv(aTHX_ sv, hv) 240static bool MY_sv_derived_from_hv(pTHX_ SV *sv, HV *hv) 241{ 242 char *hvname = HvNAME(hv); 243 if(!hvname) 244 return FALSE; 245 246 return sv_derived_from_pvn(sv, hvname, HvNAMELEN(hv), HvNAMEUTF8(hv) ? SVf_UTF8 : 0); 247} 248 249#define av_push_from_av_inc(dst, src) S_av_push_from_av(aTHX_ dst, src, TRUE) 250#define av_push_from_av_noinc(dst, src) S_av_push_from_av(aTHX_ dst, src, FALSE) 251static void S_av_push_from_av(pTHX_ AV *dst, AV *src, bool refcnt_inc) 252{ 253 SSize_t count = av_count(src); 254 SSize_t i; 255 256 av_extend(dst, av_count(dst) + count - 1); 257 258 SV **vals = AvARRAY(src); 259 260 for(i = 0; i < count; i++) { 261 SV *sv = vals[i]; 262 av_push(dst, refcnt_inc ? SvREFCNT_inc(sv) : sv); 263 } 264} 265