Commit | Line | Data |
---|---|---|
99b497aa PE |
1 | /* class.c |
2 | * | |
3 | * Copyright (C) 2022 by Paul Evans and others | |
4 | * | |
5 | * You may distribute under the terms of either the GNU General Public | |
6 | * License or the Artistic License, as specified in the README file. | |
7 | * | |
8 | */ | |
9 | ||
10 | /* This file contains the code that implements perl's new `use feature 'class'` | |
11 | * object model | |
12 | */ | |
13 | ||
14 | #include "EXTERN.h" | |
15 | #define PERL_IN_CLASS_C | |
16 | #include "perl.h" | |
17 | ||
18 | #include "XSUB.h" | |
19 | ||
20 | enum { | |
d8b29a34 PE |
21 | PADIX_SELF = 1, |
22 | PADIX_PARAMS = 2, | |
99b497aa PE |
23 | }; |
24 | ||
25 | void | |
26 | Perl_croak_kw_unless_class(pTHX_ const char *kw) | |
27 | { | |
28 | PERL_ARGS_ASSERT_CROAK_KW_UNLESS_CLASS; | |
29 | ||
30 | if(!HvSTASH_IS_CLASS(PL_curstash)) | |
31 | croak("Cannot '%s' outside of a 'class'", kw); | |
32 | } | |
33 | ||
24c33697 PE |
34 | #define newSVobject(fieldcount) Perl_newSVobject(aTHX_ fieldcount) |
35 | SV * | |
36 | Perl_newSVobject(pTHX_ Size_t fieldcount) | |
37 | { | |
38 | SV *sv = newSV_type(SVt_PVOBJ); | |
39 | ||
40 | Newx(ObjectFIELDS(sv), fieldcount, SV *); | |
41 | ObjectMAXFIELD(sv) = fieldcount - 1; | |
42 | ||
43 | Zero(ObjectFIELDS(sv), fieldcount, SV *); | |
44 | ||
45 | return sv; | |
46 | } | |
47 | ||
054ceeeb | 48 | PP(pp_initfield) |
9bf25cf0 | 49 | { |
054ceeeb | 50 | UNOP_AUX_item *aux = cUNOP_AUX->op_aux; |
e3b003dd | 51 | |
054ceeeb PE |
52 | SV *self = PAD_SVl(PADIX_SELF); |
53 | assert(SvTYPE(SvRV(self)) == SVt_PVOBJ); | |
54 | SV *instance = SvRV(self); | |
9bf25cf0 PE |
55 | |
56 | SV **fields = ObjectFIELDS(instance); | |
57 | ||
054ceeeb | 58 | PADOFFSET fieldix = aux[0].uv; |
9bf25cf0 | 59 | |
d8b29a34 PE |
60 | SV *val = NULL; |
61 | ||
054ceeeb PE |
62 | switch(PL_op->op_private & (OPpINITFIELD_AV|OPpINITFIELD_HV)) { |
63 | case 0: | |
6b845fdb DM |
64 | if(PL_op->op_flags & OPf_STACKED) { |
65 | val = newSVsv(*PL_stack_sp); | |
66 | rpp_popfree_1(); | |
67 | } | |
054ceeeb | 68 | else |
9bf25cf0 | 69 | val = newSV(0); |
054ceeeb PE |
70 | break; |
71 | ||
72 | case OPpINITFIELD_AV: | |
73 | { | |
74 | AV *av; | |
75 | if(PL_op->op_flags & OPf_STACKED) { | |
76 | SV **svp = PL_stack_base + POPMARK + 1; | |
6b845fdb | 77 | STRLEN count = PL_stack_sp - svp + 1; |
054ceeeb PE |
78 | |
79 | av = newAV_alloc_x(count); | |
80 | ||
6b845fdb | 81 | while(svp <= PL_stack_sp) { |
054ceeeb PE |
82 | av_push_simple(av, newSVsv(*svp)); |
83 | svp++; | |
84 | } | |
6b845fdb | 85 | rpp_popfree_to(PL_stack_sp - count); |
054ceeeb PE |
86 | } |
87 | else | |
88 | av = newAV(); | |
89 | val = (SV *)av; | |
90 | break; | |
91 | } | |
9bf25cf0 | 92 | |
054ceeeb PE |
93 | case OPpINITFIELD_HV: |
94 | { | |
95 | HV *hv = newHV(); | |
96 | if(PL_op->op_flags & OPf_STACKED) { | |
97 | SV **svp = PL_stack_base + POPMARK + 1; | |
6b845fdb | 98 | STRLEN svcount = PL_stack_sp - svp + 1; |
054ceeeb PE |
99 | |
100 | if(svcount % 2) | |
101 | Perl_warner(aTHX_ | |
102 | packWARN(WARN_MISC), "Odd number of elements in hash field initialization"); | |
103 | ||
6b845fdb | 104 | while(svp <= PL_stack_sp) { |
054ceeeb | 105 | SV *key = *svp; svp++; |
6b845fdb | 106 | SV *val = svp <= PL_stack_sp ? *svp : &PL_sv_undef; svp++; |
054ceeeb | 107 | |
d2d18d7c | 108 | (void)hv_store_ent(hv, key, newSVsv(val), 0); |
054ceeeb | 109 | } |
6b845fdb | 110 | rpp_popfree_to(PL_stack_sp - svcount); |
054ceeeb PE |
111 | } |
112 | val = (SV *)hv; | |
113 | break; | |
9bf25cf0 | 114 | } |
054ceeeb PE |
115 | } |
116 | ||
117 | fields[fieldix] = val; | |
9bf25cf0 | 118 | |
054ceeeb PE |
119 | PADOFFSET padix = PL_op->op_targ; |
120 | if(padix) { | |
121 | SAVESPTR(PAD_SVl(padix)); | |
122 | SV *sv = PAD_SVl(padix) = SvREFCNT_inc(val); | |
123 | save_freesv(sv); | |
9bf25cf0 | 124 | } |
054ceeeb | 125 | |
6b845fdb | 126 | return NORMAL; |
9bf25cf0 PE |
127 | } |
128 | ||
99b497aa PE |
129 | XS(injected_constructor); |
130 | XS(injected_constructor) | |
131 | { | |
132 | dXSARGS; | |
133 | ||
e9886301 | 134 | HV *stash = (HV *)XSANY.any_sv; |
99b497aa PE |
135 | assert(HvSTASH_IS_CLASS(stash)); |
136 | ||
137 | struct xpvhv_aux *aux = HvAUX(stash); | |
138 | ||
139 | if((items - 1) % 2) | |
140 | Perl_warn(aTHX_ "Odd number of arguments passed to %" HvNAMEf_QUOTEDPREFIX " constructor", | |
141 | HvNAMEfARG(stash)); | |
142 | ||
143 | HV *params = NULL; | |
144 | { | |
145 | /* Set up params HV */ | |
146 | params = newHV(); | |
147 | SAVEFREESV((SV *)params); | |
148 | ||
528c4120 | 149 | for(SSize_t i = 1; i < items; i += 2) { |
99b497aa PE |
150 | SV *name = ST(i); |
151 | SV *val = (i+1 < items) ? ST(i+1) : &PL_sv_undef; | |
152 | ||
153 | /* TODO: think about sanity-checking name for being | |
154 | * defined | |
155 | * not ref (but overloaded objects?? boo) | |
156 | * not duplicate | |
157 | * But then, %params = @_; wouldn't do that | |
158 | */ | |
159 | ||
d2d18d7c | 160 | (void)hv_store_ent(params, name, SvREFCNT_inc(val), 0); |
99b497aa PE |
161 | } |
162 | } | |
163 | ||
24c33697 | 164 | SV *instance = newSVobject(aux->xhv_class_next_fieldix); |
ca8d92cf PE |
165 | SvOBJECT_on(instance); |
166 | SvSTASH_set(instance, MUTABLE_HV(SvREFCNT_inc_simple(stash))); | |
167 | ||
054ceeeb PE |
168 | SV *self = sv_2mortal(newRV_noinc(instance)); |
169 | ||
e3b003dd PE |
170 | assert(aux->xhv_class_initfields_cv); |
171 | { | |
172 | ENTER; | |
173 | SAVETMPS; | |
174 | ||
d8b29a34 | 175 | EXTEND(SP, 2); |
e3b003dd | 176 | PUSHMARK(SP); |
054ceeeb | 177 | PUSHs(self); |
d8b29a34 PE |
178 | if(params) |
179 | PUSHs((SV *)params); // yes a raw HV | |
180 | else | |
181 | PUSHs(&PL_sv_undef); | |
e3b003dd PE |
182 | PUTBACK; |
183 | ||
184 | call_sv((SV *)aux->xhv_class_initfields_cv, G_VOID); | |
185 | ||
186 | SPAGAIN; | |
187 | ||
188 | FREETMPS; | |
189 | LEAVE; | |
190 | } | |
99b497aa | 191 | |
99b497aa PE |
192 | if(aux->xhv_class_adjust_blocks) { |
193 | CV **cvp = (CV **)AvARRAY(aux->xhv_class_adjust_blocks); | |
194 | U32 nblocks = av_count(aux->xhv_class_adjust_blocks); | |
195 | ||
196 | for(U32 i = 0; i < nblocks; i++) { | |
197 | ENTER; | |
198 | SAVETMPS; | |
199 | SPAGAIN; | |
200 | ||
d8b29a34 | 201 | EXTEND(SP, 2); |
99b497aa PE |
202 | |
203 | PUSHMARK(SP); | |
204 | PUSHs(self); /* I don't believe this needs to be an sv_mortalcopy() */ | |
205 | PUTBACK; | |
206 | ||
207 | call_sv((SV *)cvp[i], G_VOID); | |
208 | ||
209 | SPAGAIN; | |
210 | ||
211 | FREETMPS; | |
212 | LEAVE; | |
213 | } | |
214 | } | |
215 | ||
216 | if(params && hv_iterinit(params) > 0) { | |
217 | /* TODO: consider sorting these into a canonical order, but that's awkward */ | |
218 | HE *he = hv_iternext(params); | |
219 | ||
220 | SV *paramnames = newSVsv(HeSVKEY_force(he)); | |
221 | SAVEFREESV(paramnames); | |
222 | ||
223 | while((he = hv_iternext(params))) | |
224 | Perl_sv_catpvf(aTHX_ paramnames, ", %" SVf, SVfARG(HeSVKEY_force(he))); | |
225 | ||
226 | croak("Unrecognised parameters for %" HvNAMEf_QUOTEDPREFIX " constructor: %" SVf, | |
227 | HvNAMEfARG(stash), SVfARG(paramnames)); | |
228 | } | |
229 | ||
230 | EXTEND(SP, 1); | |
231 | ST(0) = self; | |
232 | XSRETURN(1); | |
233 | } | |
234 | ||
235 | /* OP_METHSTART is an UNOP_AUX whose AUX list contains | |
236 | * [0].uv = count of fieldbinding pairs | |
237 | * [1].uv = maximum fieldidx found in the binding list | |
238 | * [...] = pairs of (padix, fieldix) to bind in .uv fields | |
239 | */ | |
240 | ||
241 | /* TODO: People would probably expect to find this in pp.c ;) */ | |
242 | PP(pp_methstart) | |
243 | { | |
6b845fdb DM |
244 | /* note that if AvREAL(@_), be careful not to leak self: |
245 | * so keep it in @_ for now, and only shift it later */ | |
246 | SV *self = *(av_fetch(GvAV(PL_defgv), 0, 1)); | |
99b497aa PE |
247 | SV *rv = NULL; |
248 | ||
249 | /* pp_methstart happens before the first OP_NEXTSTATE of the method body, | |
250 | * meaning PL_curcop still points at the callsite. This is useful for | |
251 | * croak() messages. However, it means we have to find our current stash | |
252 | * via a different technique. | |
253 | */ | |
254 | CV *curcv; | |
255 | if(LIKELY(CxTYPE(CX_CUR()) == CXt_SUB)) | |
256 | curcv = CX_CUR()->blk_sub.cv; | |
257 | else | |
258 | curcv = find_runcv(NULL); | |
259 | ||
260 | if(!SvROK(self) || | |
261 | !SvOBJECT((rv = SvRV(self))) || | |
24c33697 | 262 | SvTYPE(rv) != SVt_PVOBJ) { |
99b497aa PE |
263 | HEK *namehek = CvGvNAME_HEK(curcv); |
264 | croak( | |
265 | namehek ? "Cannot invoke method %" HEKf_QUOTEDPREFIX " on a non-instance" : | |
266 | "Cannot invoke method on a non-instance", | |
267 | namehek); | |
268 | } | |
269 | ||
9bf25cf0 PE |
270 | if(CvSTASH(curcv) != SvSTASH(rv) && |
271 | !sv_derived_from_hv(self, CvSTASH(curcv))) | |
99b497aa PE |
272 | croak("Cannot invoke a method of %" HvNAMEf_QUOTEDPREFIX " on an instance of %" HvNAMEf_QUOTEDPREFIX, |
273 | HvNAMEfARG(CvSTASH(curcv)), HvNAMEfARG(SvSTASH(rv))); | |
274 | ||
275 | save_clearsv(&PAD_SVl(PADIX_SELF)); | |
276 | sv_setsv(PAD_SVl(PADIX_SELF), self); | |
277 | ||
278 | UNOP_AUX_item *aux = cUNOP_AUX->op_aux; | |
279 | if(aux) { | |
24c33697 PE |
280 | assert(SvTYPE(SvRV(self)) == SVt_PVOBJ); |
281 | SV *instance = SvRV(self); | |
282 | SV **fieldp = ObjectFIELDS(instance); | |
99b497aa PE |
283 | |
284 | U32 fieldcount = (aux++)->uv; | |
285 | U32 max_fieldix = (aux++)->uv; | |
286 | ||
3c0bfcec | 287 | assert((U32)(ObjectMAXFIELD(instance)+1) > max_fieldix); |
99b497aa PE |
288 | PERL_UNUSED_VAR(max_fieldix); |
289 | ||
290 | for(Size_t i = 0; i < fieldcount; i++) { | |
291 | PADOFFSET padix = (aux++)->uv; | |
292 | U32 fieldix = (aux++)->uv; | |
293 | ||
294 | assert(fieldp[fieldix]); | |
295 | ||
296 | /* TODO: There isn't a convenient SAVE macro for doing both these | |
297 | * steps in one go. Add one. */ | |
298 | SAVESPTR(PAD_SVl(padix)); | |
299 | SV *sv = PAD_SVl(padix) = SvREFCNT_inc(fieldp[fieldix]); | |
300 | save_freesv(sv); | |
301 | } | |
302 | } | |
303 | ||
6b845fdb DM |
304 | /* safe to shift and free self now */ |
305 | self = av_shift(GvAV(PL_defgv)); | |
306 | if (AvREAL(GvAV(PL_defgv))) | |
307 | SvREFCNT_dec_NN(self); | |
308 | ||
d8b29a34 PE |
309 | if(PL_op->op_private & OPpINITFIELDS) { |
310 | SV *params = *av_fetch(GvAV(PL_defgv), 0, 0); | |
311 | if(params && SvTYPE(params) == SVt_PVHV) { | |
312 | SAVESPTR(PAD_SVl(PADIX_PARAMS)); | |
313 | PAD_SVl(PADIX_PARAMS) = SvREFCNT_inc(params); | |
314 | save_freesv(params); | |
315 | } | |
316 | } | |
317 | ||
99b497aa PE |
318 | return NORMAL; |
319 | } | |
320 | ||
321 | static void | |
322 | invoke_class_seal(pTHX_ void *_arg) | |
323 | { | |
324 | class_seal_stash((HV *)_arg); | |
325 | } | |
326 | ||
327 | void | |
328 | Perl_class_setup_stash(pTHX_ HV *stash) | |
329 | { | |
330 | PERL_ARGS_ASSERT_CLASS_SETUP_STASH; | |
331 | ||
332 | assert(HvHasAUX(stash)); | |
333 | ||
334 | if(HvSTASH_IS_CLASS(stash)) { | |
335 | croak("Cannot reopen existing class %" HvNAMEf_QUOTEDPREFIX, | |
336 | HvNAMEfARG(stash)); | |
337 | } | |
338 | ||
0bb17957 PE |
339 | { |
340 | SV *isaname = newSVpvf("%" HEKf "::ISA", HvNAME_HEK(stash)); | |
341 | sv_2mortal(isaname); | |
342 | ||
343 | AV *isa = get_av(SvPV_nolen(isaname), (SvFLAGS(isaname) & SVf_UTF8)); | |
344 | ||
345 | if(isa && av_count(isa) > 0) | |
346 | croak("Cannot create class %" HEKf " as it already has a non-empty @ISA", | |
347 | HvNAME_HEK(stash)); | |
348 | } | |
349 | ||
99b497aa PE |
350 | char *classname = HvNAME(stash); |
351 | U32 nameflags = HvNAMEUTF8(stash) ? SVf_UTF8 : 0; | |
352 | ||
353 | /* TODO: | |
354 | * Set some kind of flag on the stash to point out it's a class | |
355 | * Allocate storage for all the extra things a class needs | |
356 | * See https://github.com/leonerd/perl5/discussions/1 | |
357 | */ | |
358 | ||
359 | /* Inject the constructor */ | |
360 | { | |
361 | SV *newname = Perl_newSVpvf(aTHX_ "%s::new", classname); | |
362 | SAVEFREESV(newname); | |
363 | ||
364 | CV *newcv = newXS_flags(SvPV_nolen(newname), injected_constructor, __FILE__, NULL, nameflags); | |
e9886301 PE |
365 | CvXSUBANY(newcv).any_sv = (SV *)stash; |
366 | CvREFCOUNTED_ANYSV_on(newcv); | |
99b497aa PE |
367 | } |
368 | ||
369 | /* TODO: | |
370 | * DOES method | |
371 | */ | |
372 | ||
9bf25cf0 PE |
373 | struct xpvhv_aux *aux = HvAUX(stash); |
374 | aux->xhv_class_superclass = NULL; | |
e3b003dd | 375 | aux->xhv_class_initfields_cv = NULL; |
9bf25cf0 PE |
376 | aux->xhv_class_adjust_blocks = NULL; |
377 | aux->xhv_class_fields = NULL; | |
378 | aux->xhv_class_next_fieldix = 0; | |
d8b29a34 | 379 | aux->xhv_class_param_map = NULL; |
99b497aa | 380 | |
9bf25cf0 | 381 | aux->xhv_aux_flags |= HvAUXf_IS_CLASS; |
99b497aa PE |
382 | |
383 | SAVEDESTRUCTOR_X(invoke_class_seal, stash); | |
054ceeeb PE |
384 | |
385 | /* Prepare a suspended compcv for parsing field init expressions */ | |
386 | { | |
387 | I32 floor_ix = start_subparse(FALSE, 0); | |
388 | ||
389 | CvIsMETHOD_on(PL_compcv); | |
390 | ||
391 | /* We don't want to make `$self` visible during the expression but we | |
392 | * still need to give it a name. Make it unusable from pure perl | |
393 | */ | |
394 | PADOFFSET padix = pad_add_name_pvs("$(self)", 0, NULL, NULL); | |
395 | assert(padix == PADIX_SELF); | |
d8b29a34 PE |
396 | |
397 | padix = pad_add_name_pvs("%(params)", 0, NULL, NULL); | |
398 | assert(padix == PADIX_PARAMS); | |
399 | ||
054ceeeb PE |
400 | PERL_UNUSED_VAR(padix); |
401 | ||
402 | Newx(aux->xhv_class_suspended_initfields_compcv, 1, struct suspended_compcv); | |
403 | suspend_compcv(aux->xhv_class_suspended_initfields_compcv); | |
404 | ||
405 | LEAVE_SCOPE(floor_ix); | |
406 | } | |
99b497aa PE |
407 | } |
408 | ||
9bf25cf0 PE |
409 | #define split_package_ver(value, pkgname, pkgversion) S_split_package_ver(aTHX_ value, pkgname, pkgversion) |
410 | static const char *S_split_package_ver(pTHX_ SV *value, SV *pkgname, SV *pkgversion) | |
411 | { | |
412 | const char *start = SvPVX(value), | |
413 | *p = start, | |
414 | *end = start + SvCUR(value); | |
415 | ||
416 | while(*p && !isSPACE_utf8_safe(p, end)) | |
417 | p += UTF8SKIP(p); | |
418 | ||
419 | sv_setpvn(pkgname, start, p - start); | |
420 | if(SvUTF8(value)) | |
421 | SvUTF8_on(pkgname); | |
422 | ||
423 | while(*p && isSPACE_utf8_safe(p, end)) | |
424 | p += UTF8SKIP(p); | |
425 | ||
426 | if(*p) { | |
427 | /* scan_version() gets upset about trailing content. We need to extract | |
428 | * exactly what it wants | |
429 | */ | |
430 | start = p; | |
431 | if(*p == 'v') | |
432 | p++; | |
433 | while(*p && strchr("0123456789._", *p)) | |
434 | p++; | |
435 | SV *tmpsv = newSVpvn(start, p - start); | |
436 | SAVEFREESV(tmpsv); | |
437 | ||
438 | scan_version(SvPVX(tmpsv), pkgversion, FALSE); | |
439 | } | |
440 | ||
441 | while(*p && isSPACE_utf8_safe(p, end)) | |
442 | p += UTF8SKIP(p); | |
443 | ||
444 | return p; | |
445 | } | |
446 | ||
447 | #define ensure_module_version(module, version) S_ensure_module_version(aTHX_ module, version) | |
448 | static void S_ensure_module_version(pTHX_ SV *module, SV *version) | |
449 | { | |
9bf25cf0 PE |
450 | ENTER; |
451 | ||
6b845fdb DM |
452 | PUSHMARK(PL_stack_sp); |
453 | rpp_xpush_2(module, version); | |
9bf25cf0 PE |
454 | call_method("VERSION", G_VOID); |
455 | ||
456 | LEAVE; | |
457 | } | |
458 | ||
311ca5ba PE |
459 | #define split_attr_nameval(sv, namp, valp) S_split_attr_nameval(aTHX_ sv, namp, valp) |
460 | static void S_split_attr_nameval(pTHX_ SV *sv, SV **namp, SV **valp) | |
461 | { | |
462 | STRLEN svlen = SvCUR(sv); | |
463 | bool do_utf8 = SvUTF8(sv); | |
464 | ||
465 | const char *paren_at = (const char *)memchr(SvPVX(sv), '(', svlen); | |
466 | if(paren_at) { | |
467 | STRLEN namelen = paren_at - SvPVX(sv); | |
468 | ||
469 | if(SvPVX(sv)[svlen-1] != ')') | |
470 | /* Should be impossible to reach this by parsing regular perl code | |
471 | * by as class_apply_attributes() is XS-visible API it might still | |
472 | * be reachable. As it's likely unreachable by normal perl code, | |
473 | * don't bother listing it in perldiag. | |
474 | */ | |
475 | /* diag_listed_as: SKIPME */ | |
476 | croak("Malformed attribute string"); | |
477 | *namp = sv_2mortal(newSVpvn_utf8(SvPVX(sv), namelen, do_utf8)); | |
478 | ||
479 | const char *value_at = paren_at + 1; | |
480 | const char *value_max = SvPVX(sv) + svlen - 2; | |
481 | ||
482 | /* TODO: We're only obeying ASCII whitespace here */ | |
483 | ||
484 | /* Trim whitespace at the start */ | |
485 | while(value_at < value_max && isSPACE(*value_at)) | |
486 | value_at += 1; | |
487 | while(value_max > value_at && isSPACE(*value_max)) | |
488 | value_max -= 1; | |
489 | ||
490 | if(value_max >= value_at) | |
491 | *valp = sv_2mortal(newSVpvn_utf8(value_at, value_max - value_at + 1, do_utf8)); | |
492 | } | |
493 | else { | |
494 | *namp = sv; | |
495 | *valp = NULL; | |
496 | } | |
497 | } | |
498 | ||
9bf25cf0 PE |
499 | static void |
500 | apply_class_attribute_isa(pTHX_ HV *stash, SV *value) | |
501 | { | |
502 | assert(HvSTASH_IS_CLASS(stash)); | |
503 | struct xpvhv_aux *aux = HvAUX(stash); | |
504 | ||
505 | /* Parse `value` into name + version */ | |
506 | SV *superclassname = sv_newmortal(), *superclassver = sv_newmortal(); | |
507 | const char *end = split_package_ver(value, superclassname, superclassver); | |
508 | if(*end) | |
509 | croak("Unexpected characters while parsing class :isa attribute: %s", end); | |
510 | ||
511 | if(aux->xhv_class_superclass) | |
512 | croak("Class already has a superclass, cannot add another"); | |
513 | ||
514 | HV *superstash = gv_stashsv(superclassname, 0); | |
bcd084d7 | 515 | if (!superstash || !HvSTASH_IS_CLASS(superstash)) { |
9bf25cf0 PE |
516 | /* Try to `require` the module then attempt a second time */ |
517 | load_module(PERL_LOADMOD_NOIMPORT, newSVsv(superclassname), NULL, NULL); | |
518 | superstash = gv_stashsv(superclassname, 0); | |
519 | } | |
520 | if(!superstash || !HvSTASH_IS_CLASS(superstash)) | |
521 | /* TODO: This would be a useful feature addition */ | |
522 | croak("Class :isa attribute requires a class but %" HvNAMEf_QUOTEDPREFIX " is not one", | |
523 | HvNAMEfARG(superstash)); | |
524 | ||
525 | if(superclassver && SvOK(superclassver)) | |
526 | ensure_module_version(superclassname, superclassver); | |
527 | ||
528 | /* TODO: Suuuurely there's a way to fetch this neatly with stash + "ISA" | |
529 | * You'd think that GvAV() of hv_fetchs() would do it, but no, because it | |
530 | * won't lazily create a proper (magical) GV if one didn't already exist. | |
531 | */ | |
9bf25cf0 PE |
532 | { |
533 | SV *isaname = newSVpvf("%" HEKf "::ISA", HvNAME_HEK(stash)); | |
534 | sv_2mortal(isaname); | |
535 | ||
e51627af PE |
536 | AV *isa = get_av(SvPV_nolen(isaname), GV_ADD | (SvFLAGS(isaname) & SVf_UTF8)); |
537 | ||
538 | ENTER; | |
539 | ||
540 | /* Temporarily remove the SVf_READONLY flag */ | |
541 | SAVESETSVFLAGS((SV *)isa, SVf_READONLY|SVf_PROTECT, SVf_READONLY|SVf_PROTECT); | |
542 | SvREADONLY_off((SV *)isa); | |
543 | ||
544 | av_push(isa, newSVsv(value)); | |
545 | ||
546 | LEAVE; | |
9bf25cf0 | 547 | } |
9bf25cf0 PE |
548 | |
549 | aux->xhv_class_superclass = (HV *)SvREFCNT_inc(superstash); | |
550 | ||
551 | struct xpvhv_aux *superaux = HvAUX(superstash); | |
552 | ||
553 | aux->xhv_class_next_fieldix = superaux->xhv_class_next_fieldix; | |
554 | ||
555 | if(superaux->xhv_class_adjust_blocks) { | |
556 | if(!aux->xhv_class_adjust_blocks) | |
557 | aux->xhv_class_adjust_blocks = newAV(); | |
558 | ||
f1adf80b | 559 | for(SSize_t i = 0; i <= AvFILL(superaux->xhv_class_adjust_blocks); i++) |
9bf25cf0 PE |
560 | av_push(aux->xhv_class_adjust_blocks, AvARRAY(superaux->xhv_class_adjust_blocks)[i]); |
561 | } | |
d8b29a34 PE |
562 | |
563 | if(superaux->xhv_class_param_map) { | |
564 | aux->xhv_class_param_map = newHVhv(superaux->xhv_class_param_map); | |
565 | } | |
9bf25cf0 PE |
566 | } |
567 | ||
69953ef3 PE |
568 | static struct { |
569 | const char *name; | |
570 | bool requires_value; | |
571 | void (*apply)(pTHX_ HV *stash, SV *value); | |
572 | } const class_attributes[] = { | |
9bf25cf0 PE |
573 | { .name = "isa", |
574 | .requires_value = true, | |
575 | .apply = &apply_class_attribute_isa, | |
576 | }, | |
cb6b3bdb | 577 | { NULL, false, NULL } |
69953ef3 PE |
578 | }; |
579 | ||
580 | static void | |
581 | S_class_apply_attribute(pTHX_ HV *stash, OP *attr) | |
582 | { | |
583 | assert(attr->op_type == OP_CONST); | |
69953ef3 | 584 | |
311ca5ba PE |
585 | SV *name, *value; |
586 | split_attr_nameval(cSVOPx_sv(attr), &name, &value); | |
69953ef3 PE |
587 | |
588 | for(int i = 0; class_attributes[i].name; i++) { | |
589 | /* TODO: These attribute names are not UTF-8 aware */ | |
590 | if(!strEQ(SvPVX(name), class_attributes[i].name)) | |
591 | continue; | |
592 | ||
593 | if(class_attributes[i].requires_value && !(value && SvOK(value))) | |
594 | croak("Class attribute %" SVf " requires a value", SVfARG(name)); | |
595 | ||
596 | (*class_attributes[i].apply)(aTHX_ stash, value); | |
597 | return; | |
598 | } | |
599 | ||
600 | croak("Unrecognized class attribute %" SVf, SVfARG(name)); | |
601 | } | |
602 | ||
603 | void | |
604 | Perl_class_apply_attributes(pTHX_ HV *stash, OP *attrlist) | |
605 | { | |
9bf25cf0 PE |
606 | PERL_ARGS_ASSERT_CLASS_APPLY_ATTRIBUTES; |
607 | ||
04c0207e PE |
608 | if(!attrlist) |
609 | return; | |
610 | if(attrlist->op_type == OP_NULL) { | |
611 | op_free(attrlist); | |
612 | return; | |
613 | } | |
614 | ||
69953ef3 PE |
615 | if(attrlist->op_type == OP_LIST) { |
616 | OP *o = cLISTOPx(attrlist)->op_first; | |
617 | assert(o->op_type == OP_PUSHMARK); | |
618 | o = OpSIBLING(o); | |
619 | ||
620 | for(; o; o = OpSIBLING(o)) | |
621 | S_class_apply_attribute(aTHX_ stash, o); | |
622 | } | |
623 | else | |
624 | S_class_apply_attribute(aTHX_ stash, attrlist); | |
04c0207e PE |
625 | |
626 | op_free(attrlist); | |
69953ef3 PE |
627 | } |
628 | ||
99b497aa PE |
629 | void |
630 | Perl_class_seal_stash(pTHX_ HV *stash) | |
631 | { | |
632 | PERL_ARGS_ASSERT_CLASS_SEAL_STASH; | |
633 | ||
e3b003dd PE |
634 | assert(HvSTASH_IS_CLASS(stash)); |
635 | struct xpvhv_aux *aux = HvAUX(stash); | |
636 | ||
080297a1 TC |
637 | if (PL_parser->error_count == 0) { |
638 | /* generate initfields CV */ | |
054ceeeb PE |
639 | I32 floor_ix = PL_savestack_ix; |
640 | SAVEI32(PL_subline); | |
641 | save_item(PL_subname); | |
642 | ||
643 | resume_compcv_final(aux->xhv_class_suspended_initfields_compcv); | |
644 | ||
645 | /* Some OP_INITFIELD ops will need to populate the pad with their | |
646 | * result because later ops will rely on it. There's no need to do | |
647 | * this for every op though. Store a mapping to work out which ones | |
648 | * we'll need. | |
649 | */ | |
650 | PADNAMELIST *pnl = PadlistNAMES(CvPADLIST(PL_compcv)); | |
651 | HV *fieldix_to_padix = newHV(); | |
652 | SAVEFREESV((SV *)fieldix_to_padix); | |
653 | ||
654 | /* padix 0 == @_; padix 1 == $self. Start at 2 */ | |
655 | for(PADOFFSET padix = 2; padix <= PadnamelistMAX(pnl); padix++) { | |
656 | PADNAME *pn = PadnamelistARRAY(pnl)[padix]; | |
657 | if(!pn || !PadnameIsFIELD(pn)) | |
658 | continue; | |
659 | ||
660 | U32 fieldix = PadnameFIELDINFO(pn)->fieldix; | |
d2d18d7c | 661 | (void)hv_store_ent(fieldix_to_padix, sv_2mortal(newSVuv(fieldix)), newSVuv(padix), 0); |
054ceeeb PE |
662 | } |
663 | ||
664 | OP *ops = NULL; | |
665 | ||
666 | ops = op_append_list(OP_LINESEQ, ops, | |
d8b29a34 | 667 | newUNOP_AUX(OP_METHSTART, OPpINITFIELDS << 8, NULL, NULL)); |
054ceeeb PE |
668 | |
669 | if(aux->xhv_class_superclass) { | |
670 | HV *superstash = aux->xhv_class_superclass; | |
671 | assert(HvSTASH_IS_CLASS(superstash)); | |
672 | struct xpvhv_aux *superaux = HvAUX(superstash); | |
673 | ||
674 | /* Build an OP_ENTERSUB */ | |
2e1462eb PE |
675 | OP *o = newLISTOPn(OP_ENTERSUB, OPf_WANT_VOID|OPf_STACKED, |
676 | newPADxVOP(OP_PADSV, 0, PADIX_SELF), | |
677 | newPADxVOP(OP_PADHV, OPf_REF, PADIX_PARAMS), | |
678 | /* TODO: This won't work at all well under `use threads` because | |
679 | * it embeds the CV * to the superclass initfields CV right into | |
680 | * the optree. Maybe we'll have to pop it in the pad or something | |
681 | */ | |
682 | newSVOP(OP_CONST, 0, (SV *)superaux->xhv_class_initfields_cv), | |
683 | NULL); | |
684 | ||
685 | ops = op_append_list(OP_LINESEQ, ops, o); | |
054ceeeb PE |
686 | } |
687 | ||
688 | PADNAMELIST *fieldnames = aux->xhv_class_fields; | |
689 | ||
f1adf80b | 690 | for(SSize_t i = 0; fieldnames && i <= PadnamelistMAX(fieldnames); i++) { |
054ceeeb PE |
691 | PADNAME *pn = PadnamelistARRAY(fieldnames)[i]; |
692 | char sigil = PadnamePV(pn)[0]; | |
693 | PADOFFSET fieldix = PadnameFIELDINFO(pn)->fieldix; | |
694 | ||
695 | /* Extract the OP_{NEXT,DB}STATE op from the defop so we can | |
696 | * splice it in | |
697 | */ | |
698 | OP *valop = PadnameFIELDINFO(pn)->defop; | |
699 | if(valop && valop->op_type == OP_LINESEQ) { | |
700 | OP *o = cLISTOPx(valop)->op_first; | |
701 | cLISTOPx(valop)->op_first = NULL; | |
702 | cLISTOPx(valop)->op_last = NULL; | |
703 | /* have to clear the OPf_KIDS flag or op_free() will get upset */ | |
704 | valop->op_flags &= ~OPf_KIDS; | |
705 | op_free(valop); | |
054ceeeb PE |
706 | |
707 | OP *fieldcop = o; | |
708 | assert(fieldcop->op_type == OP_NEXTSTATE || fieldcop->op_type == OP_DBSTATE); | |
709 | o = OpSIBLING(o); | |
710 | OpLASTSIB_set(fieldcop, NULL); | |
711 | ||
712 | valop = o; | |
713 | OpLASTSIB_set(valop, NULL); | |
714 | ||
715 | ops = op_append_list(OP_LINESEQ, ops, fieldcop); | |
716 | } | |
717 | ||
d8b29a34 PE |
718 | SV *paramname = PadnameFIELDINFO(pn)->paramname; |
719 | ||
054ceeeb PE |
720 | U8 op_priv = 0; |
721 | switch(sigil) { | |
722 | case '$': | |
d8b29a34 | 723 | if(paramname) { |
2e1462eb PE |
724 | if(!valop) { |
725 | SV *message = | |
d8b29a34 | 726 | newSVpvf("Required parameter '%" SVf "' is missing for %" HvNAMEf_QUOTEDPREFIX " constructor", |
2e1462eb PE |
727 | SVfARG(paramname), HvNAMEfARG(stash)); |
728 | valop = newLISTOPn(OP_DIE, 0, | |
729 | newSVOP(OP_CONST, 0, message), | |
730 | NULL); | |
731 | } | |
d8b29a34 PE |
732 | |
733 | OP *helemop = | |
734 | newBINOP(OP_HELEM, 0, | |
735 | newPADxVOP(OP_PADHV, OPf_REF, PADIX_PARAMS), | |
736 | newSVOP(OP_CONST, 0, SvREFCNT_inc(paramname))); | |
737 | ||
738 | if(PadnameFIELDINFO(pn)->def_if_undef) { | |
739 | /* delete $params{$paramname} // DEFOP */ | |
740 | valop = newLOGOP(OP_DOR, 0, | |
741 | newUNOP(OP_DELETE, 0, helemop), valop); | |
742 | } | |
743 | else if(PadnameFIELDINFO(pn)->def_if_false) { | |
744 | /* delete $params{$paramname} || DEFOP */ | |
745 | valop = newLOGOP(OP_OR, 0, | |
746 | newUNOP(OP_DELETE, 0, helemop), valop); | |
747 | } | |
748 | else { | |
749 | /* exists $params{$paramname} ? delete $params{$paramname} : DEFOP */ | |
750 | /* more efficient with the new OP_HELEMEXISTSOR */ | |
751 | valop = newLOGOP(OP_HELEMEXISTSOR, OPpHELEMEXISTSOR_DELETE << 8, | |
752 | helemop, valop); | |
753 | } | |
754 | ||
755 | valop = op_contextualize(valop, G_SCALAR); | |
756 | } | |
054ceeeb PE |
757 | break; |
758 | ||
759 | case '@': | |
760 | op_priv = OPpINITFIELD_AV; | |
761 | break; | |
762 | ||
763 | case '%': | |
764 | op_priv = OPpINITFIELD_HV; | |
765 | break; | |
766 | ||
767 | default: | |
768 | NOT_REACHED; | |
769 | } | |
770 | ||
771 | UNOP_AUX_item *aux; | |
d8b29a34 | 772 | Newx(aux, 2, UNOP_AUX_item); |
054ceeeb PE |
773 | |
774 | aux[0].uv = fieldix; | |
775 | ||
776 | OP *fieldop = newUNOP_AUX(OP_INITFIELD, valop ? OPf_STACKED : 0, valop, aux); | |
777 | fieldop->op_private = op_priv; | |
778 | ||
779 | HE *he; | |
780 | if((he = hv_fetch_ent(fieldix_to_padix, sv_2mortal(newSVuv(fieldix)), 0, 0)) && | |
781 | SvOK(HeVAL(he))) { | |
782 | fieldop->op_targ = SvUV(HeVAL(he)); | |
783 | } | |
784 | ||
785 | ops = op_append_list(OP_LINESEQ, ops, fieldop); | |
786 | } | |
e3b003dd | 787 | |
75ea41ae PE |
788 | /* initfields CV should not get class_wrap_method_body() called on its |
789 | * body. pretend it isn't a method for now */ | |
790 | CvIsMETHOD_off(PL_compcv); | |
054ceeeb | 791 | CV *initfields = newATTRSUB(floor_ix, NULL, NULL, NULL, ops); |
75ea41ae | 792 | CvIsMETHOD_on(initfields); |
054ceeeb PE |
793 | |
794 | aux->xhv_class_initfields_cv = initfields; | |
e3b003dd | 795 | } |
080297a1 TC |
796 | else { |
797 | /* we had errors, clean up and don't populate initfields */ | |
798 | PADNAMELIST *fieldnames = aux->xhv_class_fields; | |
799 | if (fieldnames) { | |
800 | for(SSize_t i = PadnamelistMAX(fieldnames); i >= 0 ; i--) { | |
801 | PADNAME *pn = PadnamelistARRAY(fieldnames)[i]; | |
ee5597d8 | 802 | op_free(PadnameFIELDINFO(pn)->defop); |
080297a1 TC |
803 | } |
804 | } | |
805 | } | |
99b497aa PE |
806 | } |
807 | ||
808 | void | |
054ceeeb PE |
809 | Perl_class_prepare_initfield_parse(pTHX) |
810 | { | |
811 | PERL_ARGS_ASSERT_CLASS_PREPARE_INITFIELD_PARSE; | |
812 | ||
813 | assert(HvSTASH_IS_CLASS(PL_curstash)); | |
814 | struct xpvhv_aux *aux = HvAUX(PL_curstash); | |
815 | ||
816 | resume_compcv_and_save(aux->xhv_class_suspended_initfields_compcv); | |
817 | CvOUTSIDE_SEQ(PL_compcv) = PL_cop_seqmax; | |
818 | } | |
819 | ||
820 | void | |
99b497aa PE |
821 | Perl_class_prepare_method_parse(pTHX_ CV *cv) |
822 | { | |
823 | PERL_ARGS_ASSERT_CLASS_PREPARE_METHOD_PARSE; | |
824 | ||
825 | assert(cv == PL_compcv); | |
826 | assert(HvSTASH_IS_CLASS(PL_curstash)); | |
827 | ||
828 | /* We expect this to be at the start of sub parsing, so there won't be | |
829 | * anything in the pad yet | |
830 | */ | |
831 | assert(PL_comppad_name_fill == 0); | |
832 | ||
833 | PADOFFSET padix; | |
834 | ||
835 | padix = pad_add_name_pvs("$self", 0, NULL, NULL); | |
836 | assert(padix == PADIX_SELF); | |
837 | PERL_UNUSED_VAR(padix); | |
838 | ||
839 | intro_my(); | |
840 | ||
841 | CvNOWARN_AMBIGUOUS_on(cv); | |
842 | CvIsMETHOD_on(cv); | |
843 | } | |
844 | ||
845 | OP * | |
846 | Perl_class_wrap_method_body(pTHX_ OP *o) | |
847 | { | |
848 | PERL_ARGS_ASSERT_CLASS_WRAP_METHOD_BODY; | |
849 | ||
850 | if(!o) | |
851 | return o; | |
852 | ||
853 | PADNAMELIST *pnl = PadlistNAMES(CvPADLIST(PL_compcv)); | |
854 | ||
855 | AV *fieldmap = newAV(); | |
856 | UV max_fieldix = 0; | |
857 | SAVEFREESV((SV *)fieldmap); | |
858 | ||
859 | /* padix 0 == @_; padix 1 == $self. Start at 2 */ | |
860 | for(PADOFFSET padix = 2; padix <= PadnamelistMAX(pnl); padix++) { | |
861 | PADNAME *pn = PadnamelistARRAY(pnl)[padix]; | |
862 | if(!pn || !PadnameIsFIELD(pn)) | |
863 | continue; | |
864 | ||
865 | U32 fieldix = PadnameFIELDINFO(pn)->fieldix; | |
866 | if(fieldix > max_fieldix) | |
867 | max_fieldix = fieldix; | |
868 | ||
f357b86a RL |
869 | av_push_simple(fieldmap, newSVuv(padix)); |
870 | av_push_simple(fieldmap, newSVuv(fieldix)); | |
99b497aa PE |
871 | } |
872 | ||
873 | UNOP_AUX_item *aux = NULL; | |
874 | ||
875 | if(av_count(fieldmap)) { | |
876 | Newx(aux, 2 + av_count(fieldmap), UNOP_AUX_item); | |
877 | ||
878 | UNOP_AUX_item *ap = aux; | |
879 | ||
880 | (ap++)->uv = av_count(fieldmap) / 2; | |
881 | (ap++)->uv = max_fieldix; | |
882 | ||
883 | for(Size_t i = 0; i < av_count(fieldmap); i++) | |
884 | (ap++)->uv = SvUV(AvARRAY(fieldmap)[i]); | |
885 | } | |
886 | ||
887 | /* If this is an empty method body then o will be an OP_STUB and not a | |
888 | * list. This will confuse op_sibling_splice() */ | |
889 | if(o->op_type != OP_LINESEQ) | |
890 | o = newLISTOP(OP_LINESEQ, 0, o, NULL); | |
891 | ||
892 | op_sibling_splice(o, NULL, 0, newUNOP_AUX(OP_METHSTART, 0, NULL, aux)); | |
893 | ||
894 | return o; | |
895 | } | |
896 | ||
897 | void | |
898 | Perl_class_add_field(pTHX_ HV *stash, PADNAME *pn) | |
899 | { | |
900 | PERL_ARGS_ASSERT_CLASS_ADD_FIELD; | |
901 | ||
902 | assert(HvSTASH_IS_CLASS(stash)); | |
903 | struct xpvhv_aux *aux = HvAUX(stash); | |
904 | ||
905 | PADOFFSET fieldix = aux->xhv_class_next_fieldix; | |
906 | aux->xhv_class_next_fieldix++; | |
907 | ||
d8b29a34 | 908 | Newxz(PadnameFIELDINFO(pn), 1, struct padname_fieldinfo); |
99b497aa PE |
909 | PadnameFLAGS(pn) |= PADNAMEf_FIELD; |
910 | ||
04c0207e | 911 | PadnameFIELDINFO(pn)->refcount = 1; |
99b497aa PE |
912 | PadnameFIELDINFO(pn)->fieldix = fieldix; |
913 | PadnameFIELDINFO(pn)->fieldstash = (HV *)SvREFCNT_inc(stash); | |
914 | ||
915 | if(!aux->xhv_class_fields) | |
916 | aux->xhv_class_fields = newPADNAMELIST(0); | |
917 | ||
918 | padnamelist_store(aux->xhv_class_fields, PadnamelistMAX(aux->xhv_class_fields)+1, pn); | |
919 | PadnameREFCNT_inc(pn); | |
920 | } | |
921 | ||
d8b29a34 PE |
922 | static void |
923 | apply_field_attribute_param(pTHX_ PADNAME *pn, SV *value) | |
924 | { | |
925 | if(!value) | |
926 | /* Default to name minus the sigil */ | |
927 | value = newSVpvn_utf8(PadnamePV(pn) + 1, PadnameLEN(pn) - 1, PadnameUTF8(pn)); | |
928 | ||
929 | if(PadnamePV(pn)[0] != '$') | |
930 | croak("Only scalar fields can take a :param attribute"); | |
931 | ||
932 | if(PadnameFIELDINFO(pn)->paramname) | |
933 | croak("Field already has a parameter name, cannot add another"); | |
934 | ||
935 | HV *stash = PadnameFIELDINFO(pn)->fieldstash; | |
936 | assert(HvSTASH_IS_CLASS(stash)); | |
937 | struct xpvhv_aux *aux = HvAUX(stash); | |
938 | ||
939 | if(aux->xhv_class_param_map && | |
940 | hv_exists_ent(aux->xhv_class_param_map, value, 0)) | |
941 | croak("Cannot assign :param(%" SVf ") to field %" SVf " because that name is already in use", | |
942 | SVfARG(value), SVfARG(PadnameSV(pn))); | |
943 | ||
944 | PadnameFIELDINFO(pn)->paramname = SvREFCNT_inc(value); | |
945 | ||
946 | if(!aux->xhv_class_param_map) | |
947 | aux->xhv_class_param_map = newHV(); | |
948 | ||
d2d18d7c | 949 | (void)hv_store_ent(aux->xhv_class_param_map, value, newSVuv(PadnameFIELDINFO(pn)->fieldix), 0); |
d8b29a34 PE |
950 | } |
951 | ||
311ca5ba PE |
952 | static struct { |
953 | const char *name; | |
954 | bool requires_value; | |
955 | void (*apply)(pTHX_ PADNAME *pn, SV *value); | |
956 | } const field_attributes[] = { | |
d8b29a34 PE |
957 | { .name = "param", |
958 | .requires_value = false, | |
959 | .apply = &apply_field_attribute_param, | |
960 | }, | |
cb6b3bdb | 961 | { NULL, false, NULL } |
311ca5ba PE |
962 | }; |
963 | ||
964 | static void | |
965 | S_class_apply_field_attribute(pTHX_ PADNAME *pn, OP *attr) | |
966 | { | |
967 | assert(attr->op_type == OP_CONST); | |
968 | ||
969 | SV *name, *value; | |
970 | split_attr_nameval(cSVOPx_sv(attr), &name, &value); | |
971 | ||
972 | for(int i = 0; field_attributes[i].name; i++) { | |
973 | /* TODO: These attribute names are not UTF-8 aware */ | |
974 | if(!strEQ(SvPVX(name), field_attributes[i].name)) | |
975 | continue; | |
976 | ||
977 | if(field_attributes[i].requires_value && !(value && SvOK(value))) | |
978 | croak("Field attribute %" SVf " requires a value", SVfARG(name)); | |
979 | ||
980 | (*field_attributes[i].apply)(aTHX_ pn, value); | |
981 | return; | |
982 | } | |
983 | ||
984 | croak("Unrecognized field attribute %" SVf, SVfARG(name)); | |
985 | } | |
986 | ||
987 | void | |
988 | Perl_class_apply_field_attributes(pTHX_ PADNAME *pn, OP *attrlist) | |
989 | { | |
990 | PERL_ARGS_ASSERT_CLASS_APPLY_FIELD_ATTRIBUTES; | |
991 | ||
04c0207e PE |
992 | if(!attrlist) |
993 | return; | |
994 | if(attrlist->op_type == OP_NULL) { | |
995 | op_free(attrlist); | |
311ca5ba | 996 | return; |
04c0207e | 997 | } |
311ca5ba PE |
998 | |
999 | if(attrlist->op_type == OP_LIST) { | |
1000 | OP *o = cLISTOPx(attrlist)->op_first; | |
1001 | assert(o->op_type == OP_PUSHMARK); | |
1002 | o = OpSIBLING(o); | |
1003 | ||
1004 | for(; o; o = OpSIBLING(o)) | |
1005 | S_class_apply_field_attribute(aTHX_ pn, o); | |
1006 | } | |
1007 | else | |
1008 | S_class_apply_field_attribute(aTHX_ pn, attrlist); | |
04c0207e PE |
1009 | |
1010 | op_free(attrlist); | |
311ca5ba PE |
1011 | } |
1012 | ||
99b497aa | 1013 | void |
d8b29a34 | 1014 | Perl_class_set_field_defop(pTHX_ PADNAME *pn, OPCODE defmode, OP *defop) |
054ceeeb PE |
1015 | { |
1016 | PERL_ARGS_ASSERT_CLASS_SET_FIELD_DEFOP; | |
1017 | ||
d8b29a34 PE |
1018 | assert(defmode == 0 || defmode == OP_ORASSIGN || defmode == OP_DORASSIGN); |
1019 | ||
054ceeeb PE |
1020 | assert(HvSTASH_IS_CLASS(PL_curstash)); |
1021 | ||
ee5597d8 | 1022 | op_free(PadnameFIELDINFO(pn)->defop); |
054ceeeb | 1023 | |
080297a1 TC |
1024 | /* set here to ensure clean up if forbid_outofblock_ops() throws */ |
1025 | PadnameFIELDINFO(pn)->defop = defop; | |
1026 | ||
1027 | forbid_outofblock_ops(defop, "field initialiser expression"); | |
1028 | ||
054ceeeb PE |
1029 | char sigil = PadnamePV(pn)[0]; |
1030 | switch(sigil) { | |
1031 | case '$': | |
1032 | defop = op_contextualize(defop, G_SCALAR); | |
1033 | break; | |
1034 | ||
1035 | case '@': | |
1036 | case '%': | |
1037 | defop = op_contextualize(op_force_list(defop), G_LIST); | |
1038 | break; | |
1039 | } | |
1040 | ||
1041 | PadnameFIELDINFO(pn)->defop = newLISTOP(OP_LINESEQ, 0, | |
1042 | newSTATEOP(0, NULL, NULL), defop); | |
d8b29a34 PE |
1043 | switch(defmode) { |
1044 | case OP_DORASSIGN: | |
1045 | PadnameFIELDINFO(pn)->def_if_undef = true; | |
1046 | break; | |
1047 | case OP_ORASSIGN: | |
1048 | PadnameFIELDINFO(pn)->def_if_false = true; | |
1049 | break; | |
1050 | } | |
054ceeeb PE |
1051 | } |
1052 | ||
1053 | void | |
99b497aa PE |
1054 | Perl_class_add_ADJUST(pTHX_ HV *stash, CV *cv) |
1055 | { | |
1056 | PERL_ARGS_ASSERT_CLASS_ADD_ADJUST; | |
1057 | ||
1058 | assert(HvSTASH_IS_CLASS(stash)); | |
1059 | struct xpvhv_aux *aux = HvAUX(stash); | |
1060 | ||
1061 | if(!aux->xhv_class_adjust_blocks) | |
1062 | aux->xhv_class_adjust_blocks = newAV(); | |
1063 | ||
1064 | av_push(aux->xhv_class_adjust_blocks, (SV *)cv); | |
1065 | } | |
1066 | ||
63119cca PE |
1067 | OP * |
1068 | Perl_ck_classname(pTHX_ OP *o) | |
1069 | { | |
1070 | if(!CvIsMETHOD(PL_compcv)) | |
1071 | croak("Cannot use __CLASS__ outside of a method or field initializer expression"); | |
1072 | ||
1073 | return o; | |
1074 | } | |
1075 | ||
1076 | PP(pp_classname) | |
1077 | { | |
63119cca PE |
1078 | dTARGET; |
1079 | ||
1080 | SV *self = PAD_SVl(PADIX_SELF); | |
1081 | assert(SvTYPE(SvRV(self)) == SVt_PVOBJ); | |
1082 | ||
6b845fdb | 1083 | rpp_xpush_1(TARG); |
63119cca PE |
1084 | sv_ref(TARG, SvRV(self), true); |
1085 | ||
6b845fdb | 1086 | return NORMAL; |
63119cca PE |
1087 | } |
1088 | ||
99b497aa PE |
1089 | /* |
1090 | * ex: set ts=8 sts=4 sw=4 et: | |
1091 | */ |