File Coverage: /home/con/perl5/perlbrew/perls/perl-5.42.2/lib/5.42.2/x86_64-linux/CORE/sv_inline.h

# File Coverage

File: | /home/con/perl5/perlbrew/perls/perl-5.42.2/lib/5.42.2/x86_64-linux/CORE/sv_inline.h
Coverage: | 66.5%

line | stmt | code
--- | --- | ---
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 |  | PERL_STATIC_INLINE SV*
72 | 19629 | Perl_new_sv(pTHX_ const char *file, int line, const char *func)
73 |  | {
74 |  | SV* sv;
75 |  | #if !defined(DEBUG_LEAKING_SCALARS) || \
76 |  | (!defined(DEBUGGING) && !defined(PERL_MEM_LOG))
77 |  | PERL_UNUSED_ARG(file);
78 |  | PERL_UNUSED_ARG(line);
79 |  | PERL_UNUSED_ARG(func);
80 |  | #endif
81 |
82 | 19629 | if (PL_sv_root)
83 | 19628 | uproot_SV(sv);
84 |  | else
85 | 1 | sv = Perl_more_sv(aTHX);
86 | 19629 | SvANY(sv) = 0;
87 | 19629 | SvREFCNT(sv) = 1;
88 | 19629 | SvFLAGS(sv) = 0;
89 |  | #ifdef DEBUG_LEAKING_SCALARS
90 |  | sv->sv_debug_optype = PL_op ? PL_op->op_type : 0;
91 |  | sv->sv_debug_line = (U16) (PL_parser && PL_parser->copline != NOLINE
92 |  | ? PL_parser->copline
93 |  | : PL_curcop
94 |  | ? CopLINE(PL_curcop)
95 |  | : 0
96 |  | );
97 |  | sv->sv_debug_inpad = 0;
98 |  | sv->sv_debug_parent = NULL;
99 |  | sv->sv_debug_file = PL_curcop ? savesharedpv(CopFILE(PL_curcop)): NULL;
100 |
101 |  | sv->sv_debug_serial = PL_sv_serial++;
102 |
103 |  | MEM_LOG_NEW_SV(sv, file, line, func);
104 |  | DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%" UVxf ": (%05ld) new_SV (from %s:%d [%s])\n",
105 |  | PTR2UV(sv), (long)sv->sv_debug_serial, file, line, func));
106 |  | #endif
107 | 19629 | return sv;
108 |  | }
109 |  | # define new_SV(p) (p)=Perl_new_sv(aTHX_ __FILE__, __LINE__, FUNCTION__)
110 |
111 |  | typedef struct xpvhv_with_aux XPVHV_WITH_AUX;
112 |
113 |  | struct body_details {
114 |  | U8 body_size; /* Size to allocate */
115 |  | U8 copy; /* Size of structure to copy (may be shorter) */
116 |  | U8 offset; /* Size of unalloced ghost fields to first alloced field*/
117 |  | PERL_BITFIELD8 type : 5; /* We have space for a sanity check. */
118 |  | PERL_BITFIELD8 cant_upgrade : 1;/* Cannot upgrade this type */
119 |  | PERL_BITFIELD8 zero_nv : 1; /* zero the NV when upgrading from this */
120 |  | PERL_BITFIELD8 arena : 1; /* Allocated from an arena */
121 |  | U32 arena_size; /* Size of arena to allocate */
122 |  | };
123 |
124 |  | #define ALIGNED_TYPE_NAME(name) name##_aligned
125 |  | #define ALIGNED_TYPE(name) \
126 |  | typedef union { \
127 |  | name align_me; \
128 |  | NV nv; \
129 |  | IV iv; \
130 |  | } ALIGNED_TYPE_NAME(name)
131 |
132 |  | ALIGNED_TYPE(regexp);
133 |  | ALIGNED_TYPE(XPVGV);
134 |  | ALIGNED_TYPE(XPVLV);
135 |  | ALIGNED_TYPE(XPVAV);
136 |  | ALIGNED_TYPE(XPVHV);
137 |  | ALIGNED_TYPE(XPVHV_WITH_AUX);
138 |  | ALIGNED_TYPE(XPVCV);
139 |  | ALIGNED_TYPE(XPVFM);
140 |  | ALIGNED_TYPE(XPVIO);
141 |  | ALIGNED_TYPE(XPVOBJ);
142 |
143 |  | #define HADNV FALSE
144 |  | #define NONV TRUE
145 |
146 |
147 |  | #ifdef PURIFY
148 |  | /* With -DPURFIY we allocate everything directly, and don't use arenas.
149 |  | This seems a rather elegant way to simplify some of the code below. */
150 |  | #define HASARENA FALSE
151 |  | #else
152 |  | #define HASARENA TRUE
153 |  | #endif
154 |  | #define NOARENA FALSE
155 |
156 |  | /* Size the arenas to exactly fit a given number of bodies. A count
157 |  | of 0 fits the max number bodies into a PERL_ARENA_SIZE.block,
158 |  | simplifying the default. If count > 0, the arena is sized to fit
159 |  | only that many bodies, allowing arenas to be used for large, rare
160 |  | bodies (XPVFM, XPVIO) without undue waste. The arena size is
161 |  | limited by PERL_ARENA_SIZE, so we can safely oversize the
162 |  | declarations.
163 |  | */
164 |  | #define FIT_ARENA0(body_size) \
165 |  | ((size_t)(PERL_ARENA_SIZE / body_size) * body_size)
166 |  | #define FIT_ARENAn(count,body_size) \
167 |  | ( count * body_size <= PERL_ARENA_SIZE) \
168 |  | ? count * body_size \
169 |  | : FIT_ARENA0 (body_size)
170 |  | #define FIT_ARENA(count,body_size) \
171 |  | (U32)(count \
172 |  | ? FIT_ARENAn (count, body_size) \
173 |  | : FIT_ARENA0 (body_size))
174 |
175 |  | /* Calculate the length to copy. Specifically work out the length less any
176 |  | final padding the compiler needed to add. See the comment in sv_upgrade
177 |  | for why copying the padding proved to be a bug. */
178 |
179 |  | #define copy_length(type, last_member) \
180 |  | STRUCT_OFFSET(type, last_member) \
181 |  | + sizeof (((type*)SvANY((const SV *)0))->last_member)
182 |
183 |  | static const struct body_details bodies_by_type[] = {
184 |  | /* HEs use this offset for their arena. */
185 |  | { 0, 0, 0, SVt_NULL, FALSE, NONV, NOARENA, 0 },
186 |
187 |  | /* IVs are in the head, so the allocation size is 0. */
188 |  | { 0,
189 |  | sizeof(IV), /* This is used to copy out the IV body. */
190 |  | STRUCT_OFFSET(XPVIV, xiv_iv), SVt_IV, FALSE, NONV,
191 |  | NOARENA /* IVS don't need an arena */, 0
192 |  | },
193 |
194 |  | #if NVSIZE <= IVSIZE
195 |  | { 0, sizeof(NV),
196 |  | STRUCT_OFFSET(XPVNV, xnv_u),
197 |  | SVt_NV, FALSE, HADNV, NOARENA, 0 },
198 |  | #else
199 |  | { sizeof(NV), sizeof(NV),
200 |  | STRUCT_OFFSET(XPVNV, xnv_u),
201 |  | SVt_NV, FALSE, HADNV, HASARENA, FIT_ARENA(0, sizeof(NV)) },
202 |  | #endif
203 |
204 |  | { sizeof(XPV) - STRUCT_OFFSET(XPV, xpv_cur),
205 |  | copy_length(XPV, xpv_len) - STRUCT_OFFSET(XPV, xpv_cur),
206 |  | + STRUCT_OFFSET(XPV, xpv_cur),
207 |  | SVt_PV, FALSE, NONV, HASARENA,
208 |  | FIT_ARENA(0, sizeof(XPV) - STRUCT_OFFSET(XPV, xpv_cur)) },
209 |
210 |  | { sizeof(XINVLIST) - STRUCT_OFFSET(XPV, xpv_cur),
211 |  | copy_length(XINVLIST, is_offset) - STRUCT_OFFSET(XPV, xpv_cur),
212 |  | + STRUCT_OFFSET(XPV, xpv_cur),
213 |  | SVt_INVLIST, TRUE, NONV, HASARENA,
214 |  | FIT_ARENA(0, sizeof(XINVLIST) - STRUCT_OFFSET(XPV, xpv_cur)) },
215 |
216 |  | { sizeof(XPVIV) - STRUCT_OFFSET(XPV, xpv_cur),
217 |  | copy_length(XPVIV, xiv_u) - STRUCT_OFFSET(XPV, xpv_cur),
218 |  | + STRUCT_OFFSET(XPV, xpv_cur),
219 |  | SVt_PVIV, FALSE, NONV, HASARENA,
220 |  | FIT_ARENA(0, sizeof(XPVIV) - STRUCT_OFFSET(XPV, xpv_cur)) },
221 |
222 |  | #if NVSIZE > 8 && PTRSIZE < 8 && MEM_ALIGNBYTES > 8
223 |  | /* NV may need strict 16 byte alignment.
224 |
225 |  | On 64-bit systems the NV ends up aligned despite the hack
226 |  | avoiding allocation of xmg_stash and xmg_u, so only do this
227 |  | for 32-bit systems.
228 |  | */
229 |  | { sizeof(XPVNV),
230 |  | sizeof(XPVNV),
231 |  | 0,
232 |  | SVt_PVNV, FALSE, HADNV, HASARENA,
233 |  | FIT_ARENA(0, sizeof(XPVNV)) },
234 |  | #else
235 |  | { sizeof(XPVNV) - STRUCT_OFFSET(XPV, xpv_cur),
236 |  | copy_length(XPVNV, xnv_u) - STRUCT_OFFSET(XPV, xpv_cur),
237 |  | + STRUCT_OFFSET(XPV, xpv_cur),
238 |  | SVt_PVNV, FALSE, HADNV, HASARENA,
239 |  | FIT_ARENA(0, sizeof(XPVNV) - STRUCT_OFFSET(XPV, xpv_cur)) },
240 |  | #endif
241 |  | { sizeof(XPVMG), copy_length(XPVMG, xnv_u), 0, SVt_PVMG, FALSE, HADNV,
242 |  | HASARENA, FIT_ARENA(0, sizeof(XPVMG)) },
243 |
244 |  | { sizeof(ALIGNED_TYPE_NAME(regexp)),
245 |  | sizeof(regexp),
246 |  | 0,
247 |  | SVt_REGEXP, TRUE, NONV, HASARENA,
248 |  | FIT_ARENA(0, sizeof(ALIGNED_TYPE_NAME(regexp)))
249 |  | },
250 |
251 |  | { sizeof(ALIGNED_TYPE_NAME(XPVGV)), sizeof(XPVGV), 0, SVt_PVGV, TRUE, HADNV,
252 |  | HASARENA, FIT_ARENA(0, sizeof(ALIGNED_TYPE_NAME(XPVGV))) },
253 |
254 |  | { sizeof(ALIGNED_TYPE_NAME(XPVLV)), sizeof(XPVLV), 0, SVt_PVLV, TRUE, HADNV,
255 |  | HASARENA, FIT_ARENA(0, sizeof(ALIGNED_TYPE_NAME(XPVLV))) },
256 |
257 |  | { sizeof(ALIGNED_TYPE_NAME(XPVAV)),
258 |  | copy_length(XPVAV, xav_alloc),
259 |  | 0,
260 |  | SVt_PVAV, TRUE, NONV, HASARENA,
261 |  | FIT_ARENA(0, sizeof(ALIGNED_TYPE_NAME(XPVAV))) },
262 |
263 |  | { sizeof(ALIGNED_TYPE_NAME(XPVHV)),
264 |  | copy_length(XPVHV, xhv_max),
265 |  | 0,
266 |  | SVt_PVHV, TRUE, NONV, HASARENA,
267 |  | FIT_ARENA(0, sizeof(ALIGNED_TYPE_NAME(XPVHV))) },
268 |
269 |  | { sizeof(ALIGNED_TYPE_NAME(XPVCV)),
270 |  | sizeof(XPVCV),
271 |  | 0,
272 |  | SVt_PVCV, TRUE, NONV, HASARENA,
273 |  | FIT_ARENA(0, sizeof(ALIGNED_TYPE_NAME(XPVCV))) },
274 |
275 |  | { sizeof(ALIGNED_TYPE_NAME(XPVFM)),
276 |  | sizeof(XPVFM),
277 |  | 0,
278 |  | SVt_PVFM, TRUE, NONV, NOARENA,
279 |  | FIT_ARENA(20, sizeof(ALIGNED_TYPE_NAME(XPVFM))) },
280 |
281 |  | { sizeof(ALIGNED_TYPE_NAME(XPVIO)),
282 |  | sizeof(XPVIO),
283 |  | 0,
284 |  | SVt_PVIO, TRUE, NONV, HASARENA,
285 |  | FIT_ARENA(24, sizeof(ALIGNED_TYPE_NAME(XPVIO))) },
286 |
287 |  | { sizeof(ALIGNED_TYPE_NAME(XPVOBJ)),
288 |  | copy_length(XPVOBJ, xobject_fields),
289 |  | 0,
290 |  | SVt_PVOBJ, TRUE, NONV, HASARENA,
291 |  | FIT_ARENA(0, sizeof(ALIGNED_TYPE_NAME(XPVOBJ))) },
292 |  | };
293 |
294 |  | #define new_body_allocated(sv_type) \
295 |  | (void *)((char *)S_new_body(aTHX_ sv_type) \
296 |  | - bodies_by_type[sv_type].offset)
297 |
298 |  | #ifdef PURIFY
299 |  | #if !(NVSIZE <= IVSIZE)
300 |  | # define new_XNV() safemalloc(sizeof(XPVNV))
301 |  | #endif
302 |  | #define new_XPVNV() safemalloc(sizeof(XPVNV))
303 |  | #define new_XPVMG() safemalloc(sizeof(XPVMG))
304 |
305 |  | #define del_body_by_type(p, type) safefree(p)
306 |
307 |  | #else /* !PURIFY */
308 |
309 |  | #if !(NVSIZE <= IVSIZE)
310 |  | # define new_XNV() new_body_allocated(SVt_NV)
311 |  | #endif
312 |  | #define new_XPVNV() new_body_allocated(SVt_PVNV)
313 |  | #define new_XPVMG() new_body_allocated(SVt_PVMG)
314 |
315 |  | #define del_body_by_type(p, type) \
316 |  | del_body(p + bodies_by_type[(type)].offset, \
317 |  | &PL_body_roots[(type)])
318 |
319 |  | #endif /* PURIFY */
320 |
321 |  | /* no arena for you! */
322 |
323 |  | #define new_NOARENA(details) \
324 |  | safemalloc((details)->body_size + (details)->offset)
325 |  | #define new_NOARENAZ(details) \
326 |  | safecalloc((details)->body_size + (details)->offset, 1)
327 |
328 |  | #ifndef PURIFY
329 |
330 |  | /* grab a new thing from the arena's free list, allocating more if necessary. */
331 |  | #define new_body_from_arena(xpv, root_index, type_meta) \
332 |  | STMT_START { \
333 |  | void ** const r3wt = &PL_body_roots[root_index]; \
334 |  | xpv = (PTR_TBL_ENT_t*) (*((void **)(r3wt)) \
335 |  | ? *((void **)(r3wt)) : Perl_more_bodies(aTHX_ root_index, \
336 |  | type_meta.body_size,\
337 |  | type_meta.arena_size)); \
338 |  | *(r3wt) = *(void**)(xpv); \
339 |  | } STMT_END
340 |
341 |  | PERL_STATIC_INLINE void *
342 | 17846 | S_new_body(pTHX_ const svtype sv_type)
343 |  | {
344 |  | void *xpv;
345 | 17846 | new_body_from_arena(xpv, sv_type, bodies_by_type[sv_type]);
346 | 17846 | return xpv;
347 |  | }
348 |
349 |  | #endif
350 |
351 |  | static const struct body_details fake_rv =
352 |  | { 0, 0, 0, SVt_IV, FALSE, NONV, NOARENA, 0 };
353 |
354 |  | static const struct body_details fake_hv_with_aux =
355 |  | /* The SVt_IV arena is used for (larger) PVHV bodies. */
356 |  | { sizeof(ALIGNED_TYPE_NAME(XPVHV_WITH_AUX)),
357 |  | copy_length(XPVHV, xhv_max),
358 |  | 0,
359 |  | SVt_PVHV, TRUE, NONV, HASARENA,
360 |  | FIT_ARENA(0, sizeof(ALIGNED_TYPE_NAME(XPVHV_WITH_AUX))) };
361 |
362 |  | /*
363 - 368 |  |
    =for apidoc newSV_type

    Creates a new SV, of the type specified.  The reference count for the new SV
    is set to 1.

    =cut
369 |  | */
370 |
371 |  | PERL_STATIC_INLINE SV *
372 | 19629 | Perl_newSV_type(pTHX_ const svtype type)
373 |  | {
374 |  | SV *sv;
375 |  | void* new_body;
376 |  | const struct body_details *type_details;
377 |
378 | 19629 | new_SV(sv);
379 |
380 | 19629 | type_details = bodies_by_type + type;
381 |
382 | 19629 | SvFLAGS(sv) &= ~SVTYPEMASK;
383 | 19629 | SvFLAGS(sv) |= type;
384 |
385 | 19629 | switch (type) {
386 | 0 | case SVt_NULL:
387 | 0 | break;
388 | 1783 | case SVt_IV:
389 | 1783 | SET_SVANY_FOR_BODYLESS_IV(sv);
390 | 1783 | SvIV_set(sv, 0);
391 | 1783 | break;
392 | 0 | case SVt_NV:
393 |  | #if NVSIZE <= IVSIZE
394 | 0 | SET_SVANY_FOR_BODYLESS_NV(sv);
395 |  | #else
396 |  | SvANY(sv) = new_XNV();
397 |  | #endif
398 | 0 | SvNV_set(sv, 0);
399 | 0 | break;
400 | 17794 | case SVt_PVHV:
401 |  | case SVt_PVAV:
402 |  | case SVt_PVOBJ:
403 |  | assert(type_details->body_size);
404 |
405 |  | #ifndef PURIFY
406 |  | assert(type_details->arena);
407 |  | assert(type_details->arena_size);
408 |  | /* This points to the start of the allocated area. */
409 | 17794 | new_body = S_new_body(aTHX_ type);
410 |  | /* xpvav and xpvhv have no offset, so no need to adjust new_body */
411 |  | assert(!(type_details->offset));
412 |  | #else
413 |  | /* We always allocated the full length item with PURIFY. To do this
414 |  | we fake things so that arena is false for all 16 types.. */
415 |  | new_body = new_NOARENAZ(type_details);
416 |  | #endif
417 | 17794 | SvANY(sv) = new_body;
418 |
419 | 17794 | SvSTASH_set(sv, NULL);
420 | 17794 | SvMAGIC_set(sv, NULL);
421 |
422 | 17794 | switch(type) {
423 | 16534 | case SVt_PVAV:
424 | 16534 | AvFILLp(sv) = -1;
425 | 16534 | AvMAX(sv) = -1;
426 | 16534 | AvALLOC(sv) = NULL;
427 |
428 | 16534 | AvREAL_only(sv);
429 | 16534 | break;
430 | 1260 | case SVt_PVHV:
431 | 1260 | HvTOTALKEYS(sv) = 0;
432 |  | /* start with PERL_HASH_DEFAULT_HvMAX+1 buckets: */
433 | 1260 | HvMAX(sv) = PERL_HASH_DEFAULT_HvMAX;
434 |
435 |  | assert(!SvOK(sv));
436 | 1260 | SvOK_off(sv);
437 |  | #ifndef NODEFAULT_SHAREKEYS
438 | 1260 | HvSHAREKEYS_on(sv); /* key-sharing on by default */
439 |  | #endif
440 |  | /* start with PERL_HASH_DEFAULT_HvMAX+1 buckets: */
441 | 1260 | HvMAX(sv) = PERL_HASH_DEFAULT_HvMAX;
442 | 1260 | break;
443 | 0 | case SVt_PVOBJ:
444 | 0 | ObjectMAXFIELD(sv) = -1;
445 | 0 | ObjectFIELDS(sv) = NULL;
446 | 0 | break;
447 | 0 | default:
448 | 0 | NOT_REACHED;
449 |  | }
450 |
451 | 17794 | sv->sv_u.svu_array = NULL; /* or svu_hash */
452 | 17794 | break;
453 |
454 | 52 | case SVt_PVIV:
455 |  | case SVt_PVIO:
456 |  | case SVt_PVGV:
457 |  | case SVt_PVCV:
458 |  | case SVt_PVLV:
459 |  | case SVt_INVLIST:
460 |  | case SVt_REGEXP:
461 |  | case SVt_PVMG:
462 |  | case SVt_PVNV:
463 |  | case SVt_PV:
464 |  | /* For a type known at compile time, it should be possible for the
465 |  | * compiler to deduce the value of (type_details->arena), resolve
466 |  | * that branch below, and inline the relevant values from
467 |  | * bodies_by_type. Except, at least for gcc, it seems not to do that.
468 |  | * We help it out here with two deviations from sv_upgrade:
469 |  | * (1) Minor rearrangement here, so that PVFM - the only type at this
470 |  | * point not to be allocated from an array appears last, not PV.
471 |  | * (2) The ASSUME() statement here for everything that isn't PVFM.
472 |  | * Obviously this all only holds as long as it's a true reflection of
473 |  | * the bodies_by_type lookup table. */
474 |  | #ifndef PURIFY
475 | 52 | ASSUME(type_details->arena);
476 |  | #endif
477 |  | /* FALLTHROUGH */
478 |  | case SVt_PVFM:
479 |
480 |  | assert(type_details->body_size);
481 |  | /* We always allocated the full length item with PURIFY. To do this
482 |  | we fake things so that arena is false for all 16 types.. */
483 |  | #ifndef PURIFY
484 | 52 | if(type_details->arena) {
485 |  | /* This points to the start of the allocated area. */
486 | 52 | new_body = S_new_body(aTHX_ type);
487 | 52 | Zero(new_body, type_details->body_size, char);
488 | 52 | new_body = ((char *)new_body) - type_details->offset;
489 |  | } else
490 |  | #endif
491 |  | {
492 | 0 | new_body = new_NOARENAZ(type_details);
493 |  | }
494 | 52 | SvANY(sv) = new_body;
495 |
496 | 52 | if (UNLIKELY(type == SVt_PVIO)) {
497 | 0 | IO * const io = MUTABLE_IO(sv);
498 | 0 | GV *iogv = gv_fetchpvs("IO::File::", GV_ADD, SVt_PVHV);
499 |
500 | 0 | SvOBJECT_on(io);
501 |  | /* Clear the stashcache because a new IO could overrule a package
502 |  | name */
503 |  | DEBUG_o(Perl_deb(aTHX_ "sv_upgrade clearing PL_stashcache\n"));
504 | 0 | hv_clear(PL_stashcache);
505 |
506 | 0 | SvSTASH_set(io, MUTABLE_HV(SvREFCNT_inc(GvHV(iogv))));
507 | 0 | IoPAGE_LEN(sv) = 60;
508 |  | }
509 |
510 | 52 | sv->sv_u.svu_rv = NULL;
511 | 52 | break;
512 | 0 | default:
513 | 0 | Perl_croak(aTHX_ "panic: sv_upgrade to unknown type %lu",
514 |  | (unsigned long)type);
515 |  | }
516 |
517 | 19629 | return sv;
518 |  | }
519 |
520 |  | /*
521 - 534 |  |
    =for apidoc newSV_type_mortal

    Creates a new mortal SV, of the type specified.  The reference count for the
    new SV is set to 1.

    This is equivalent to
        SV* sv = sv_2mortal(newSV_type(<some type>))
    and
        SV* sv = sv_newmortal();
        sv_upgrade(sv, <some_type>)
    but should be more efficient than both of them. (Unless sv_2mortal is inlined
    at some point in the future.)

    =cut
535 |  | */
536 |
537 |  | PERL_STATIC_INLINE SV *
538 |  | Perl_newSV_type_mortal(pTHX_ const svtype type)
539 |  | {
540 |  | SV *sv = newSV_type(type);
541 |  | SSize_t ix = ++PL_tmps_ix;
542 |  | if (UNLIKELY(ix >= PL_tmps_max))
543 |  | ix = Perl_tmps_grow_p(aTHX_ ix);
544 |  | PL_tmps_stack[ix] = (sv);
545 |  | SvTEMP_on(sv);
546 |  | return sv;
547 |  | }
548 |
549 |  | /* The following functions started out in sv.h and then moved to inline.h. They
550 |  | * moved again into this file during the 5.37.x development cycle. */
551 |
552 |  | /*
553 - 564 |  |
    =for apidoc_section $SV
    =for apidoc SvPVXtrue

    Returns a boolean as to whether or not C<sv> contains a PV that is considered
    TRUE.  FALSE is returned if C<sv> doesn't contain a PV, or if the PV it does
    contain is zero length, or consists of just the single character '0'.  Every
    other PV value is considered TRUE.

    As of Perl v5.37.1, C<sv> is evaluated exactly once; in earlier releases, it
    could be evaluated more than once.

    =cut
565 |  | */
566 |
567 |  | PERL_STATIC_INLINE bool
568 |  | Perl_SvPVXtrue(pTHX_ SV *sv)
569 |  | {
570 |  | PERL_ARGS_ASSERT_SVPVXTRUE;
571 |
572 |  | PERL_UNUSED_CONTEXT;
573 |
574 | 0 | if (! (XPV *) SvANY(sv)) {
575 | 0 | return false;
576 |  | }
577 |
578 | 0 | if ( ((XPV *) SvANY(sv))->xpv_cur > 1) { /* length > 1 */
579 | 0 | return true;
580 |  | }
581 |
582 | 0 | if (( (XPV *) SvANY(sv))->xpv_cur == 0) {
583 | 0 | return false;
584 |  | }
585 |
586 | 0 | return *sv->sv_u.svu_pv != '0';
587 |  | }
588 |
589 |  | /*
590 - 595 |  |
    =for apidoc SvGETMAGIC
    Invokes C<L</mg_get>> on an SV if it has 'get' magic.  For example, this
    will call C<FETCH> on a tied variable.  As of 5.37.1, this function is
    guaranteed to evaluate its argument exactly once.

    =cut
596 |  | */
597 |
598 |  | PERL_STATIC_INLINE void
599 | 114 | Perl_SvGETMAGIC(pTHX_ SV *sv)
600 |  | {
601 |  | PERL_ARGS_ASSERT_SVGETMAGIC;
602 |
603 | 114 | if (UNLIKELY(SvGMAGICAL(sv))) {
604 | 0 | mg_get(sv);
605 |  | }
606 | 114 | }
607 |
608 |  | PERL_STATIC_INLINE bool
609 | 114 | Perl_SvTRUE(pTHX_ SV *sv)
610 |  | {
611 |  | PERL_ARGS_ASSERT_SVTRUE;
612 |
613 | 114 | if (UNLIKELY(sv == NULL))
614 | 0 | return FALSE;
615 | 114 | SvGETMAGIC(sv);
616 | 114 | return SvTRUE_nomg_NN(sv);
617 |  | }
618 |
619 |  | PERL_STATIC_INLINE bool
620 |  | Perl_SvTRUE_nomg(pTHX_ SV *sv)
621 |  | {
622 |  | PERL_ARGS_ASSERT_SVTRUE_NOMG;
623 |
624 |  | if (UNLIKELY(sv == NULL))
625 |  | return FALSE;
626 |  | return SvTRUE_nomg_NN(sv);
627 |  | }
628 |
629 |  | PERL_STATIC_INLINE bool
630 |  | Perl_SvTRUE_NN(pTHX_ SV *sv)
631 |  | {
632 |  | PERL_ARGS_ASSERT_SVTRUE_NN;
633 |
634 |  | SvGETMAGIC(sv);
635 |  | return SvTRUE_nomg_NN(sv);
636 |  | }
637 |
638 |  | PERL_STATIC_INLINE bool
639 | 114 | Perl_SvTRUE_common(pTHX_ SV * sv, const bool sv_2bool_is_fallback)
640 |  | {
641 |  | PERL_ARGS_ASSERT_SVTRUE_COMMON;
642 |
643 | 114 | if (UNLIKELY(SvIMMORTAL_INTERP(sv)))
644 | 42 | return SvIMMORTAL_TRUE(sv);
645 |
646 | 72 | if (! SvOK(sv))
647 | 0 | return FALSE;
648 |
649 | 72 | if (SvPOK(sv))
650 | 0 | return SvPVXtrue(sv);
651 |
652 | 72 | if (SvIOK(sv))
653 | 72 | return SvIVX(sv) != 0; /* casts to bool */
654 |
655 | 0 | if (SvROK(sv) && !(SvOBJECT(SvRV(sv)) && HvAMAGIC(SvSTASH(SvRV(sv)))))
656 | 0 | return TRUE;
657 |
658 | 0 | if (sv_2bool_is_fallback)
659 | 0 | return sv_2bool_nomg(sv);
660 |
661 | 0 | return isGV_with_GP(sv);
662 |  | }
663 |
664 |  | PERL_STATIC_INLINE SV *
665 | 0 | Perl_SvREFCNT_inc(SV *sv)
666 |  | {
667 | 0 | if (LIKELY(sv != NULL))
668 | 0 | SvREFCNT(sv)++;
669 | 0 | return sv;
670 |  | }
671 |
672 |  | PERL_STATIC_INLINE SV *
673 |  | Perl_SvREFCNT_inc_NN(SV *sv)
674 |  | {
675 |  | PERL_ARGS_ASSERT_SVREFCNT_INC_NN;
676 |
677 |  | SvREFCNT(sv)++;
678 |  | return sv;
679 |  | }
680 |
681 |  | PERL_STATIC_INLINE void
682 |  | Perl_SvREFCNT_inc_void(SV *sv)
683 |  | {
684 |  | if (LIKELY(sv != NULL))
685 |  | SvREFCNT(sv)++;
686 |  | }
687 |
688 |  | PERL_STATIC_INLINE void
689 | 16103 | Perl_SvREFCNT_dec(pTHX_ SV *sv)
690 |  | {
691 | 16103 | if (LIKELY(sv != NULL)) {
692 | 16103 | U32 rc = SvREFCNT(sv);
693 | 16103 | if (LIKELY(rc > 1))
694 | 0 | SvREFCNT(sv) = rc - 1;
695 |  | else
696 | 16103 | Perl_sv_free2(aTHX_ sv, rc);
697 |  | }
698 | 16103 | }
699 |
700 |  | PERL_STATIC_INLINE SV *
701 |  | Perl_SvREFCNT_dec_ret_NULL(pTHX_ SV *sv)
702 |  | {
703 |  | PERL_ARGS_ASSERT_SVREFCNT_DEC_RET_NULL;
704 |  | Perl_SvREFCNT_dec(aTHX_ sv);
705 |  | return NULL;
706 |  | }
707 |
708 |
709 |  | PERL_STATIC_INLINE void
710 |  | Perl_SvREFCNT_dec_NN(pTHX_ SV *sv)
711 |  | {
712 |  | U32 rc = SvREFCNT(sv);
713 |
714 |  | PERL_ARGS_ASSERT_SVREFCNT_DEC_NN;
715 |
716 |  | if (LIKELY(rc > 1))
717 |  | SvREFCNT(sv) = rc - 1;
718 |  | else
719 |  | Perl_sv_free2(aTHX_ sv, rc);
720 |  | }
721 |
722 |  | /*
723 - 727 |  |
    =for apidoc SvAMAGIC_on

    Indicate that C<sv> has overloading (active magic) enabled.

    =cut
728 |  | */
729 |
730 |  | PERL_STATIC_INLINE void
731 |  | Perl_SvAMAGIC_on(SV *sv)
732 |  | {
733 |  | PERL_ARGS_ASSERT_SVAMAGIC_ON;
734 |  | assert(SvROK(sv));
735 |
736 |  | if (SvOBJECT(SvRV(sv))) HvAMAGIC_on(SvSTASH(SvRV(sv)));
737 |  | }
738 |
739 |  | /*
740 - 744 |  |
    =for apidoc SvAMAGIC_off

    Indicate that C<sv> has overloading (active magic) disabled.

    =cut
745 |  | */
746 |
747 |  | PERL_STATIC_INLINE void
748 |  | Perl_SvAMAGIC_off(SV *sv)
749 |  | {
750 |  | PERL_ARGS_ASSERT_SVAMAGIC_OFF;
751 |
752 |  | if (SvROK(sv) && SvOBJECT(SvRV(sv)))
753 |  | HvAMAGIC_off(SvSTASH(SvRV(sv)));
754 |  | }
755 |
756 |  | PERL_STATIC_INLINE U32
757 |  | Perl_SvPADSTALE_on(SV *sv)
758 |  | {
759 |  | assert(!(SvFLAGS(sv) & SVs_PADTMP));
760 |  | return SvFLAGS(sv) |= SVs_PADSTALE;
761 |  | }
762 |  | PERL_STATIC_INLINE U32
763 |  | Perl_SvPADSTALE_off(SV *sv)
764 |  | {
765 |  | assert(!(SvFLAGS(sv) & SVs_PADTMP));
766 |  | return SvFLAGS(sv) &= ~SVs_PADSTALE;
767 |  | }
768 |
769 |  | /*
770 - 814 |  |
    =for apidoc_section $SV
    =for apidoc         SvIV
    =for apidoc_item    SvIV_nomg
    =for apidoc_item m||SvIVx

    These each coerce the given SV to IV and return it.  The returned value in many
    circumstances will get stored in C<sv>'s IV slot, but not in all cases.  (Use
    C<L</sv_setiv>> to make sure it does).

    As of 5.37.1, all are guaranteed to evaluate C<sv> only once.

    C<SvIVx> is now identical to C<SvIV>, but prior to 5.37.1, it was the only form
    guaranteed to evaluate C<sv> only once.

    C<SvIV_nomg> is the same as C<SvIV>, but does not perform 'get' magic.

    =for apidoc         SvNV
    =for apidoc_item    SvNV_nomg
    =for apidoc_item m||SvNVx

    These each coerce the given SV to NV and return it.  The returned value in many
    circumstances will get stored in C<sv>'s NV slot, but not in all cases.  (Use
    C<L</sv_setnv>> to make sure it does).

    As of 5.37.1, all are guaranteed to evaluate C<sv> only once.

    C<SvNVx> is now identical to C<SvNV>, but prior to 5.37.1, it was the only form
    guaranteed to evaluate C<sv> only once.

    C<SvNV_nomg> is the same as C<SvNV>, but does not perform 'get' magic.

    =for apidoc         SvUV
    =for apidoc_item    SvUV_nomg
    =for apidoc_item m||SvUVx

    These each coerce the given SV to UV and return it.  The returned value in many
    circumstances will get stored in C<sv>'s UV slot, but not in all cases.  (Use
    C<L</sv_setuv>> to make sure it does).

    As of 5.37.1, all are guaranteed to evaluate C<sv> only once.

    C<SvUVx> is now identical to C<SvUV>, but prior to 5.37.1, it was the only form
    guaranteed to evaluate C<sv> only once.

    =cut
815 |  | */
816 |
817 |  | PERL_STATIC_INLINE IV
818 | 100 | Perl_SvIV(pTHX_ SV *sv) {
819 |  | PERL_ARGS_ASSERT_SVIV;
820 |
821 | 100 | if (SvIOK_nog(sv))
822 | 100 | return SvIVX(sv);
823 | 0 | return sv_2iv(sv);
824 |  | }
825 |
826 |  | PERL_STATIC_INLINE UV
827 | 201 | Perl_SvUV(pTHX_ SV *sv) {
828 |  | PERL_ARGS_ASSERT_SVUV;
829 |
830 | 201 | if (SvUOK_nog(sv))
831 | 0 | return SvUVX(sv);
832 | 201 | return sv_2uv(sv);
833 |  | }
834 |
835 |  | PERL_STATIC_INLINE NV
836 | 265766 | Perl_SvNV(pTHX_ SV *sv) {
837 |  | PERL_ARGS_ASSERT_SVNV;
838 |
839 | 265766 | if (SvNOK_nog(sv))
840 | 221182 | return SvNVX(sv);
841 | 44584 | return sv_2nv(sv);
842 |  | }
843 |
844 |  | PERL_STATIC_INLINE IV
845 |  | Perl_SvIV_nomg(pTHX_ SV *sv) {
846 |  | PERL_ARGS_ASSERT_SVIV_NOMG;
847 |
848 |  | if (SvIOK(sv))
849 |  | return SvIVX(sv);
850 |  | return sv_2iv_flags(sv, 0);
851 |  | }
852 |
853 |  | PERL_STATIC_INLINE UV
854 |  | Perl_SvUV_nomg(pTHX_ SV *sv) {
855 |  | PERL_ARGS_ASSERT_SVUV_NOMG;
856 |
857 |  | if (SvUOK(sv))
858 |  | return SvUVX(sv);
859 |  | return sv_2uv_flags(sv, 0);
860 |  | }
861 |
862 |  | PERL_STATIC_INLINE NV
863 |  | Perl_SvNV_nomg(pTHX_ SV *sv) {
864 |  | PERL_ARGS_ASSERT_SVNV_NOMG;
865 |
866 |  | if (SvNOK(sv))
867 |  | return SvNVX(sv);
868 |  | return sv_2nv_flags(sv, 0);
869 |  | }
870 |
871 |  | #if defined(PERL_CORE) || defined (PERL_EXT)
872 |  | PERL_STATIC_INLINE STRLEN
873 |  | S_sv_or_pv_pos_u2b(pTHX_ SV *sv, const char *pv, STRLEN pos, STRLEN *lenp)
874 |  | {
875 |  | PERL_ARGS_ASSERT_SV_OR_PV_POS_U2B;
876 |  | if (SvGAMAGIC(sv)) {
877 |  | U8 *hopped = utf8_hop((U8 *)pv, pos);
878 |  | if (lenp) *lenp = (STRLEN)(utf8_hop(hopped, *lenp) - hopped);
879 |  | return (STRLEN)(hopped - (U8 *)pv);
880 |  | }
881 |  | return sv_pos_u2b_flags(sv,pos,lenp,SV_CONST_RETURN);
882 |  | }
883 |  | #endif
884 |
885 |  | PERL_STATIC_INLINE char *
886 |  | Perl_sv_pvutf8n_force_wrapper(pTHX_ SV * const sv, STRLEN * const lp, const U32 dummy)
887 |  | {
888 |  | /* This is just so can be passed to Perl_SvPV_helper() as a function
889 |  | * pointer with the same signature as all the other such pointers, and
890 |  | * having hence an unused parameter */
891 |  | PERL_ARGS_ASSERT_SV_PVUTF8N_FORCE_WRAPPER;
892 |  | PERL_UNUSED_ARG(dummy);
893 |
894 |  | return sv_pvutf8n_force(sv, lp);
895 |  | }
896 |
897 |  | PERL_STATIC_INLINE char *
898 |  | Perl_sv_pvbyten_force_wrapper(pTHX_ SV * const sv, STRLEN * const lp, const U32 dummy)
899 |  | {
900 |  | /* This is just so can be passed to Perl_SvPV_helper() as a function
901 |  | * pointer with the same signature as all the other such pointers, and
902 |  | * having hence an unused parameter */
903 |  | PERL_ARGS_ASSERT_SV_PVBYTEN_FORCE_WRAPPER;
904 |  | PERL_UNUSED_ARG(dummy);
905 |
906 |  | return sv_pvbyten_force(sv, lp);
907 |  | }
908 |
909 |  | PERL_STATIC_INLINE char *
910 | 20254 | Perl_SvPV_helper(pTHX_
911 |  | SV * const sv,
912 |  | STRLEN * const lp,
913 |  | const U32 flags,
914 |  | const PL_SvPVtype type,
915 |  | char * (*non_trivial)(pTHX_ SV *, STRLEN * const, const U32),
916 |  | const bool or_null,
917 |  | const U32 return_flags
918 |  | )
919 |  | {
920 |  | /* 'type' should be known at compile time, so this is reduced to a single
921 |  | * conditional at runtime */
922 | 20254 | if ( (type == SvPVbyte_type_ && SvPOK_byte_nog(sv))
923 | 20248 | || (type == SvPVforce_type_ && SvPOK_pure_nogthink(sv))
924 | 20248 | || (type == SvPVutf8_type_ && SvPOK_utf8_nog(sv))
925 | 20248 | || (type == SvPVnormal_type_ && SvPOK_nog(sv))
926 | 199 | || (type == SvPVutf8_pure_type_ && SvPOK_utf8_pure_nogthink(sv))
927 | 199 | || (type == SvPVbyte_pure_type_ && SvPOK_byte_pure_nogthink(sv))
928 |  | ) {
929 | 20055 | if (lp) {
930 | 6 | *lp = SvCUR(sv);
931 |  | }
932 |
933 |  | /* Similarly 'return_flags is known at compile time, so this becomes
934 |  | * branchless */
935 | 20055 | if (return_flags & SV_MUTABLE_RETURN) {
936 | 0 | return SvPVX_mutable(sv);
937 |  | }
938 | 20055 | else if(return_flags & SV_CONST_RETURN) {
939 | 0 | return (char *) SvPVX_const(sv);
940 |  | }
941 |  | else {
942 | 20055 | return SvPVX(sv);
943 |  | }
944 |  | }
945 |
946 | 199 | if (or_null) { /* This is also known at compile time */
947 | 0 | if (flags & SV_GMAGIC) { /* As is this */
948 | 0 | SvGETMAGIC(sv);
949 |  | }
950 |
951 | 0 | if (! SvOK(sv)) {
952 | 0 | if (lp) { /* As is this */
953 | 0 | *lp = 0;
954 |  | }
955 |
956 | 0 | return NULL;
957 |  | }
958 |  | }
959 |
960 |  | /* Can't trivially handle this, call the function */
961 | 199 | return non_trivial(aTHX_ sv, lp, (flags|return_flags));
962 |  | }
963 |
964 |  | /*
965 - 970 |  |
    =for apidoc newRV_noinc

    Creates an RV wrapper for an SV.  The reference count for the original
    SV is B<not> incremented.

    =cut
971 |  | */
972 |
973 |  | PERL_STATIC_INLINE SV *
974 | 1783 | Perl_newRV_noinc(pTHX_ SV *const tmpRef)
975 |  | {
976 | 1783 | SV *sv = newSV_type(SVt_IV);
977 |
978 |  | PERL_ARGS_ASSERT_NEWRV_NOINC;
979 |
980 | 1783 | SvTEMP_off(tmpRef);
981 |
982 |  | /* inlined, simplified sv_setrv_noinc(sv, tmpRef); */
983 | 1783 | SvRV_set(sv, tmpRef);
984 | 1783 | SvROK_on(sv);
985 |
986 | 1783 | return sv;
987 |  | }
988 |
989 |  | PERL_STATIC_INLINE char *
990 |  | Perl_sv_setpv_freshbuf(pTHX_ SV *const sv)
991 |  | {
992 |  | PERL_ARGS_ASSERT_SV_SETPV_FRESHBUF;
993 |  | assert(SvTYPE(sv) >= SVt_PV);
994 |  | assert(SvTYPE(sv) <= SVt_PVMG);
995 |  | assert(!SvTHINKFIRST(sv));
996 |  | assert(SvPVX(sv));
997 |  | SvCUR_set(sv, 0);
998 |  | *(SvEND(sv))= '\0';
999 |  | (void)SvPOK_only_UTF8(sv); /* UTF-8 flag will be 0; This is used instead
1000 |  | of 'SvPOK_only' because the other sv_setpv
1001 |  | functions use it */
1002 |  | SvTAINT(sv);
1003 |  | return SvPVX(sv);
1004 |  | }
1005 |
1006 |  | /*
1007 |  | * ex: set ts=8 sts=4 sw=4 et:
1008 |  | */