1 /* sv_inline.h
2 *
3 * Copyright (C) 2022 by Larry Wall 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 newSV_type and newSV_type_mortal functions, as well as
11 * the various struct and macro definitions they require. In the main, these
12 * definitions were moved from sv.c, where many of them continue to also be used.
13 * (In Perl_more_bodies, Perl_sv_upgrade and Perl_sv_clear, for example.) Code
14 * comments associated with definitions and functions were also copied across
15 * verbatim.
16 *
17 * The rationale for having these as inline functions, rather than in sv.c, is
18 * that the target type is very often known at compile time, and therefore
19 * optimum code can be emitted by the compiler, rather than having all calls
20 * traverse the many branches of Perl_sv_upgrade at runtime.
21 */
22
23 /* This definition came from perl.h*/
24
25 /* The old value was hard coded at 1008. (4096-16) seems to be a bit faster,
26 at least on FreeBSD. YMMV, so experiment. */
27 #ifndef PERL_ARENA_SIZE
28 #define PERL_ARENA_SIZE 4080
29 #endif
30
31 /* All other pre-existing definitions and functions that were moved into this
32 * file originally came from sv.c. */
33
34 #ifdef PERL_POISON
35 # define SvARENA_CHAIN(sv) ((sv)->sv_u.svu_rv)
36 # define SvARENA_CHAIN_SET(sv,val) (sv)->sv_u.svu_rv = MUTABLE_SV((val))
37 /* Whilst I'd love to do this, it seems that things like to check on
38 unreferenced scalars
39 # define POISON_SV_HEAD(sv) PoisonNew(sv, 1, struct STRUCT_SV)
40 */
41 # define POISON_SV_HEAD(sv) PoisonNew(&SvANY(sv), 1, void *), \
42 PoisonNew(&SvREFCNT(sv), 1, U32)
43 #else
44 # define SvARENA_CHAIN(sv) SvANY(sv)
45 # define SvARENA_CHAIN_SET(sv,val) SvANY(sv) = (void *)(val)
46 # define POISON_SV_HEAD(sv)
47 #endif
48
49 #ifdef PERL_MEM_LOG
50 # define MEM_LOG_NEW_SV(sv, file, line, func) \
51 Perl_mem_log_new_sv(sv, file, line, func)
52 # define MEM_LOG_DEL_SV(sv, file, line, func) \
53 Perl_mem_log_del_sv(sv, file, line, func)
54 #else
55 # define MEM_LOG_NEW_SV(sv, file, line, func) NOOP
56 # define MEM_LOG_DEL_SV(sv, file, line, func) NOOP
57 #endif
58
59 #define uproot_SV(p) \
60 STMT_START { \
61 (p) = PL_sv_root; \
62 PL_sv_root = MUTABLE_SV(SvARENA_CHAIN(p)); \
63 ++PL_sv_count; \
64 } STMT_END
65
66 /* Perl_more_sv lives in sv.c, we don't want to inline it.
67 * but the function declaration seems to be needed. */
68 SV* Perl_more_sv(pTHX);
69
70 /* new_SV(): return a new, empty SV head */
71
72 #ifdef DEBUG_LEAKING_SCALARS
73 /* provide a real function for a debugger to play with */
74 STATIC SV*
S_new_SV(pTHX_ const char * file,int line,const char * func)75 S_new_SV(pTHX_ const char *file, int line, const char *func)
76 {
77 SV* sv;
78
79 if (PL_sv_root)
80 uproot_SV(sv);
81 else
82 sv = Perl_more_sv(aTHX);
83 SvANY(sv) = 0;
84 SvREFCNT(sv) = 1;
85 SvFLAGS(sv) = 0;
86 sv->sv_debug_optype = PL_op ? PL_op->op_type : 0;
87 sv->sv_debug_line = (U16) (PL_parser && PL_parser->copline != NOLINE
88 ? PL_parser->copline
89 : PL_curcop
90 ? CopLINE(PL_curcop)
91 : 0
92 );
93 sv->sv_debug_inpad = 0;
94 sv->sv_debug_parent = NULL;
95 sv->sv_debug_file = PL_curcop ? savesharedpv(CopFILE(PL_curcop)): NULL;
96
97 sv->sv_debug_serial = PL_sv_serial++;
98
99 MEM_LOG_NEW_SV(sv, file, line, func);
100 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%" UVxf ": (%05ld) new_SV (from %s:%d [%s])\n",
101 PTR2UV(sv), (long)sv->sv_debug_serial, file, line, func));
102
103 return sv;
104 }
105 # define new_SV(p) (p)=S_new_SV(aTHX_ __FILE__, __LINE__, FUNCTION__)
106
107 #else
108 # define new_SV(p) \
109 STMT_START { \
110 if (PL_sv_root) \
111 uproot_SV(p); \
112 else \
113 (p) = Perl_more_sv(aTHX); \
114 SvANY(p) = 0; \
115 SvREFCNT(p) = 1; \
116 SvFLAGS(p) = 0; \
117 MEM_LOG_NEW_SV(p, __FILE__, __LINE__, FUNCTION__); \
118 } STMT_END
119 #endif
120
121
122 typedef struct xpvhv_with_aux XPVHV_WITH_AUX;
123
124 struct body_details {
125 U8 body_size; /* Size to allocate */
126 U8 copy; /* Size of structure to copy (may be shorter) */
127 U8 offset; /* Size of unalloced ghost fields to first alloced field*/
128 PERL_BITFIELD8 type : 5; /* We have space for a sanity check. */
129 PERL_BITFIELD8 cant_upgrade : 1;/* Cannot upgrade this type */
130 PERL_BITFIELD8 zero_nv : 1; /* zero the NV when upgrading from this */
131 PERL_BITFIELD8 arena : 1; /* Allocated from an arena */
132 U32 arena_size; /* Size of arena to allocate */
133 };
134
135 #define ALIGNED_TYPE_NAME(name) name##_aligned
136 #define ALIGNED_TYPE(name) \
137 typedef union { \
138 name align_me; \
139 NV nv; \
140 IV iv; \
141 } ALIGNED_TYPE_NAME(name)
142
143 ALIGNED_TYPE(regexp);
144 ALIGNED_TYPE(XPVGV);
145 ALIGNED_TYPE(XPVLV);
146 ALIGNED_TYPE(XPVAV);
147 ALIGNED_TYPE(XPVHV);
148 ALIGNED_TYPE(XPVHV_WITH_AUX);
149 ALIGNED_TYPE(XPVCV);
150 ALIGNED_TYPE(XPVFM);
151 ALIGNED_TYPE(XPVIO);
152 ALIGNED_TYPE(XPVOBJ);
153
154 #define HADNV FALSE
155 #define NONV TRUE
156
157
158 #ifdef PURIFY
159 /* With -DPURFIY we allocate everything directly, and don't use arenas.
160 This seems a rather elegant way to simplify some of the code below. */
161 #define HASARENA FALSE
162 #else
163 #define HASARENA TRUE
164 #endif
165 #define NOARENA FALSE
166
167 /* Size the arenas to exactly fit a given number of bodies. A count
168 of 0 fits the max number bodies into a PERL_ARENA_SIZE.block,
169 simplifying the default. If count > 0, the arena is sized to fit
170 only that many bodies, allowing arenas to be used for large, rare
171 bodies (XPVFM, XPVIO) without undue waste. The arena size is
172 limited by PERL_ARENA_SIZE, so we can safely oversize the
173 declarations.
174 */
175 #define FIT_ARENA0(body_size) \
176 ((size_t)(PERL_ARENA_SIZE / body_size) * body_size)
177 #define FIT_ARENAn(count,body_size) \
178 ( count * body_size <= PERL_ARENA_SIZE) \
179 ? count * body_size \
180 : FIT_ARENA0 (body_size)
181 #define FIT_ARENA(count,body_size) \
182 (U32)(count \
183 ? FIT_ARENAn (count, body_size) \
184 : FIT_ARENA0 (body_size))
185
186 /* Calculate the length to copy. Specifically work out the length less any
187 final padding the compiler needed to add. See the comment in sv_upgrade
188 for why copying the padding proved to be a bug. */
189
190 #define copy_length(type, last_member) \
191 STRUCT_OFFSET(type, last_member) \
192 + sizeof (((type*)SvANY((const SV *)0))->last_member)
193
194 static const struct body_details bodies_by_type[] = {
195 /* HEs use this offset for their arena. */
196 { 0, 0, 0, SVt_NULL, FALSE, NONV, NOARENA, 0 },
197
198 /* IVs are in the head, so the allocation size is 0. */
199 { 0,
200 sizeof(IV), /* This is used to copy out the IV body. */
201 STRUCT_OFFSET(XPVIV, xiv_iv), SVt_IV, FALSE, NONV,
202 NOARENA /* IVS don't need an arena */, 0
203 },
204
205 #if NVSIZE <= IVSIZE
206 { 0, sizeof(NV),
207 STRUCT_OFFSET(XPVNV, xnv_u),
208 SVt_NV, FALSE, HADNV, NOARENA, 0 },
209 #else
210 { sizeof(NV), sizeof(NV),
211 STRUCT_OFFSET(XPVNV, xnv_u),
212 SVt_NV, FALSE, HADNV, HASARENA, FIT_ARENA(0, sizeof(NV)) },
213 #endif
214
215 { sizeof(XPV) - STRUCT_OFFSET(XPV, xpv_cur),
216 copy_length(XPV, xpv_len) - STRUCT_OFFSET(XPV, xpv_cur),
217 + STRUCT_OFFSET(XPV, xpv_cur),
218 SVt_PV, FALSE, NONV, HASARENA,
219 FIT_ARENA(0, sizeof(XPV) - STRUCT_OFFSET(XPV, xpv_cur)) },
220
221 { sizeof(XINVLIST) - STRUCT_OFFSET(XPV, xpv_cur),
222 copy_length(XINVLIST, is_offset) - STRUCT_OFFSET(XPV, xpv_cur),
223 + STRUCT_OFFSET(XPV, xpv_cur),
224 SVt_INVLIST, TRUE, NONV, HASARENA,
225 FIT_ARENA(0, sizeof(XINVLIST) - STRUCT_OFFSET(XPV, xpv_cur)) },
226
227 { sizeof(XPVIV) - STRUCT_OFFSET(XPV, xpv_cur),
228 copy_length(XPVIV, xiv_u) - STRUCT_OFFSET(XPV, xpv_cur),
229 + STRUCT_OFFSET(XPV, xpv_cur),
230 SVt_PVIV, FALSE, NONV, HASARENA,
231 FIT_ARENA(0, sizeof(XPVIV) - STRUCT_OFFSET(XPV, xpv_cur)) },
232
233 { sizeof(XPVNV) - STRUCT_OFFSET(XPV, xpv_cur),
234 copy_length(XPVNV, xnv_u) - STRUCT_OFFSET(XPV, xpv_cur),
235 + STRUCT_OFFSET(XPV, xpv_cur),
236 SVt_PVNV, FALSE, HADNV, HASARENA,
237 FIT_ARENA(0, sizeof(XPVNV) - STRUCT_OFFSET(XPV, xpv_cur)) },
238
239 { sizeof(XPVMG), copy_length(XPVMG, xnv_u), 0, SVt_PVMG, FALSE, HADNV,
240 HASARENA, FIT_ARENA(0, sizeof(XPVMG)) },
241
242 { sizeof(ALIGNED_TYPE_NAME(regexp)),
243 sizeof(regexp),
244 0,
245 SVt_REGEXP, TRUE, NONV, HASARENA,
246 FIT_ARENA(0, sizeof(ALIGNED_TYPE_NAME(regexp)))
247 },
248
249 { sizeof(ALIGNED_TYPE_NAME(XPVGV)), sizeof(XPVGV), 0, SVt_PVGV, TRUE, HADNV,
250 HASARENA, FIT_ARENA(0, sizeof(ALIGNED_TYPE_NAME(XPVGV))) },
251
252 { sizeof(ALIGNED_TYPE_NAME(XPVLV)), sizeof(XPVLV), 0, SVt_PVLV, TRUE, HADNV,
253 HASARENA, FIT_ARENA(0, sizeof(ALIGNED_TYPE_NAME(XPVLV))) },
254
255 { sizeof(ALIGNED_TYPE_NAME(XPVAV)),
256 copy_length(XPVAV, xav_alloc),
257 0,
258 SVt_PVAV, TRUE, NONV, HASARENA,
259 FIT_ARENA(0, sizeof(ALIGNED_TYPE_NAME(XPVAV))) },
260
261 { sizeof(ALIGNED_TYPE_NAME(XPVHV)),
262 copy_length(XPVHV, xhv_max),
263 0,
264 SVt_PVHV, TRUE, NONV, HASARENA,
265 FIT_ARENA(0, sizeof(ALIGNED_TYPE_NAME(XPVHV))) },
266
267 { sizeof(ALIGNED_TYPE_NAME(XPVCV)),
268 sizeof(XPVCV),
269 0,
270 SVt_PVCV, TRUE, NONV, HASARENA,
271 FIT_ARENA(0, sizeof(ALIGNED_TYPE_NAME(XPVCV))) },
272
273 { sizeof(ALIGNED_TYPE_NAME(XPVFM)),
274 sizeof(XPVFM),
275 0,
276 SVt_PVFM, TRUE, NONV, NOARENA,
277 FIT_ARENA(20, sizeof(ALIGNED_TYPE_NAME(XPVFM))) },
278
279 { sizeof(ALIGNED_TYPE_NAME(XPVIO)),
280 sizeof(XPVIO),
281 0,
282 SVt_PVIO, TRUE, NONV, HASARENA,
283 FIT_ARENA(24, sizeof(ALIGNED_TYPE_NAME(XPVIO))) },
284
285 { sizeof(ALIGNED_TYPE_NAME(XPVOBJ)),
286 copy_length(XPVOBJ, xobject_fields),
287 0,
288 SVt_PVOBJ, TRUE, NONV, HASARENA,
289 FIT_ARENA(0, sizeof(ALIGNED_TYPE_NAME(XPVOBJ))) },
290 };
291
292 #define new_body_allocated(sv_type) \
293 (void *)((char *)S_new_body(aTHX_ sv_type) \
294 - bodies_by_type[sv_type].offset)
295
296 #ifdef PURIFY
297 #if !(NVSIZE <= IVSIZE)
298 # define new_XNV() safemalloc(sizeof(XPVNV))
299 #endif
300 #define new_XPVNV() safemalloc(sizeof(XPVNV))
301 #define new_XPVMG() safemalloc(sizeof(XPVMG))
302
303 #define del_body_by_type(p, type) safefree(p)
304
305 #else /* !PURIFY */
306
307 #if !(NVSIZE <= IVSIZE)
308 # define new_XNV() new_body_allocated(SVt_NV)
309 #endif
310 #define new_XPVNV() new_body_allocated(SVt_PVNV)
311 #define new_XPVMG() new_body_allocated(SVt_PVMG)
312
313 #define del_body_by_type(p, type) \
314 del_body(p + bodies_by_type[(type)].offset, \
315 &PL_body_roots[(type)])
316
317 #endif /* PURIFY */
318
319 /* no arena for you! */
320
321 #define new_NOARENA(details) \
322 safemalloc((details)->body_size + (details)->offset)
323 #define new_NOARENAZ(details) \
324 safecalloc((details)->body_size + (details)->offset, 1)
325
326 #ifndef PURIFY
327
328 /* grab a new thing from the arena's free list, allocating more if necessary. */
329 #define new_body_from_arena(xpv, root_index, type_meta) \
330 STMT_START { \
331 void ** const r3wt = &PL_body_roots[root_index]; \
332 xpv = (PTR_TBL_ENT_t*) (*((void **)(r3wt)) \
333 ? *((void **)(r3wt)) : Perl_more_bodies(aTHX_ root_index, \
334 type_meta.body_size,\
335 type_meta.arena_size)); \
336 *(r3wt) = *(void**)(xpv); \
337 } STMT_END
338
339 PERL_STATIC_INLINE void *
S_new_body(pTHX_ const svtype sv_type)340 S_new_body(pTHX_ const svtype sv_type)
341 {
342 void *xpv;
343 new_body_from_arena(xpv, sv_type, bodies_by_type[sv_type]);
344 return xpv;
345 }
346
347 #endif
348
349 static const struct body_details fake_rv =
350 { 0, 0, 0, SVt_IV, FALSE, NONV, NOARENA, 0 };
351
352 static const struct body_details fake_hv_with_aux =
353 /* The SVt_IV arena is used for (larger) PVHV bodies. */
354 { sizeof(ALIGNED_TYPE_NAME(XPVHV_WITH_AUX)),
355 copy_length(XPVHV, xhv_max),
356 0,
357 SVt_PVHV, TRUE, NONV, HASARENA,
358 FIT_ARENA(0, sizeof(ALIGNED_TYPE_NAME(XPVHV_WITH_AUX))) };
359
360 /*
361 =for apidoc newSV_type
362
363 Creates a new SV, of the type specified. The reference count for the new SV
364 is set to 1.
365
366 =cut
367 */
368
369 PERL_STATIC_INLINE SV *
Perl_newSV_type(pTHX_ const svtype type)370 Perl_newSV_type(pTHX_ const svtype type)
371 {
372 SV *sv;
373 void* new_body;
374 const struct body_details *type_details;
375
376 new_SV(sv);
377
378 type_details = bodies_by_type + type;
379
380 SvFLAGS(sv) &= ~SVTYPEMASK;
381 SvFLAGS(sv) |= type;
382
383 switch (type) {
384 case SVt_NULL:
385 break;
386 case SVt_IV:
387 SET_SVANY_FOR_BODYLESS_IV(sv);
388 SvIV_set(sv, 0);
389 break;
390 case SVt_NV:
391 #if NVSIZE <= IVSIZE
392 SET_SVANY_FOR_BODYLESS_NV(sv);
393 #else
394 SvANY(sv) = new_XNV();
395 #endif
396 SvNV_set(sv, 0);
397 break;
398 case SVt_PVHV:
399 case SVt_PVAV:
400 case SVt_PVOBJ:
401 assert(type_details->body_size);
402
403 #ifndef PURIFY
404 assert(type_details->arena);
405 assert(type_details->arena_size);
406 /* This points to the start of the allocated area. */
407 new_body = S_new_body(aTHX_ type);
408 /* xpvav and xpvhv have no offset, so no need to adjust new_body */
409 assert(!(type_details->offset));
410 #else
411 /* We always allocated the full length item with PURIFY. To do this
412 we fake things so that arena is false for all 16 types.. */
413 new_body = new_NOARENAZ(type_details);
414 #endif
415 SvANY(sv) = new_body;
416
417 SvSTASH_set(sv, NULL);
418 SvMAGIC_set(sv, NULL);
419
420 switch(type) {
421 case SVt_PVAV:
422 AvFILLp(sv) = -1;
423 AvMAX(sv) = -1;
424 AvALLOC(sv) = NULL;
425
426 AvREAL_only(sv);
427 break;
428 case SVt_PVHV:
429 HvTOTALKEYS(sv) = 0;
430 /* start with PERL_HASH_DEFAULT_HvMAX+1 buckets: */
431 HvMAX(sv) = PERL_HASH_DEFAULT_HvMAX;
432
433 assert(!SvOK(sv));
434 SvOK_off(sv);
435 #ifndef NODEFAULT_SHAREKEYS
436 HvSHAREKEYS_on(sv); /* key-sharing on by default */
437 #endif
438 /* start with PERL_HASH_DEFAULT_HvMAX+1 buckets: */
439 HvMAX(sv) = PERL_HASH_DEFAULT_HvMAX;
440 break;
441 case SVt_PVOBJ:
442 ObjectMAXFIELD(sv) = -1;
443 ObjectFIELDS(sv) = NULL;
444 break;
445 default:
446 NOT_REACHED;
447 }
448
449 sv->sv_u.svu_array = NULL; /* or svu_hash */
450 break;
451
452 case SVt_PVIV:
453 case SVt_PVIO:
454 case SVt_PVGV:
455 case SVt_PVCV:
456 case SVt_PVLV:
457 case SVt_INVLIST:
458 case SVt_REGEXP:
459 case SVt_PVMG:
460 case SVt_PVNV:
461 case SVt_PV:
462 /* For a type known at compile time, it should be possible for the
463 * compiler to deduce the value of (type_details->arena), resolve
464 * that branch below, and inline the relevant values from
465 * bodies_by_type. Except, at least for gcc, it seems not to do that.
466 * We help it out here with two deviations from sv_upgrade:
467 * (1) Minor rearrangement here, so that PVFM - the only type at this
468 * point not to be allocated from an array appears last, not PV.
469 * (2) The ASSUME() statement here for everything that isn't PVFM.
470 * Obviously this all only holds as long as it's a true reflection of
471 * the bodies_by_type lookup table. */
472 #ifndef PURIFY
473 ASSUME(type_details->arena);
474 #endif
475 /* FALLTHROUGH */
476 case SVt_PVFM:
477
478 assert(type_details->body_size);
479 /* We always allocated the full length item with PURIFY. To do this
480 we fake things so that arena is false for all 16 types.. */
481 #ifndef PURIFY
482 if(type_details->arena) {
483 /* This points to the start of the allocated area. */
484 new_body = S_new_body(aTHX_ type);
485 Zero(new_body, type_details->body_size, char);
486 new_body = ((char *)new_body) - type_details->offset;
487 } else
488 #endif
489 {
490 new_body = new_NOARENAZ(type_details);
491 }
492 SvANY(sv) = new_body;
493
494 if (UNLIKELY(type == SVt_PVIO)) {
495 IO * const io = MUTABLE_IO(sv);
496 GV *iogv = gv_fetchpvs("IO::File::", GV_ADD, SVt_PVHV);
497
498 SvOBJECT_on(io);
499 /* Clear the stashcache because a new IO could overrule a package
500 name */
501 DEBUG_o(Perl_deb(aTHX_ "sv_upgrade clearing PL_stashcache\n"));
502 hv_clear(PL_stashcache);
503
504 SvSTASH_set(io, MUTABLE_HV(SvREFCNT_inc(GvHV(iogv))));
505 IoPAGE_LEN(sv) = 60;
506 }
507
508 sv->sv_u.svu_rv = NULL;
509 break;
510 default:
511 Perl_croak(aTHX_ "panic: sv_upgrade to unknown type %lu",
512 (unsigned long)type);
513 }
514
515 return sv;
516 }
517
518 /*
519 =for apidoc newSV_type_mortal
520
521 Creates a new mortal SV, of the type specified. The reference count for the
522 new SV is set to 1.
523
524 This is equivalent to
525 SV* sv = sv_2mortal(newSV_type(<some type>))
526 and
527 SV* sv = sv_newmortal();
528 sv_upgrade(sv, <some_type>)
529 but should be more efficient than both of them. (Unless sv_2mortal is inlined
530 at some point in the future.)
531
532 =cut
533 */
534
535 PERL_STATIC_INLINE SV *
Perl_newSV_type_mortal(pTHX_ const svtype type)536 Perl_newSV_type_mortal(pTHX_ const svtype type)
537 {
538 SV *sv = newSV_type(type);
539 SSize_t ix = ++PL_tmps_ix;
540 if (UNLIKELY(ix >= PL_tmps_max))
541 ix = Perl_tmps_grow_p(aTHX_ ix);
542 PL_tmps_stack[ix] = (sv);
543 SvTEMP_on(sv);
544 return sv;
545 }
546
547 /* The following functions started out in sv.h and then moved to inline.h. They
548 * moved again into this file during the 5.37.x development cycle. */
549
550 /*
551 =for apidoc_section $SV
552 =for apidoc SvPVXtrue
553
554 Returns a boolean as to whether or not C<sv> contains a PV that is considered
555 TRUE. FALSE is returned if C<sv> doesn't contain a PV, or if the PV it does
556 contain is zero length, or consists of just the single character '0'. Every
557 other PV value is considered TRUE.
558
559 As of Perl v5.37.1, C<sv> is evaluated exactly once; in earlier releases, it
560 could be evaluated more than once.
561
562 =cut
563 */
564
565 PERL_STATIC_INLINE bool
Perl_SvPVXtrue(pTHX_ SV * sv)566 Perl_SvPVXtrue(pTHX_ SV *sv)
567 {
568 PERL_ARGS_ASSERT_SVPVXTRUE;
569
570 if (! (XPV *) SvANY(sv)) {
571 return false;
572 }
573
574 if ( ((XPV *) SvANY(sv))->xpv_cur > 1) { /* length > 1 */
575 return true;
576 }
577
578 if (( (XPV *) SvANY(sv))->xpv_cur == 0) {
579 return false;
580 }
581
582 return *sv->sv_u.svu_pv != '0';
583 }
584
585 /*
586 =for apidoc SvGETMAGIC
587 Invokes C<L</mg_get>> on an SV if it has 'get' magic. For example, this
588 will call C<FETCH> on a tied variable. As of 5.37.1, this function is
589 guaranteed to evaluate its argument exactly once.
590
591 =cut
592 */
593
594 PERL_STATIC_INLINE void
Perl_SvGETMAGIC(pTHX_ SV * sv)595 Perl_SvGETMAGIC(pTHX_ SV *sv)
596 {
597 PERL_ARGS_ASSERT_SVGETMAGIC;
598
599 if (UNLIKELY(SvGMAGICAL(sv))) {
600 mg_get(sv);
601 }
602 }
603
604 PERL_STATIC_INLINE bool
Perl_SvTRUE(pTHX_ SV * sv)605 Perl_SvTRUE(pTHX_ SV *sv)
606 {
607 PERL_ARGS_ASSERT_SVTRUE;
608
609 if (UNLIKELY(sv == NULL))
610 return FALSE;
611 SvGETMAGIC(sv);
612 return SvTRUE_nomg_NN(sv);
613 }
614
615 PERL_STATIC_INLINE bool
Perl_SvTRUE_nomg(pTHX_ SV * sv)616 Perl_SvTRUE_nomg(pTHX_ SV *sv)
617 {
618 PERL_ARGS_ASSERT_SVTRUE_NOMG;
619
620 if (UNLIKELY(sv == NULL))
621 return FALSE;
622 return SvTRUE_nomg_NN(sv);
623 }
624
625 PERL_STATIC_INLINE bool
Perl_SvTRUE_NN(pTHX_ SV * sv)626 Perl_SvTRUE_NN(pTHX_ SV *sv)
627 {
628 PERL_ARGS_ASSERT_SVTRUE_NN;
629
630 SvGETMAGIC(sv);
631 return SvTRUE_nomg_NN(sv);
632 }
633
634 PERL_STATIC_INLINE bool
Perl_SvTRUE_common(pTHX_ SV * sv,const bool sv_2bool_is_fallback)635 Perl_SvTRUE_common(pTHX_ SV * sv, const bool sv_2bool_is_fallback)
636 {
637 PERL_ARGS_ASSERT_SVTRUE_COMMON;
638
639 if (UNLIKELY(SvIMMORTAL_INTERP(sv)))
640 return SvIMMORTAL_TRUE(sv);
641
642 if (! SvOK(sv))
643 return FALSE;
644
645 if (SvPOK(sv))
646 return SvPVXtrue(sv);
647
648 if (SvIOK(sv))
649 return SvIVX(sv) != 0; /* casts to bool */
650
651 if (SvROK(sv) && !(SvOBJECT(SvRV(sv)) && HvAMAGIC(SvSTASH(SvRV(sv)))))
652 return TRUE;
653
654 if (sv_2bool_is_fallback)
655 return sv_2bool_nomg(sv);
656
657 return isGV_with_GP(sv);
658 }
659
660 PERL_STATIC_INLINE SV *
Perl_SvREFCNT_inc(SV * sv)661 Perl_SvREFCNT_inc(SV *sv)
662 {
663 if (LIKELY(sv != NULL))
664 SvREFCNT(sv)++;
665 return sv;
666 }
667
668 PERL_STATIC_INLINE SV *
Perl_SvREFCNT_inc_NN(SV * sv)669 Perl_SvREFCNT_inc_NN(SV *sv)
670 {
671 PERL_ARGS_ASSERT_SVREFCNT_INC_NN;
672
673 SvREFCNT(sv)++;
674 return sv;
675 }
676
677 PERL_STATIC_INLINE void
Perl_SvREFCNT_inc_void(SV * sv)678 Perl_SvREFCNT_inc_void(SV *sv)
679 {
680 if (LIKELY(sv != NULL))
681 SvREFCNT(sv)++;
682 }
683
684 PERL_STATIC_INLINE void
Perl_SvREFCNT_dec(pTHX_ SV * sv)685 Perl_SvREFCNT_dec(pTHX_ SV *sv)
686 {
687 if (LIKELY(sv != NULL)) {
688 U32 rc = SvREFCNT(sv);
689 if (LIKELY(rc > 1))
690 SvREFCNT(sv) = rc - 1;
691 else
692 Perl_sv_free2(aTHX_ sv, rc);
693 }
694 }
695
696 PERL_STATIC_INLINE SV *
Perl_SvREFCNT_dec_ret_NULL(pTHX_ SV * sv)697 Perl_SvREFCNT_dec_ret_NULL(pTHX_ SV *sv)
698 {
699 PERL_ARGS_ASSERT_SVREFCNT_DEC_RET_NULL;
700 Perl_SvREFCNT_dec(aTHX_ sv);
701 return NULL;
702 }
703
704
705 PERL_STATIC_INLINE void
Perl_SvREFCNT_dec_NN(pTHX_ SV * sv)706 Perl_SvREFCNT_dec_NN(pTHX_ SV *sv)
707 {
708 U32 rc = SvREFCNT(sv);
709
710 PERL_ARGS_ASSERT_SVREFCNT_DEC_NN;
711
712 if (LIKELY(rc > 1))
713 SvREFCNT(sv) = rc - 1;
714 else
715 Perl_sv_free2(aTHX_ sv, rc);
716 }
717
718 /*
719 =for apidoc SvAMAGIC_on
720
721 Indicate that C<sv> has overloading (active magic) enabled.
722
723 =cut
724 */
725
726 PERL_STATIC_INLINE void
Perl_SvAMAGIC_on(SV * sv)727 Perl_SvAMAGIC_on(SV *sv)
728 {
729 PERL_ARGS_ASSERT_SVAMAGIC_ON;
730 assert(SvROK(sv));
731
732 if (SvOBJECT(SvRV(sv))) HvAMAGIC_on(SvSTASH(SvRV(sv)));
733 }
734
735 /*
736 =for apidoc SvAMAGIC_off
737
738 Indicate that C<sv> has overloading (active magic) disabled.
739
740 =cut
741 */
742
743 PERL_STATIC_INLINE void
Perl_SvAMAGIC_off(SV * sv)744 Perl_SvAMAGIC_off(SV *sv)
745 {
746 PERL_ARGS_ASSERT_SVAMAGIC_OFF;
747
748 if (SvROK(sv) && SvOBJECT(SvRV(sv)))
749 HvAMAGIC_off(SvSTASH(SvRV(sv)));
750 }
751
752 PERL_STATIC_INLINE U32
Perl_SvPADSTALE_on(SV * sv)753 Perl_SvPADSTALE_on(SV *sv)
754 {
755 assert(!(SvFLAGS(sv) & SVs_PADTMP));
756 return SvFLAGS(sv) |= SVs_PADSTALE;
757 }
758 PERL_STATIC_INLINE U32
Perl_SvPADSTALE_off(SV * sv)759 Perl_SvPADSTALE_off(SV *sv)
760 {
761 assert(!(SvFLAGS(sv) & SVs_PADTMP));
762 return SvFLAGS(sv) &= ~SVs_PADSTALE;
763 }
764
765 /*
766 =for apidoc_section $SV
767 =for apidoc SvIV
768 =for apidoc_item SvIV_nomg
769 =for apidoc_item SvIVx
770
771 These each coerce the given SV to IV and return it. The returned value in many
772 circumstances will get stored in C<sv>'s IV slot, but not in all cases. (Use
773 C<L</sv_setiv>> to make sure it does).
774
775 As of 5.37.1, all are guaranteed to evaluate C<sv> only once.
776
777 C<SvIVx> is now identical to C<SvIV>, but prior to 5.37.1, it was the only form
778 guaranteed to evaluate C<sv> only once.
779
780 C<SvIV_nomg> is the same as C<SvIV>, but does not perform 'get' magic.
781
782 =for apidoc SvNV
783 =for apidoc_item SvNV_nomg
784 =for apidoc_item SvNVx
785
786 These each coerce the given SV to NV and return it. The returned value in many
787 circumstances will get stored in C<sv>'s NV slot, but not in all cases. (Use
788 C<L</sv_setnv>> to make sure it does).
789
790 As of 5.37.1, all are guaranteed to evaluate C<sv> only once.
791
792 C<SvNVx> is now identical to C<SvNV>, but prior to 5.37.1, it was the only form
793 guaranteed to evaluate C<sv> only once.
794
795 C<SvNV_nomg> is the same as C<SvNV>, but does not perform 'get' magic.
796
797 =for apidoc SvUV
798 =for apidoc_item SvUV_nomg
799 =for apidoc_item SvUVx
800
801 These each coerce the given SV to UV and return it. The returned value in many
802 circumstances will get stored in C<sv>'s UV slot, but not in all cases. (Use
803 C<L</sv_setuv>> to make sure it does).
804
805 As of 5.37.1, all are guaranteed to evaluate C<sv> only once.
806
807 C<SvUVx> is now identical to C<SvUV>, but prior to 5.37.1, it was the only form
808 guaranteed to evaluate C<sv> only once.
809
810 =cut
811 */
812
813 PERL_STATIC_INLINE IV
Perl_SvIV(pTHX_ SV * sv)814 Perl_SvIV(pTHX_ SV *sv) {
815 PERL_ARGS_ASSERT_SVIV;
816
817 if (SvIOK_nog(sv))
818 return SvIVX(sv);
819 return sv_2iv(sv);
820 }
821
822 PERL_STATIC_INLINE UV
Perl_SvUV(pTHX_ SV * sv)823 Perl_SvUV(pTHX_ SV *sv) {
824 PERL_ARGS_ASSERT_SVUV;
825
826 if (SvUOK_nog(sv))
827 return SvUVX(sv);
828 return sv_2uv(sv);
829 }
830
831 PERL_STATIC_INLINE NV
Perl_SvNV(pTHX_ SV * sv)832 Perl_SvNV(pTHX_ SV *sv) {
833 PERL_ARGS_ASSERT_SVNV;
834
835 if (SvNOK_nog(sv))
836 return SvNVX(sv);
837 return sv_2nv(sv);
838 }
839
840 PERL_STATIC_INLINE IV
Perl_SvIV_nomg(pTHX_ SV * sv)841 Perl_SvIV_nomg(pTHX_ SV *sv) {
842 PERL_ARGS_ASSERT_SVIV_NOMG;
843
844 if (SvIOK(sv))
845 return SvIVX(sv);
846 return sv_2iv_flags(sv, 0);
847 }
848
849 PERL_STATIC_INLINE UV
Perl_SvUV_nomg(pTHX_ SV * sv)850 Perl_SvUV_nomg(pTHX_ SV *sv) {
851 PERL_ARGS_ASSERT_SVUV_NOMG;
852
853 if (SvIOK_nog(sv))
854 return SvUVX(sv);
855 return sv_2uv_flags(sv, 0);
856 }
857
858 PERL_STATIC_INLINE NV
Perl_SvNV_nomg(pTHX_ SV * sv)859 Perl_SvNV_nomg(pTHX_ SV *sv) {
860 PERL_ARGS_ASSERT_SVNV_NOMG;
861
862 if (SvNOK_nog(sv))
863 return SvNVX(sv);
864 return sv_2nv_flags(sv, 0);
865 }
866
867 #if defined(PERL_CORE) || defined (PERL_EXT)
868 PERL_STATIC_INLINE STRLEN
S_sv_or_pv_pos_u2b(pTHX_ SV * sv,const char * pv,STRLEN pos,STRLEN * lenp)869 S_sv_or_pv_pos_u2b(pTHX_ SV *sv, const char *pv, STRLEN pos, STRLEN *lenp)
870 {
871 PERL_ARGS_ASSERT_SV_OR_PV_POS_U2B;
872 if (SvGAMAGIC(sv)) {
873 U8 *hopped = utf8_hop((U8 *)pv, pos);
874 if (lenp) *lenp = (STRLEN)(utf8_hop(hopped, *lenp) - hopped);
875 return (STRLEN)(hopped - (U8 *)pv);
876 }
877 return sv_pos_u2b_flags(sv,pos,lenp,SV_CONST_RETURN);
878 }
879 #endif
880
881 PERL_STATIC_INLINE char *
Perl_sv_pvutf8n_force_wrapper(pTHX_ SV * const sv,STRLEN * const lp,const U32 dummy)882 Perl_sv_pvutf8n_force_wrapper(pTHX_ SV * const sv, STRLEN * const lp, const U32 dummy)
883 {
884 /* This is just so can be passed to Perl_SvPV_helper() as a function
885 * pointer with the same signature as all the other such pointers, and
886 * having hence an unused parameter */
887 PERL_ARGS_ASSERT_SV_PVUTF8N_FORCE_WRAPPER;
888 PERL_UNUSED_ARG(dummy);
889
890 return sv_pvutf8n_force(sv, lp);
891 }
892
893 PERL_STATIC_INLINE char *
Perl_sv_pvbyten_force_wrapper(pTHX_ SV * const sv,STRLEN * const lp,const U32 dummy)894 Perl_sv_pvbyten_force_wrapper(pTHX_ SV * const sv, STRLEN * const lp, const U32 dummy)
895 {
896 /* This is just so can be passed to Perl_SvPV_helper() as a function
897 * pointer with the same signature as all the other such pointers, and
898 * having hence an unused parameter */
899 PERL_ARGS_ASSERT_SV_PVBYTEN_FORCE_WRAPPER;
900 PERL_UNUSED_ARG(dummy);
901
902 return sv_pvbyten_force(sv, lp);
903 }
904
905 PERL_STATIC_INLINE char *
Perl_SvPV_helper(pTHX_ SV * const sv,STRLEN * const lp,const U32 flags,const PL_SvPVtype type,char * (* non_trivial)(pTHX_ SV *,STRLEN * const,const U32),const bool or_null,const U32 return_flags)906 Perl_SvPV_helper(pTHX_
907 SV * const sv,
908 STRLEN * const lp,
909 const U32 flags,
910 const PL_SvPVtype type,
911 char * (*non_trivial)(pTHX_ SV *, STRLEN * const, const U32),
912 const bool or_null,
913 const U32 return_flags
914 )
915 {
916 /* 'type' should be known at compile time, so this is reduced to a single
917 * conditional at runtime */
918 if ( (type == SvPVbyte_type_ && SvPOK_byte_nog(sv))
919 || (type == SvPVforce_type_ && SvPOK_pure_nogthink(sv))
920 || (type == SvPVutf8_type_ && SvPOK_utf8_nog(sv))
921 || (type == SvPVnormal_type_ && SvPOK_nog(sv))
922 || (type == SvPVutf8_pure_type_ && SvPOK_utf8_pure_nogthink(sv))
923 || (type == SvPVbyte_pure_type_ && SvPOK_byte_pure_nogthink(sv))
924 ) {
925 if (lp) {
926 *lp = SvCUR(sv);
927 }
928
929 /* Similarly 'return_flags is known at compile time, so this becomes
930 * branchless */
931 if (return_flags & SV_MUTABLE_RETURN) {
932 return SvPVX_mutable(sv);
933 }
934 else if(return_flags & SV_CONST_RETURN) {
935 return (char *) SvPVX_const(sv);
936 }
937 else {
938 return SvPVX(sv);
939 }
940 }
941
942 if (or_null) { /* This is also known at compile time */
943 if (flags & SV_GMAGIC) { /* As is this */
944 SvGETMAGIC(sv);
945 }
946
947 if (! SvOK(sv)) {
948 if (lp) { /* As is this */
949 *lp = 0;
950 }
951
952 return NULL;
953 }
954 }
955
956 /* Can't trivially handle this, call the function */
957 return non_trivial(aTHX_ sv, lp, (flags|return_flags));
958 }
959
960 /*
961 =for apidoc newRV_noinc
962
963 Creates an RV wrapper for an SV. The reference count for the original
964 SV is B<not> incremented.
965
966 =cut
967 */
968
969 PERL_STATIC_INLINE SV *
Perl_newRV_noinc(pTHX_ SV * const tmpRef)970 Perl_newRV_noinc(pTHX_ SV *const tmpRef)
971 {
972 SV *sv = newSV_type(SVt_IV);
973
974 PERL_ARGS_ASSERT_NEWRV_NOINC;
975
976 SvTEMP_off(tmpRef);
977
978 /* inlined, simplified sv_setrv_noinc(sv, tmpRef); */
979 SvRV_set(sv, tmpRef);
980 SvROK_on(sv);
981
982 return sv;
983 }
984
985 PERL_STATIC_INLINE char *
Perl_sv_setpv_freshbuf(pTHX_ SV * const sv)986 Perl_sv_setpv_freshbuf(pTHX_ SV *const sv)
987 {
988 PERL_ARGS_ASSERT_SV_SETPV_FRESHBUF;
989 assert(SvTYPE(sv) >= SVt_PV);
990 assert(SvTYPE(sv) <= SVt_PVMG);
991 assert(!SvTHINKFIRST(sv));
992 assert(SvPVX(sv));
993 SvCUR_set(sv, 0);
994 *(SvEND(sv))= '\0';
995 (void)SvPOK_only_UTF8(sv);
996 SvTAINT(sv);
997 return SvPVX(sv);
998 }
999
1000 /*
1001 * ex: set ts=8 sts=4 sw=4 et:
1002 */
1003