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