File Coverage

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

linestmtbrancondsubtimecode
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. */
68SV* Perl_more_sv(pTHX);
69
70/* new_SV(): return a new, empty SV head */
71PERL_STATIC_INLINE SV*
72
14662
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
14662
    if (PL_sv_root)
83
14662
        uproot_SV(sv);
84    else
85
0
        sv = Perl_more_sv(aTHX);
86
14662
    SvANY(sv) = 0;
87
14662
    SvREFCNT(sv) = 1;
88
14662
    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
14662
    return sv;
108}
109#  define new_SV(p) (p)=Perl_new_sv(aTHX_ __FILE__, __LINE__, FUNCTION__)
110
111typedef struct xpvhv_with_aux XPVHV_WITH_AUX;
112
113struct 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
132ALIGNED_TYPE(regexp);
133ALIGNED_TYPE(XPVGV);
134ALIGNED_TYPE(XPVLV);
135ALIGNED_TYPE(XPVAV);
136ALIGNED_TYPE(XPVHV);
137ALIGNED_TYPE(XPVHV_WITH_AUX);
138ALIGNED_TYPE(XPVCV);
139ALIGNED_TYPE(XPVFM);
140ALIGNED_TYPE(XPVIO);
141ALIGNED_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
183static 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
341PERL_STATIC_INLINE void *
342
13352
S_new_body(pTHX_ const svtype sv_type)
343{
344    void *xpv;
345
13352
    new_body_from_arena(xpv, sv_type, bodies_by_type[sv_type]);
346
13352
    return xpv;
347}
348
349#endif
350
351static const struct body_details fake_rv =
352    { 0, 0, 0, SVt_IV, FALSE, NONV, NOARENA, 0 };
353
354static 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
371PERL_STATIC_INLINE SV *
372
14662
Perl_newSV_type(pTHX_ const svtype type)
373{
374    SV *sv;
375    void*      new_body;
376    const struct body_details *type_details;
377
378
14662
    new_SV(sv);
379
380
14662
    type_details = bodies_by_type + type;
381
382
14662
    SvFLAGS(sv) &= ~SVTYPEMASK;
383
14662
    SvFLAGS(sv) |= type;
384
385
14662
    switch (type) {
386
0
    case SVt_NULL:
387
0
        break;
388
1310
    case SVt_IV:
389
1310
        SET_SVANY_FOR_BODYLESS_IV(sv);
390
1310
        SvIV_set(sv, 0);
391
1310
        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
13313
    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
13313
        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
13313
        SvANY(sv) = new_body;
418
419
13313
        SvSTASH_set(sv, NULL);
420
13313
        SvMAGIC_set(sv, NULL);
421
422
13313
        switch(type) {
423
12391
        case SVt_PVAV:
424
12391
            AvFILLp(sv) = -1;
425
12391
            AvMAX(sv) = -1;
426
12391
            AvALLOC(sv) = NULL;
427
428
12391
            AvREAL_only(sv);
429
12391
            break;
430
922
        case SVt_PVHV:
431
922
            HvTOTALKEYS(sv) = 0;
432            /* start with PERL_HASH_DEFAULT_HvMAX+1 buckets: */
433
922
            HvMAX(sv) = PERL_HASH_DEFAULT_HvMAX;
434
435            assert(!SvOK(sv));
436
922
            SvOK_off(sv);
437#ifndef NODEFAULT_SHAREKEYS
438
922
            HvSHAREKEYS_on(sv);         /* key-sharing on by default */
439#endif
440            /* start with PERL_HASH_DEFAULT_HvMAX+1 buckets: */
441
922
            HvMAX(sv) = PERL_HASH_DEFAULT_HvMAX;
442
922
            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
13313
        sv->sv_u.svu_array = NULL; /* or svu_hash  */
452
13313
        break;
453
454
39
    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
39
         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
39
        if(type_details->arena) {
485            /* This points to the start of the allocated area.  */
486
39
            new_body = S_new_body(aTHX_ type);
487
39
            Zero(new_body, type_details->body_size, char);
488
39
            new_body = ((char *)new_body) - type_details->offset;
489        } else
490#endif
491        {
492
0
            new_body = new_NOARENAZ(type_details);
493        }
494
39
        SvANY(sv) = new_body;
495
496
39
        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
39
        sv->sv_u.svu_rv = NULL;
511
39
        break;
512
0
    default:
513
0
        Perl_croak(aTHX_ "panic: sv_upgrade to unknown type %lu",
514                   (unsigned long)type);
515    }
516
517
14662
    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
537PERL_STATIC_INLINE SV *
538Perl_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
567PERL_STATIC_INLINE bool
568Perl_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
598PERL_STATIC_INLINE void
599
85
Perl_SvGETMAGIC(pTHX_ SV *sv)
600{
601    PERL_ARGS_ASSERT_SVGETMAGIC;
602
603
85
    if (UNLIKELY(SvGMAGICAL(sv))) {
604
0
        mg_get(sv);
605    }
606
85
}
607
608PERL_STATIC_INLINE bool
609
85
Perl_SvTRUE(pTHX_ SV *sv)
610{
611    PERL_ARGS_ASSERT_SVTRUE;
612
613
85
    if (UNLIKELY(sv == NULL))
614
0
        return FALSE;
615
85
    SvGETMAGIC(sv);
616
85
    return SvTRUE_nomg_NN(sv);
617}
618
619PERL_STATIC_INLINE bool
620Perl_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
629PERL_STATIC_INLINE bool
630Perl_SvTRUE_NN(pTHX_ SV *sv)
631{
632    PERL_ARGS_ASSERT_SVTRUE_NN;
633
634    SvGETMAGIC(sv);
635    return SvTRUE_nomg_NN(sv);
636}
637
638PERL_STATIC_INLINE bool
639
85
Perl_SvTRUE_common(pTHX_ SV * sv, const bool sv_2bool_is_fallback)
640{
641    PERL_ARGS_ASSERT_SVTRUE_COMMON;
642
643
85
    if (UNLIKELY(SvIMMORTAL_INTERP(sv)))
644
42
        return SvIMMORTAL_TRUE(sv);
645
646
43
    if (! SvOK(sv))
647
0
        return FALSE;
648
649
43
    if (SvPOK(sv))
650
0
        return SvPVXtrue(sv);
651
652
43
    if (SvIOK(sv))
653
43
        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
664PERL_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
672PERL_STATIC_INLINE SV *
673Perl_SvREFCNT_inc_NN(SV *sv)
674{
675    PERL_ARGS_ASSERT_SVREFCNT_INC_NN;
676
677    SvREFCNT(sv)++;
678    return sv;
679}
680
681PERL_STATIC_INLINE void
682Perl_SvREFCNT_inc_void(SV *sv)
683{
684    if (LIKELY(sv != NULL))
685        SvREFCNT(sv)++;
686}
687
688PERL_STATIC_INLINE void
689
12072
Perl_SvREFCNT_dec(pTHX_ SV *sv)
690{
691
12072
    if (LIKELY(sv != NULL)) {
692
12072
        U32 rc = SvREFCNT(sv);
693
12072
        if (LIKELY(rc > 1))
694
0
            SvREFCNT(sv) = rc - 1;
695        else
696
12072
            Perl_sv_free2(aTHX_ sv, rc);
697    }
698
12072
}
699
700PERL_STATIC_INLINE SV *
701Perl_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
709PERL_STATIC_INLINE void
710Perl_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
730PERL_STATIC_INLINE void
731Perl_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
747PERL_STATIC_INLINE void
748Perl_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
756PERL_STATIC_INLINE U32
757Perl_SvPADSTALE_on(SV *sv)
758{
759    assert(!(SvFLAGS(sv) & SVs_PADTMP));
760    return SvFLAGS(sv) |= SVs_PADSTALE;
761}
762PERL_STATIC_INLINE U32
763Perl_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
817PERL_STATIC_INLINE IV
818
75
Perl_SvIV(pTHX_ SV *sv) {
819    PERL_ARGS_ASSERT_SVIV;
820
821
75
    if (SvIOK_nog(sv))
822
75
        return SvIVX(sv);
823
0
    return sv_2iv(sv);
824}
825
826PERL_STATIC_INLINE UV
827
148
Perl_SvUV(pTHX_ SV *sv) {
828    PERL_ARGS_ASSERT_SVUV;
829
830
148
    if (SvUOK_nog(sv))
831
0
        return SvUVX(sv);
832
148
    return sv_2uv(sv);
833}
834
835PERL_STATIC_INLINE NV
836
199192
Perl_SvNV(pTHX_ SV *sv) {
837    PERL_ARGS_ASSERT_SVNV;
838
839
199192
    if (SvNOK_nog(sv))
840
165787
        return SvNVX(sv);
841
33405
    return sv_2nv(sv);
842}
843
844PERL_STATIC_INLINE IV
845Perl_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
853PERL_STATIC_INLINE UV
854Perl_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
862PERL_STATIC_INLINE NV
863Perl_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)
872PERL_STATIC_INLINE STRLEN
873S_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
885PERL_STATIC_INLINE char *
886Perl_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
897PERL_STATIC_INLINE char *
898Perl_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
909PERL_STATIC_INLINE char *
910
15149
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
15149
    if (   (type == SvPVbyte_type_      && SvPOK_byte_nog(sv))
923
15143
        || (type == SvPVforce_type_     && SvPOK_pure_nogthink(sv))
924
15143
        || (type == SvPVutf8_type_      && SvPOK_utf8_nog(sv))
925
15143
        || (type == SvPVnormal_type_    && SvPOK_nog(sv))
926
138
        || (type == SvPVutf8_pure_type_ && SvPOK_utf8_pure_nogthink(sv))
927
138
        || (type == SvPVbyte_pure_type_ && SvPOK_byte_pure_nogthink(sv))
928   ) {
929
15011
        if (lp) {
930
6
            *lp = SvCUR(sv);
931        }
932
933        /* Similarly 'return_flags is known at compile time, so this becomes
934         * branchless */
935
15011
        if (return_flags & SV_MUTABLE_RETURN) {
936
0
            return SvPVX_mutable(sv);
937        }
938
15011
        else if(return_flags & SV_CONST_RETURN) {
939
0
            return (char *) SvPVX_const(sv);
940        }
941        else {
942
15011
            return SvPVX(sv);
943        }
944    }
945
946
138
    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
138
    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
973PERL_STATIC_INLINE SV *
974
1310
Perl_newRV_noinc(pTHX_ SV *const tmpRef)
975{
976
1310
    SV *sv = newSV_type(SVt_IV);
977
978    PERL_ARGS_ASSERT_NEWRV_NOINC;
979
980
1310
    SvTEMP_off(tmpRef);
981
982    /* inlined, simplified sv_setrv_noinc(sv, tmpRef); */
983
1310
    SvRV_set(sv, tmpRef);
984
1310
    SvROK_on(sv);
985
986
1310
    return sv;
987}
988
989PERL_STATIC_INLINE char *
990Perl_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 */