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