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
29324
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
29324
    if (PL_sv_root)
83
29324
        uproot_SV(sv);
84    else
85
0
        sv = Perl_more_sv(aTHX);
86
29324
    SvANY(sv) = 0;
87
29324
    SvREFCNT(sv) = 1;
88
29324
    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
29324
    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
26704
S_new_body(pTHX_ const svtype sv_type)
343{
344    void *xpv;
345
26704
    new_body_from_arena(xpv, sv_type, bodies_by_type[sv_type]);
346
26704
    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
29324
Perl_newSV_type(pTHX_ const svtype type)
373{
374    SV *sv;
375    void*      new_body;
376    const struct body_details *type_details;
377
378
29324
    new_SV(sv);
379
380
29324
    type_details = bodies_by_type + type;
381
382
29324
    SvFLAGS(sv) &= ~SVTYPEMASK;
383
29324
    SvFLAGS(sv) |= type;
384
385
29324
    switch (type) {
386
0
    case SVt_NULL:
387
0
        break;
388
2620
    case SVt_IV:
389
2620
        SET_SVANY_FOR_BODYLESS_IV(sv);
390
2620
        SvIV_set(sv, 0);
391
2620
        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
26626
    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
26626
        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
26626
        SvANY(sv) = new_body;
418
419
26626
        SvSTASH_set(sv, NULL);
420
26626
        SvMAGIC_set(sv, NULL);
421
422
26626
        switch(type) {
423
24782
        case SVt_PVAV:
424
24782
            AvFILLp(sv) = -1;
425
24782
            AvMAX(sv) = -1;
426
24782
            AvALLOC(sv) = NULL;
427
428
24782
            AvREAL_only(sv);
429
24782
            break;
430
1844
        case SVt_PVHV:
431
1844
            HvTOTALKEYS(sv) = 0;
432            /* start with PERL_HASH_DEFAULT_HvMAX+1 buckets: */
433
1844
            HvMAX(sv) = PERL_HASH_DEFAULT_HvMAX;
434
435            assert(!SvOK(sv));
436
1844
            SvOK_off(sv);
437#ifndef NODEFAULT_SHAREKEYS
438
1844
            HvSHAREKEYS_on(sv);         /* key-sharing on by default */
439#endif
440            /* start with PERL_HASH_DEFAULT_HvMAX+1 buckets: */
441
1844
            HvMAX(sv) = PERL_HASH_DEFAULT_HvMAX;
442
1844
            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
26626
        sv->sv_u.svu_array = NULL; /* or svu_hash  */
452
26626
        break;
453
454
78
    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
78
         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
78
        if(type_details->arena) {
485            /* This points to the start of the allocated area.  */
486
78
            new_body = S_new_body(aTHX_ type);
487
78
            Zero(new_body, type_details->body_size, char);
488
78
            new_body = ((char *)new_body) - type_details->offset;
489        } else
490#endif
491        {
492
0
            new_body = new_NOARENAZ(type_details);
493        }
494
78
        SvANY(sv) = new_body;
495
496
78
        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
78
        sv->sv_u.svu_rv = NULL;
511
78
        break;
512
0
    default:
513
0
        Perl_croak(aTHX_ "panic: sv_upgrade to unknown type %lu",
514                   (unsigned long)type);
515    }
516
517
29324
    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
170
Perl_SvGETMAGIC(pTHX_ SV *sv)
600{
601    PERL_ARGS_ASSERT_SVGETMAGIC;
602
603
170
    if (UNLIKELY(SvGMAGICAL(sv))) {
604
0
        mg_get(sv);
605    }
606
170
}
607
608PERL_STATIC_INLINE bool
609
170
Perl_SvTRUE(pTHX_ SV *sv)
610{
611    PERL_ARGS_ASSERT_SVTRUE;
612
613
170
    if (UNLIKELY(sv == NULL))
614
0
        return FALSE;
615
170
    SvGETMAGIC(sv);
616
170
    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
170
Perl_SvTRUE_common(pTHX_ SV * sv, const bool sv_2bool_is_fallback)
640{
641    PERL_ARGS_ASSERT_SVTRUE_COMMON;
642
643
170
    if (UNLIKELY(SvIMMORTAL_INTERP(sv)))
644
84
        return SvIMMORTAL_TRUE(sv);
645
646
86
    if (! SvOK(sv))
647
0
        return FALSE;
648
649
86
    if (SvPOK(sv))
650
0
        return SvPVXtrue(sv);
651
652
86
    if (SvIOK(sv))
653
86
        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
24144
Perl_SvREFCNT_dec(pTHX_ SV *sv)
690{
691
24144
    if (LIKELY(sv != NULL)) {
692
24144
        U32 rc = SvREFCNT(sv);
693
24144
        if (LIKELY(rc > 1))
694
0
            SvREFCNT(sv) = rc - 1;
695        else
696
24144
            Perl_sv_free2(aTHX_ sv, rc);
697    }
698
24144
}
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
150
Perl_SvIV(pTHX_ SV *sv) {
819    PERL_ARGS_ASSERT_SVIV;
820
821
150
    if (SvIOK_nog(sv))
822
150
        return SvIVX(sv);
823
0
    return sv_2iv(sv);
824}
825
826PERL_STATIC_INLINE UV
827
296
Perl_SvUV(pTHX_ SV *sv) {
828    PERL_ARGS_ASSERT_SVUV;
829
830
296
    if (SvUOK_nog(sv))
831
0
        return SvUVX(sv);
832
296
    return sv_2uv(sv);
833}
834
835PERL_STATIC_INLINE NV
836
398384
Perl_SvNV(pTHX_ SV *sv) {
837    PERL_ARGS_ASSERT_SVNV;
838
839
398384
    if (SvNOK_nog(sv))
840
331574
        return SvNVX(sv);
841
66810
    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
30298
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
30298
    if (   (type == SvPVbyte_type_      && SvPOK_byte_nog(sv))
923
30286
        || (type == SvPVforce_type_     && SvPOK_pure_nogthink(sv))
924
30286
        || (type == SvPVutf8_type_      && SvPOK_utf8_nog(sv))
925
30286
        || (type == SvPVnormal_type_    && SvPOK_nog(sv))
926
276
        || (type == SvPVutf8_pure_type_ && SvPOK_utf8_pure_nogthink(sv))
927
276
        || (type == SvPVbyte_pure_type_ && SvPOK_byte_pure_nogthink(sv))
928   ) {
929
30022
        if (lp) {
930
12
            *lp = SvCUR(sv);
931        }
932
933        /* Similarly 'return_flags is known at compile time, so this becomes
934         * branchless */
935
30022
        if (return_flags & SV_MUTABLE_RETURN) {
936
0
            return SvPVX_mutable(sv);
937        }
938
30022
        else if(return_flags & SV_CONST_RETURN) {
939
0
            return (char *) SvPVX_const(sv);
940        }
941        else {
942
30022
            return SvPVX(sv);
943        }
944    }
945
946
276
    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
276
    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
2620
Perl_newRV_noinc(pTHX_ SV *const tmpRef)
975{
976
2620
    SV *sv = newSV_type(SVt_IV);
977
978    PERL_ARGS_ASSERT_NEWRV_NOINC;
979
980
2620
    SvTEMP_off(tmpRef);
981
982    /* inlined, simplified sv_setrv_noinc(sv, tmpRef); */
983
2620
    SvRV_set(sv, tmpRef);
984
2620
    SvROK_on(sv);
985
986
2620
    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 */