sv.c

   1 /*    sv.c
   2  *
   3  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
   4  *    2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
   5  *
   6  *    You may distribute under the terms of either the GNU General Public
   7  *    License or the Artistic License, as specified in the README file.
   8  *
   9  * "I wonder what the Entish is for 'yes' and 'no'," he thought.
  10  *
  11  *
  12  * This file contains the code that creates, manipulates and destroys
  13  * scalar values (SVs). The other types (AV, HV, GV, etc.) reuse the
  14  * structure of an SV, so their creation and destruction is handled
  15  * here; higher-level functions are in av.c, hv.c, and so on. Opcode
  16  * level functions (eg. substr, split, join) for each of the types are
  17  * in the pp*.c files.
  18  */
  19
  20 #include "EXTERN.h"
  21 #define PERL_IN_SV_C
  22 #include "perl.h"
  23 #include "regcomp.h"
  24
  25 #define FCALL *f
  26
  27 #ifdef __Lynx__
  28 /* Missing proto on LynxOS */
  29   char *gconvert(double, int, int,  char *);
  30 #endif
  31
  32 #ifdef PERL_UTF8_CACHE_ASSERT
  33 /* if adding more checks watch out for the following tests:
  34  *   t/op/index.t t/op/length.t t/op/pat.t t/op/substr.t
  35  *   lib/utf8.t lib/Unicode/Collate/t/index.t
  36  * --jhi
  37  */
  38 #   define ASSERT_UTF8_CACHE(cache) \
  39     STMT_START { if (cache) { assert((cache)[0] <= (cache)[1]); \
  40                               assert((cache)[2] <= (cache)[3]); \
  41                               assert((cache)[3] <= (cache)[1]);} \
  42                               } STMT_END
  43 #else
  44 #   define ASSERT_UTF8_CACHE(cache) NOOP
  45 #endif
  46
  47 #ifdef PERL_OLD_COPY_ON_WRITE
  48 #define SV_COW_NEXT_SV(sv)      INT2PTR(SV *,SvUVX(sv))
  49 #define SV_COW_NEXT_SV_SET(current,next)        SvUV_set(current, PTR2UV(next))
  50 /* This is a pessimistic view. Scalar must be purely a read-write PV to copy-
  51    on-write.  */
  52 #endif
  53
  54 /* ============================================================================
  55
  56 =head1 Allocation and deallocation of SVs.
  57
  58 An SV (or AV, HV, etc.) is allocated in two parts: the head (struct
  59 sv, av, hv...) contains type and reference count information, and for
  60 many types, a pointer to the body (struct xrv, xpv, xpviv...), which
  61 contains fields specific to each type.  Some types store all they need
  62 in the head, so don't have a body.
  63
  64 In all but the most memory-paranoid configuations (ex: PURIFY), heads
  65 and bodies are allocated out of arenas, which by default are
  66 approximately 4K chunks of memory parcelled up into N heads or bodies.
  67 Sv-bodies are allocated by their sv-type, guaranteeing size
  68 consistency needed to allocate safely from arrays.
  69
  70 For SV-heads, the first slot in each arena is reserved, and holds a
  71 link to the next arena, some flags, and a note of the number of slots.
  72 Snaked through each arena chain is a linked list of free items; when
  73 this becomes empty, an extra arena is allocated and divided up into N
  74 items which are threaded into the free list.
  75
  76 SV-bodies are similar, but they use arena-sets by default, which
  77 separate the link and info from the arena itself, and reclaim the 1st
  78 slot in the arena.  SV-bodies are further described later.
  79
  80 The following global variables are associated with arenas:
  81
  82     PL_sv_arenaroot     pointer to list of SV arenas
  83     PL_sv_root          pointer to list of free SV structures
  84
  85     PL_body_arenas      head of linked-list of body arenas
  86     PL_body_roots[]     array of pointers to list of free bodies of svtype
  87                         arrays are indexed by the svtype needed
  88
  89 A few special SV heads are not allocated from an arena, but are
  90 instead directly created in the interpreter structure, eg PL_sv_undef.
  91 The size of arenas can be changed from the default by setting
  92 PERL_ARENA_SIZE appropriately at compile time.
  93
  94 The SV arena serves the secondary purpose of allowing still-live SVs
  95 to be located and destroyed during final cleanup.
  96
  97 At the lowest level, the macros new_SV() and del_SV() grab and free
  98 an SV head.  (If debugging with -DD, del_SV() calls the function S_del_sv()
  99 to return the SV to the free list with error checking.) new_SV() calls
 100 more_sv() / sv_add_arena() to add an extra arena if the free list is empty.
 101 SVs in the free list have their SvTYPE field set to all ones.
 102
 103 At the time of very final cleanup, sv_free_arenas() is called from
 104 perl_destruct() to physically free all the arenas allocated since the
 105 start of the interpreter.
 106
 107 The function visit() scans the SV arenas list, and calls a specified
 108 function for each SV it finds which is still live - ie which has an SvTYPE
 109 other than all 1's, and a non-zero SvREFCNT. visit() is used by the
 110 following functions (specified as [function that calls visit()] / [function
 111 called by visit() for each SV]):
 112
 113     sv_report_used() / do_report_used()
 114                         dump all remaining SVs (debugging aid)
 115
 116     sv_clean_objs() / do_clean_objs(),do_clean_named_objs()
 117                         Attempt to free all objects pointed to by RVs,
 118                         and, unless DISABLE_DESTRUCTOR_KLUDGE is defined,
 119                         try to do the same for all objects indirectly
 120                         referenced by typeglobs too.  Called once from
 121                         perl_destruct(), prior to calling sv_clean_all()
 122                         below.
 123
 124     sv_clean_all() / do_clean_all()
 125                         SvREFCNT_dec(sv) each remaining SV, possibly
 126                         triggering an sv_free(). It also sets the
 127                         SVf_BREAK flag on the SV to indicate that the
 128                         refcnt has been artificially lowered, and thus
 129                         stopping sv_free() from giving spurious warnings
 130                         about SVs which unexpectedly have a refcnt
 131                         of zero.  called repeatedly from perl_destruct()
 132                         until there are no SVs left.
 133
 134 =head2 Arena allocator API Summary
 135
 136 Private API to rest of sv.c
 137
 138     new_SV(),  del_SV(),
 139
 140     new_XIV(), del_XIV(),
 141     new_XNV(), del_XNV(),
 142     etc
 143
 144 Public API:
 145
 146     sv_report_used(), sv_clean_objs(), sv_clean_all(), sv_free_arenas()
 147
 148 =cut
 149
 150 ============================================================================ */
 151
 152 /*
 153  * "A time to plant, and a time to uproot what was planted..."
 154  */
 155
 156 void
 157 Perl_offer_nice_chunk(pTHX_ void *const chunk, const U32 chunk_size)
 158 {
 159     dVAR;
 160     void *new_chunk;
 161     U32 new_chunk_size;
 162
 163     PERL_ARGS_ASSERT_OFFER_NICE_CHUNK;
 164
 165     new_chunk = (void *)(chunk);
 166     new_chunk_size = (chunk_size);
 167     if (new_chunk_size > PL_nice_chunk_size) {
 168         Safefree(PL_nice_chunk);
 169         PL_nice_chunk = (char *) new_chunk;
 170         PL_nice_chunk_size = new_chunk_size;
 171     } else {
 172         Safefree(chunk);
 173     }
 174 }
 175
 176 #ifdef PERL_MEM_LOG
 177 #  define MEM_LOG_NEW_SV(sv, file, line, func)  \
 178             Perl_mem_log_new_sv(sv, file, line, func)
 179 #  define MEM_LOG_DEL_SV(sv, file, line, func)  \
 180             Perl_mem_log_del_sv(sv, file, line, func)
 181 #else
 182 #  define MEM_LOG_NEW_SV(sv, file, line, func)  NOOP
 183 #  define MEM_LOG_DEL_SV(sv, file, line, func)  NOOP
 184 #endif
 185
 186 #ifdef DEBUG_LEAKING_SCALARS
 187 #  define FREE_SV_DEBUG_FILE(sv) Safefree((sv)->sv_debug_file)
 188 #  define DEBUG_SV_SERIAL(sv)                                               \
 189     DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) del_SV\n",    \
 190             PTR2UV(sv), (long)(sv)->sv_debug_serial))
 191 #else
 192 #  define FREE_SV_DEBUG_FILE(sv)
 193 #  define DEBUG_SV_SERIAL(sv)   NOOP
 194 #endif
 195
 196 #ifdef PERL_POISON
 197 #  define SvARENA_CHAIN(sv)     ((sv)->sv_u.svu_rv)
 198 #  define SvARENA_CHAIN_SET(sv,val)     (sv)->sv_u.svu_rv = (SV *)(val)
 199 /* Whilst I'd love to do this, it seems that things like to check on
 200    unreferenced scalars
 201 #  define POSION_SV_HEAD(sv)    PoisonNew(sv, 1, struct STRUCT_SV)
 202 */
 203 #  define POSION_SV_HEAD(sv)    PoisonNew(&SvANY(sv), 1, void *), \
 204                                 PoisonNew(&SvREFCNT(sv), 1, U32)
 205 #else
 206 #  define SvARENA_CHAIN(sv)     SvANY(sv)
 207 #  define SvARENA_CHAIN_SET(sv,val)     SvANY(sv) = (void *)(val)
 208 #  define POSION_SV_HEAD(sv)
 209 #endif
 210
 211 /* Mark an SV head as unused, and add to free list.
 212  *
 213  * If SVf_BREAK is set, skip adding it to the free list, as this SV had
 214  * its refcount artificially decremented during global destruction, so
 215  * there may be dangling pointers to it. The last thing we want in that
 216  * case is for it to be reused. */
 217
 218 #define plant_SV(p) \
 219     STMT_START {                                        \
 220         const U32 old_flags = SvFLAGS(p);                       \
 221         MEM_LOG_DEL_SV(p, __FILE__, __LINE__, FUNCTION__);  \
 222         DEBUG_SV_SERIAL(p);                             \
 223         FREE_SV_DEBUG_FILE(p);                          \
 224         POSION_SV_HEAD(p);                              \
 225         SvFLAGS(p) = SVTYPEMASK;                        \
 226         if (!(old_flags & SVf_BREAK)) {         \
 227             SvARENA_CHAIN_SET(p, PL_sv_root);   \
 228             PL_sv_root = (p);                           \
 229         }                                               \
 230         --PL_sv_count;                                  \
 231     } STMT_END
 232
 233 #define uproot_SV(p) \
 234     STMT_START {                                        \
 235         (p) = PL_sv_root;                               \
 236         PL_sv_root = (SV*)SvARENA_CHAIN(p);             \
 237         ++PL_sv_count;                                  \
 238     } STMT_END
 239
 240
 241 /* make some more SVs by adding another arena */
 242
 243 STATIC SV*
 244 S_more_sv(pTHX)
 245 {
 246     dVAR;
 247     SV* sv;
 248
 249     if (PL_nice_chunk) {
 250         sv_add_arena(PL_nice_chunk, PL_nice_chunk_size, 0);
 251         PL_nice_chunk = NULL;
 252         PL_nice_chunk_size = 0;
 253     }
 254     else {
 255         char *chunk;                /* must use New here to match call to */
 256         Newx(chunk,PERL_ARENA_SIZE,char);  /* Safefree() in sv_free_arenas() */
 257         sv_add_arena(chunk, PERL_ARENA_SIZE, 0);
 258     }
 259     uproot_SV(sv);
 260     return sv;
 261 }
 262
 263 /* new_SV(): return a new, empty SV head */
 264
 265 #ifdef DEBUG_LEAKING_SCALARS
 266 /* provide a real function for a debugger to play with */
 267 STATIC SV*
 268 S_new_SV(pTHX_ const char *file, int line, const char *func)
 269 {
 270     SV* sv;
 271
 272     if (PL_sv_root)
 273         uproot_SV(sv);
 274     else
 275         sv = S_more_sv(aTHX);
 276     SvANY(sv) = 0;
 277     SvREFCNT(sv) = 1;
 278     SvFLAGS(sv) = 0;
 279     sv->sv_debug_optype = PL_op ? PL_op->op_type : 0;
 280     sv->sv_debug_line = (U16) (PL_parser && PL_parser->copline != NOLINE
 281                 ? PL_parser->copline
 282                 :  PL_curcop
 283                     ? CopLINE(PL_curcop)
 284                     : 0
 285             );
 286     sv->sv_debug_inpad = 0;
 287     sv->sv_debug_cloned = 0;
 288     sv->sv_debug_file = PL_curcop ? savepv(CopFILE(PL_curcop)): NULL;
 289
 290     sv->sv_debug_serial = PL_sv_serial++;
 291
 292     MEM_LOG_NEW_SV(sv, file, line, func);
 293     DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) new_SV (from %s:%d [%s])\n",
 294             PTR2UV(sv), (long)sv->sv_debug_serial, file, line, func));
 295
 296     return sv;
 297 }
 298 #  define new_SV(p) (p)=S_new_SV(aTHX_ __FILE__, __LINE__, FUNCTION__)
 299
 300 #else
 301 #  define new_SV(p) \
 302     STMT_START {                                        \
 303         if (PL_sv_root)                                 \
 304             uproot_SV(p);                               \
 305         else                                            \
 306             (p) = S_more_sv(aTHX);                      \
 307         SvANY(p) = 0;                                   \
 308         SvREFCNT(p) = 1;                                \
 309         SvFLAGS(p) = 0;                                 \
 310         MEM_LOG_NEW_SV(p, __FILE__, __LINE__, FUNCTION__);  \
 311     } STMT_END
 312 #endif
 313
 314
 315 /* del_SV(): return an empty SV head to the free list */
 316
 317 #ifdef DEBUGGING
 318
 319 #define del_SV(p) \
 320     STMT_START {                                        \
 321         if (DEBUG_D_TEST)                               \
 322             del_sv(p);                                  \
 323         else                                            \
 324             plant_SV(p);                                \
 325     } STMT_END
 326
 327 STATIC void
 328 S_del_sv(pTHX_ SV *p)
 329 {
 330     dVAR;
 331
 332     PERL_ARGS_ASSERT_DEL_SV;
 333
 334     if (DEBUG_D_TEST) {
 335         SV* sva;
 336         bool ok = 0;
 337         for (sva = PL_sv_arenaroot; sva; sva = (SV *) SvANY(sva)) {
 338             const SV * const sv = sva + 1;
 339             const SV * const svend = &sva[SvREFCNT(sva)];
 340             if (p >= sv && p < svend) {
 341                 ok = 1;
 342                 break;
 343             }
 344         }
 345         if (!ok) {
 346             if (ckWARN_d(WARN_INTERNAL))
 347                 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
 348                             "Attempt to free non-arena SV: 0x%"UVxf
 349                             pTHX__FORMAT, PTR2UV(p) pTHX__VALUE);
 350             return;
 351         }
 352     }
 353     plant_SV(p);
 354 }
 355
 356 #else /* ! DEBUGGING */
 357
 358 #define del_SV(p)   plant_SV(p)
 359
 360 #endif /* DEBUGGING */
 361
 362
 363 /*
 364 =head1 SV Manipulation Functions
 365
 366 =for apidoc sv_add_arena
 367
 368 Given a chunk of memory, link it to the head of the list of arenas,
 369 and split it into a list of free SVs.
 370
 371 =cut
 372 */
 373
 374 void
 375 Perl_sv_add_arena(pTHX_ char *const ptr, const U32 size, const U32 flags)
 376 {
 377     dVAR;
 378     SV* const sva = (SV*)ptr;
 379     register SV* sv;
 380     register SV* svend;
 381
 382     PERL_ARGS_ASSERT_SV_ADD_ARENA;
 383
 384     /* The first SV in an arena isn't an SV. */
 385     SvANY(sva) = (void *) PL_sv_arenaroot;              /* ptr to next arena */
 386     SvREFCNT(sva) = size / sizeof(SV);          /* number of SV slots */
 387     SvFLAGS(sva) = flags;                       /* FAKE if not to be freed */
 388
 389     PL_sv_arenaroot = sva;
 390     PL_sv_root = sva + 1;
 391
 392     svend = &sva[SvREFCNT(sva) - 1];
 393     sv = sva + 1;
 394     while (sv < svend) {
 395         SvARENA_CHAIN_SET(sv, (sv + 1));
 396 #ifdef DEBUGGING
 397         SvREFCNT(sv) = 0;
 398 #endif
 399         /* Must always set typemask because it's always checked in on cleanup
 400            when the arenas are walked looking for objects.  */
 401         SvFLAGS(sv) = SVTYPEMASK;
 402         sv++;
 403     }
 404     SvARENA_CHAIN_SET(sv, 0);
 405 #ifdef DEBUGGING
 406     SvREFCNT(sv) = 0;
 407 #endif
 408     SvFLAGS(sv) = SVTYPEMASK;
 409 }
 410
 411 /* visit(): call the named function for each non-free SV in the arenas
 412  * whose flags field matches the flags/mask args. */
 413
 414 STATIC I32
 415 S_visit(pTHX_ SVFUNC_t f, const U32 flags, const U32 mask)
 416 {
 417     dVAR;
 418     SV* sva;
 419     I32 visited = 0;
 420
 421     PERL_ARGS_ASSERT_VISIT;
 422
 423     for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) {
 424         register const SV * const svend = &sva[SvREFCNT(sva)];
 425         register SV* sv;
 426         for (sv = sva + 1; sv < svend; ++sv) {
 427             if (SvTYPE(sv) != SVTYPEMASK
 428                     && (sv->sv_flags & mask) == flags
 429                     && SvREFCNT(sv))
 430             {
 431                 (FCALL)(aTHX_ sv);
 432                 ++visited;
 433             }
 434         }
 435     }
 436     return visited;
 437 }
 438
 439 #ifdef DEBUGGING
 440
 441 /* called by sv_report_used() for each live SV */
 442
 443 static void
 444 do_report_used(pTHX_ SV *const sv)
 445 {
 446     if (SvTYPE(sv) != SVTYPEMASK) {
 447         PerlIO_printf(Perl_debug_log, "****\n");
 448         sv_dump(sv);
 449     }
 450 }
 451 #endif
 452
 453 /*
 454 =for apidoc sv_report_used
 455
 456 Dump the contents of all SVs not yet freed. (Debugging aid).
 457
 458 =cut
 459 */
 460
 461 void
 462 Perl_sv_report_used(pTHX)
 463 {
 464 #ifdef DEBUGGING
 465     visit(do_report_used, 0, 0);
 466 #else
 467     PERL_UNUSED_CONTEXT;
 468 #endif
 469 }
 470
 471 /* called by sv_clean_objs() for each live SV */
 472
 473 static void
 474 do_clean_objs(pTHX_ SV *const ref)
 475 {
 476     dVAR;
 477     assert (SvROK(ref));
 478     {
 479         SV * const target = SvRV(ref);
 480         if (SvOBJECT(target)) {
 481             DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(ref)));
 482             if (SvWEAKREF(ref)) {
 483                 sv_del_backref(target, ref);
 484                 SvWEAKREF_off(ref);
 485                 SvRV_set(ref, NULL);
 486             } else {
 487                 SvROK_off(ref);
 488                 SvRV_set(ref, NULL);
 489                 SvREFCNT_dec(target);
 490             }
 491         }
 492     }
 493
 494     /* XXX Might want to check arrays, etc. */
 495 }
 496
 497 /* called by sv_clean_objs() for each live SV */
 498
 499 #ifndef DISABLE_DESTRUCTOR_KLUDGE
 500 static void
 501 do_clean_named_objs(pTHX_ SV *const sv)
 502 {
 503     dVAR;
 504     assert(SvTYPE(sv) == SVt_PVGV);
 505     assert(isGV_with_GP(sv));
 506     if (GvGP(sv)) {
 507         if ((
 508 #ifdef PERL_DONT_CREATE_GVSV
 509              GvSV(sv) &&
 510 #endif
 511              SvOBJECT(GvSV(sv))) ||
 512              (GvAV(sv) && SvOBJECT(GvAV(sv))) ||
 513              (GvHV(sv) && SvOBJECT(GvHV(sv))) ||
 514              /* In certain rare cases GvIOp(sv) can be NULL, which would make SvOBJECT(GvIO(sv)) dereference NULL. */
 515              (GvIO(sv) ? (SvFLAGS(GvIOp(sv)) & SVs_OBJECT) : 0) ||
 516              (GvCV(sv) && SvOBJECT(GvCV(sv))) )
 517         {
 518             DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv)));
 519             SvFLAGS(sv) |= SVf_BREAK;
 520             SvREFCNT_dec(sv);
 521         }
 522     }
 523 }
 524 #endif
 525
 526 /*
 527 =for apidoc sv_clean_objs
 528
 529 Attempt to destroy all objects not yet freed
 530
 531 =cut
 532 */
 533
 534 void
 535 Perl_sv_clean_objs(pTHX)
 536 {
 537     dVAR;
 538     PL_in_clean_objs = TRUE;
 539     visit(do_clean_objs, SVf_ROK, SVf_ROK);
 540 #ifndef DISABLE_DESTRUCTOR_KLUDGE
 541     /* some barnacles may yet remain, clinging to typeglobs */
 542     visit(do_clean_named_objs, SVt_PVGV|SVpgv_GP, SVTYPEMASK|SVp_POK|SVpgv_GP);
 543 #endif
 544     PL_in_clean_objs = FALSE;
 545 }
 546
 547 /* called by sv_clean_all() for each live SV */
 548
 549 static void
 550 do_clean_all(pTHX_ SV *const sv)
 551 {
 552     dVAR;
 553     if (sv == (SV*) PL_fdpid || sv == (SV *)PL_strtab) {
 554         /* don't clean pid table and strtab */
 555         return;
 556     }
 557     DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) ));
 558     SvFLAGS(sv) |= SVf_BREAK;
 559     SvREFCNT_dec(sv);
 560 }
 561
 562 /*
 563 =for apidoc sv_clean_all
 564
 565 Decrement the refcnt of each remaining SV, possibly triggering a
 566 cleanup. This function may have to be called multiple times to free
 567 SVs which are in complex self-referential hierarchies.
 568
 569 =cut
 570 */
 571
 572 I32
 573 Perl_sv_clean_all(pTHX)
 574 {
 575     dVAR;
 576     I32 cleaned;
 577     PL_in_clean_all = TRUE;
 578     cleaned = visit(do_clean_all, 0,0);
 579     PL_in_clean_all = FALSE;
 580     return cleaned;
 581 }
 582
 583 /*
 584   ARENASETS: a meta-arena implementation which separates arena-info
 585   into struct arena_set, which contains an array of struct
 586   arena_descs, each holding info for a single arena.  By separating
 587   the meta-info from the arena, we recover the 1st slot, formerly
 588   borrowed for list management.  The arena_set is about the size of an
 589   arena, avoiding the needless malloc overhead of a naive linked-list.
 590
 591   The cost is 1 arena-set malloc per ~320 arena-mallocs, + the unused
 592   memory in the last arena-set (1/2 on average).  In trade, we get
 593   back the 1st slot in each arena (ie 1.7% of a CV-arena, less for
 594   smaller types).  The recovery of the wasted space allows use of
 595   small arenas for large, rare body types, by changing array* fields
 596   in body_details_by_type[] below.
 597 */
 598 struct arena_desc {
 599     char       *arena;          /* the raw storage, allocated aligned */
 600     size_t      size;           /* its size ~4k typ */
 601     U32         misc;           /* type, and in future other things. */
 602 };
 603
 604 struct arena_set;
 605
 606 /* Get the maximum number of elements in set[] such that struct arena_set
 607    will fit within PERL_ARENA_SIZE, which is probably just under 4K, and
 608    therefore likely to be 1 aligned memory page.  */
 609
 610 #define ARENAS_PER_SET  ((PERL_ARENA_SIZE - sizeof(struct arena_set*) \
 611                           - 2 * sizeof(int)) / sizeof (struct arena_desc))
 612
 613 struct arena_set {
 614     struct arena_set* next;
 615     unsigned int   set_size;    /* ie ARENAS_PER_SET */
 616     unsigned int   curr;        /* index of next available arena-desc */
 617     struct arena_desc set[ARENAS_PER_SET];
 618 };
 619
 620 /*
 621 =for apidoc sv_free_arenas
 622
 623 Deallocate the memory used by all arenas. Note that all the individual SV
 624 heads and bodies within the arenas must already have been freed.
 625
 626 =cut
 627 */
 628 void
 629 Perl_sv_free_arenas(pTHX)
 630 {
 631     dVAR;
 632     SV* sva;
 633     SV* svanext;
 634     unsigned int i;
 635
 636     /* Free arenas here, but be careful about fake ones.  (We assume
 637        contiguity of the fake ones with the corresponding real ones.) */
 638
 639     for (sva = PL_sv_arenaroot; sva; sva = svanext) {
 640         svanext = (SV*) SvANY(sva);
 641         while (svanext && SvFAKE(svanext))
 642             svanext = (SV*) SvANY(svanext);
 643
 644         if (!SvFAKE(sva))
 645             Safefree(sva);
 646     }
 647
 648     {
 649         struct arena_set *aroot = (struct arena_set*) PL_body_arenas;
 650
 651         while (aroot) {
 652             struct arena_set *current = aroot;
 653             i = aroot->curr;
 654             while (i--) {
 655                 assert(aroot->set[i].arena);
 656                 Safefree(aroot->set[i].arena);
 657             }
 658             aroot = aroot->next;
 659             Safefree(current);
 660         }
 661     }
 662     PL_body_arenas = 0;
 663
 664     i = PERL_ARENA_ROOTS_SIZE;
 665     while (i--)
 666         PL_body_roots[i] = 0;
 667
 668     Safefree(PL_nice_chunk);
 669     PL_nice_chunk = NULL;
 670     PL_nice_chunk_size = 0;
 671     PL_sv_arenaroot = 0;
 672     PL_sv_root = 0;
 673 }
 674
 675 /*
 676   Here are mid-level routines that manage the allocation of bodies out
 677   of the various arenas.  There are 5 kinds of arenas:
 678
 679   1. SV-head arenas, which are discussed and handled above
 680   2. regular body arenas
 681   3. arenas for reduced-size bodies
 682   4. Hash-Entry arenas
 683   5. pte arenas (thread related)
 684
 685   Arena types 2 & 3 are chained by body-type off an array of
 686   arena-root pointers, which is indexed by svtype.  Some of the
 687   larger/less used body types are malloced singly, since a large
 688   unused block of them is wasteful.  Also, several svtypes dont have
 689   bodies; the data fits into the sv-head itself.  The arena-root
 690   pointer thus has a few unused root-pointers (which may be hijacked
 691   later for arena types 4,5)
 692
 693   3 differs from 2 as an optimization; some body types have several
 694   unused fields in the front of the structure (which are kept in-place
 695   for consistency).  These bodies can be allocated in smaller chunks,
 696   because the leading fields arent accessed.  Pointers to such bodies
 697   are decremented to point at the unused 'ghost' memory, knowing that
 698   the pointers are used with offsets to the real memory.
 699
 700   HE, HEK arenas are managed separately, with separate code, but may
 701   be merge-able later..
 702
 703   PTE arenas are not sv-bodies, but they share these mid-level
 704   mechanics, so are considered here.  The new mid-level mechanics rely
 705   on the sv_type of the body being allocated, so we just reserve one
 706   of the unused body-slots for PTEs, then use it in those (2) PTE
 707   contexts below (line ~10k)
 708 */
 709
 710 /* get_arena(size): this creates custom-sized arenas
 711    TBD: export properly for hv.c: S_more_he().
 712 */
 713 void*
 714 Perl_get_arena(pTHX_ const size_t arena_size, const U32 misc)
 715 {
 716     dVAR;
 717     struct arena_desc* adesc;
 718     struct arena_set *aroot = (struct arena_set*) PL_body_arenas;
 719     unsigned int curr;
 720
 721     /* shouldnt need this
 722     if (!arena_size)    arena_size = PERL_ARENA_SIZE;
 723     */
 724
 725     /* may need new arena-set to hold new arena */
 726     if (!aroot || aroot->curr >= aroot->set_size) {
 727         struct arena_set *newroot;
 728         Newxz(newroot, 1, struct arena_set);
 729         newroot->set_size = ARENAS_PER_SET;
 730         newroot->next = aroot;
 731         aroot = newroot;
 732         PL_body_arenas = (void *) newroot;
 733         DEBUG_m(PerlIO_printf(Perl_debug_log, "new arenaset %p\n", (void*)aroot));
 734     }
 735
 736     /* ok, now have arena-set with at least 1 empty/available arena-desc */
 737     curr = aroot->curr++;
 738     adesc = &(aroot->set[curr]);
 739     assert(!adesc->arena);
 740
 741     Newx(adesc->arena, arena_size, char);
 742     adesc->size = arena_size;
 743     adesc->misc = misc;
 744     DEBUG_m(PerlIO_printf(Perl_debug_log, "arena %d added: %p size %"UVuf"\n",
 745                           curr, (void*)adesc->arena, (UV)arena_size));
 746
 747     return adesc->arena;
 748 }
 749
 750
 751 /* return a thing to the free list */
 752
 753 #define del_body(thing, root)                   \
 754     STMT_START {                                \
 755         void ** const thing_copy = (void **)thing;\
 756         *thing_copy = *root;                    \
 757         *root = (void*)thing_copy;              \
 758     } STMT_END
 759
 760 /*
 761
 762 =head1 SV-Body Allocation
 763
 764 Allocation of SV-bodies is similar to SV-heads, differing as follows;
 765 the allocation mechanism is used for many body types, so is somewhat
 766 more complicated, it uses arena-sets, and has no need for still-live
 767 SV detection.
 768
 769 At the outermost level, (new|del)_X*V macros return bodies of the
 770 appropriate type.  These macros call either (new|del)_body_type or
 771 (new|del)_body_allocated macro pairs, depending on specifics of the
 772 type.  Most body types use the former pair, the latter pair is used to
 773 allocate body types with "ghost fields".
 774
 775 "ghost fields" are fields that are unused in certain types, and
 776 consequently dont need to actually exist.  They are declared because
 777 they're part of a "base type", which allows use of functions as
 778 methods.  The simplest examples are AVs and HVs, 2 aggregate types
 779 which don't use the fields which support SCALAR semantics.
 780
 781 For these types, the arenas are carved up into *_allocated size
 782 chunks, we thus avoid wasted memory for those unaccessed members.
 783 When bodies are allocated, we adjust the pointer back in memory by the
 784 size of the bit not allocated, so it's as if we allocated the full
 785 structure.  (But things will all go boom if you write to the part that
 786 is "not there", because you'll be overwriting the last members of the
 787 preceding structure in memory.)
 788
 789 We calculate the correction using the STRUCT_OFFSET macro. For
 790 example, if xpv_allocated is the same structure as XPV then the two
 791 OFFSETs sum to zero, and the pointer is unchanged. If the allocated
 792 structure is smaller (no initial NV actually allocated) then the net
 793 effect is to subtract the size of the NV from the pointer, to return a
 794 new pointer as if an initial NV were actually allocated.
 795
 796 This is the same trick as was used for NV and IV bodies. Ironically it
 797 doesn't need to be used for NV bodies any more, because NV is now at
 798 the start of the structure. IV bodies don't need it either, because
 799 they are no longer allocated.
 800
 801 In turn, the new_body_* allocators call S_new_body(), which invokes
 802 new_body_inline macro, which takes a lock, and takes a body off the
 803 linked list at PL_body_roots[sv_type], calling S_more_bodies() if
 804 necessary to refresh an empty list.  Then the lock is released, and
 805 the body is returned.
 806
 807 S_more_bodies calls get_arena(), and carves it up into an array of N
 808 bodies, which it strings into a linked list.  It looks up arena-size
 809 and body-size from the body_details table described below, thus
 810 supporting the multiple body-types.
 811
 812 If PURIFY is defined, or PERL_ARENA_SIZE=0, arenas are not used, and
 813 the (new|del)_X*V macros are mapped directly to malloc/free.
 814
 815 */
 816
 817 /*
 818
 819 For each sv-type, struct body_details bodies_by_type[] carries
 820 parameters which control these aspects of SV handling:
 821
 822 Arena_size determines whether arenas are used for this body type, and if
 823 so, how big they are.  PURIFY or PERL_ARENA_SIZE=0 set this field to
 824 zero, forcing individual mallocs and frees.
 825
 826 Body_size determines how big a body is, and therefore how many fit into
 827 each arena.  Offset carries the body-pointer adjustment needed for
 828 *_allocated body types, and is used in *_allocated macros.
 829
 830 But its main purpose is to parameterize info needed in
 831 Perl_sv_upgrade().  The info here dramatically simplifies the function
 832 vs the implementation in 5.8.7, making it table-driven.  All fields
 833 are used for this, except for arena_size.
 834
 835 For the sv-types that have no bodies, arenas are not used, so those
 836 PL_body_roots[sv_type] are unused, and can be overloaded.  In
 837 something of a special case, SVt_NULL is borrowed for HE arenas;
 838 PL_body_roots[HE_SVSLOT=SVt_NULL] is filled by S_more_he, but the
 839 bodies_by_type[SVt_NULL] slot is not used, as the table is not
 840 available in hv.c.
 841
 842 PTEs also use arenas, but are never seen in Perl_sv_upgrade. Nonetheless,
 843 they get their own slot in bodies_by_type[PTE_SVSLOT =SVt_IV], so they can
 844 just use the same allocation semantics.  At first, PTEs were also
 845 overloaded to a non-body sv-type, but this yielded hard-to-find malloc
 846 bugs, so was simplified by claiming a new slot.  This choice has no
 847 consequence at this time.
 848
 849 */
 850
 851 struct body_details {
 852     U8 body_size;       /* Size to allocate  */
 853     U8 copy;            /* Size of structure to copy (may be shorter)  */
 854     U8 offset;
 855     unsigned int type : 4;          /* We have space for a sanity check.  */
 856     unsigned int cant_upgrade : 1;  /* Cannot upgrade this type */
 857     unsigned int zero_nv : 1;       /* zero the NV when upgrading from this */
 858     unsigned int arena : 1;         /* Allocated from an arena */
 859     size_t arena_size;              /* Size of arena to allocate */
 860 };
 861
 862 #define HADNV FALSE
 863 #define NONV TRUE
 864
 865
 866 #ifdef PURIFY
 867 /* With -DPURFIY we allocate everything directly, and don't use arenas.
 868    This seems a rather elegant way to simplify some of the code below.  */
 869 #define HASARENA FALSE
 870 #else
 871 #define HASARENA TRUE
 872 #endif
 873 #define NOARENA FALSE
 874
 875 /* Size the arenas to exactly fit a given number of bodies.  A count
 876    of 0 fits the max number bodies into a PERL_ARENA_SIZE.block,
 877    simplifying the default.  If count > 0, the arena is sized to fit
 878    only that many bodies, allowing arenas to be used for large, rare
 879    bodies (XPVFM, XPVIO) without undue waste.  The arena size is
 880    limited by PERL_ARENA_SIZE, so we can safely oversize the
 881    declarations.
 882  */
 883 #define FIT_ARENA0(body_size)                           \
 884     ((size_t)(PERL_ARENA_SIZE / body_size) * body_size)
 885 #define FIT_ARENAn(count,body_size)                     \
 886     ( count * body_size <= PERL_ARENA_SIZE)             \
 887     ? count * body_size                                 \
 888     : FIT_ARENA0 (body_size)
 889 #define FIT_ARENA(count,body_size)                      \
 890     count                                               \
 891     ? FIT_ARENAn (count, body_size)                     \
 892     : FIT_ARENA0 (body_size)
 893
 894 /* A macro to work out the offset needed to subtract from a pointer to (say)
 895
 896 typedef struct {
 897     STRLEN      xpv_cur;
 898     STRLEN      xpv_len;
 899 } xpv_allocated;
 900
 901 to make its members accessible via a pointer to (say)
 902
 903 struct xpv {
 904     NV          xnv_nv;
 905     STRLEN      xpv_cur;
 906     STRLEN      xpv_len;
 907 };
 908
 909 */
 910
 911 #define relative_STRUCT_OFFSET(longer, shorter, member) \
 912     (STRUCT_OFFSET(shorter, member) - STRUCT_OFFSET(longer, member))
 913
 914 /* Calculate the length to copy. Specifically work out the length less any
 915    final padding the compiler needed to add.  See the comment in sv_upgrade
 916    for why copying the padding proved to be a bug.  */
 917
 918 #define copy_length(type, last_member) \
 919         STRUCT_OFFSET(type, last_member) \
 920         + sizeof (((type*)SvANY((SV*)0))->last_member)
 921
 922 static const struct body_details bodies_by_type[] = {
 923     { sizeof(HE), 0, 0, SVt_NULL,
 924       FALSE, NONV, NOARENA, FIT_ARENA(0, sizeof(HE)) },
 925
 926     /* The bind placeholder pretends to be an RV for now.
 927        Also it's marked as "can't upgrade" to stop anyone using it before it's
 928        implemented.  */
 929     { 0, 0, 0, SVt_BIND, TRUE, NONV, NOARENA, 0 },
 930
 931     /* IVs are in the head, so the allocation size is 0.
 932        However, the slot is overloaded for PTEs.  */
 933     { sizeof(struct ptr_tbl_ent), /* This is used for PTEs.  */
 934       sizeof(IV), /* This is used to copy out the IV body.  */
 935       STRUCT_OFFSET(XPVIV, xiv_iv), SVt_IV, FALSE, NONV,
 936       NOARENA /* IVS don't need an arena  */,
 937       /* But PTEs need to know the size of their arena  */
 938       FIT_ARENA(0, sizeof(struct ptr_tbl_ent))
 939     },
 940
 941     /* 8 bytes on most ILP32 with IEEE doubles */
 942     { sizeof(NV), sizeof(NV), 0, SVt_NV, FALSE, HADNV, HASARENA,
 943       FIT_ARENA(0, sizeof(NV)) },
 944
 945     /* 8 bytes on most ILP32 with IEEE doubles */
 946     { sizeof(xpv_allocated),
 947       copy_length(XPV, xpv_len)
 948       - relative_STRUCT_OFFSET(xpv_allocated, XPV, xpv_cur),
 949       + relative_STRUCT_OFFSET(xpv_allocated, XPV, xpv_cur),
 950       SVt_PV, FALSE, NONV, HASARENA, FIT_ARENA(0, sizeof(xpv_allocated)) },
 951
 952     /* 12 */
 953     { sizeof(xpviv_allocated),
 954       copy_length(XPVIV, xiv_u)
 955       - relative_STRUCT_OFFSET(xpviv_allocated, XPVIV, xpv_cur),
 956       + relative_STRUCT_OFFSET(xpviv_allocated, XPVIV, xpv_cur),
 957       SVt_PVIV, FALSE, NONV, HASARENA, FIT_ARENA(0, sizeof(xpviv_allocated)) },
 958
 959     /* 20 */
 960     { sizeof(XPVNV), copy_length(XPVNV, xiv_u), 0, SVt_PVNV, FALSE, HADNV,
 961       HASARENA, FIT_ARENA(0, sizeof(XPVNV)) },
 962
 963     /* 28 */
 964     { sizeof(XPVMG), copy_length(XPVMG, xmg_stash), 0, SVt_PVMG, FALSE, HADNV,
 965       HASARENA, FIT_ARENA(0, sizeof(XPVMG)) },
 966
 967     /* something big */
 968     { sizeof(struct regexp_allocated), sizeof(struct regexp_allocated),
 969       + relative_STRUCT_OFFSET(struct regexp_allocated, regexp, xpv_cur),
 970       SVt_REGEXP, FALSE, NONV, HASARENA,
 971       FIT_ARENA(0, sizeof(struct regexp_allocated))
 972     },
 973
 974     /* 48 */
 975     { sizeof(XPVGV), sizeof(XPVGV), 0, SVt_PVGV, TRUE, HADNV,
 976       HASARENA, FIT_ARENA(0, sizeof(XPVGV)) },
 977
 978     /* 64 */
 979     { sizeof(XPVLV), sizeof(XPVLV), 0, SVt_PVLV, TRUE, HADNV,
 980       HASARENA, FIT_ARENA(0, sizeof(XPVLV)) },
 981
 982     { sizeof(xpvav_allocated),
 983       copy_length(XPVAV, xmg_stash)
 984       - relative_STRUCT_OFFSET(xpvav_allocated, XPVAV, xav_fill),
 985       + relative_STRUCT_OFFSET(xpvav_allocated, XPVAV, xav_fill),
 986       SVt_PVAV, TRUE, NONV, HASARENA, FIT_ARENA(0, sizeof(xpvav_allocated)) },
 987
 988     { sizeof(xpvhv_allocated),
 989       copy_length(XPVHV, xmg_stash)
 990       - relative_STRUCT_OFFSET(xpvhv_allocated, XPVHV, xhv_fill),
 991       + relative_STRUCT_OFFSET(xpvhv_allocated, XPVHV, xhv_fill),
 992       SVt_PVHV, TRUE, NONV, HASARENA, FIT_ARENA(0, sizeof(xpvhv_allocated)) },
 993
 994     /* 56 */
 995     { sizeof(xpvcv_allocated), sizeof(xpvcv_allocated),
 996       + relative_STRUCT_OFFSET(xpvcv_allocated, XPVCV, xpv_cur),
 997       SVt_PVCV, TRUE, NONV, HASARENA, FIT_ARENA(0, sizeof(xpvcv_allocated)) },
 998
 999     { sizeof(xpvfm_allocated), sizeof(xpvfm_allocated),
1000       + relative_STRUCT_OFFSET(xpvfm_allocated, XPVFM, xpv_cur),
1001       SVt_PVFM, TRUE, NONV, NOARENA, FIT_ARENA(20, sizeof(xpvfm_allocated)) },
1002
1003     /* XPVIO is 84 bytes, fits 48x */
1004     { sizeof(xpvio_allocated), sizeof(xpvio_allocated),
1005       + relative_STRUCT_OFFSET(xpvio_allocated, XPVIO, xpv_cur),
1006       SVt_PVIO, TRUE, NONV, HASARENA, FIT_ARENA(24, sizeof(xpvio_allocated)) },
1007 };
1008
1009 #define new_body_type(sv_type)          \
1010     (void *)((char *)S_new_body(aTHX_ sv_type))
1011
1012 #define del_body_type(p, sv_type)       \
1013     del_body(p, &PL_body_roots[sv_type])
1014
1015
1016 #define new_body_allocated(sv_type)             \
1017     (void *)((char *)S_new_body(aTHX_ sv_type)  \
1018              - bodies_by_type[sv_type].offset)
1019
1020 #define del_body_allocated(p, sv_type)          \
1021     del_body(p + bodies_by_type[sv_type].offset, &PL_body_roots[sv_type])
1022
1023
1024 #define my_safemalloc(s)        (void*)safemalloc(s)
1025 #define my_safecalloc(s)        (void*)safecalloc(s, 1)
1026 #define my_safefree(p)  safefree((char*)p)
1027
1028 #ifdef PURIFY
1029
1030 #define new_XNV()       my_safemalloc(sizeof(XPVNV))
1031 #define del_XNV(p)      my_safefree(p)
1032
1033 #define new_XPVNV()     my_safemalloc(sizeof(XPVNV))
1034 #define del_XPVNV(p)    my_safefree(p)
1035
1036 #define new_XPVAV()     my_safemalloc(sizeof(XPVAV))
1037 #define del_XPVAV(p)    my_safefree(p)
1038
1039 #define new_XPVHV()     my_safemalloc(sizeof(XPVHV))
1040 #define del_XPVHV(p)    my_safefree(p)
1041
1042 #define new_XPVMG()     my_safemalloc(sizeof(XPVMG))
1043 #define del_XPVMG(p)    my_safefree(p)
1044
1045 #define new_XPVGV()     my_safemalloc(sizeof(XPVGV))
1046 #define del_XPVGV(p)    my_safefree(p)
1047
1048 #else /* !PURIFY */
1049
1050 #define new_XNV()       new_body_type(SVt_NV)
1051 #define del_XNV(p)      del_body_type(p, SVt_NV)
1052
1053 #define new_XPVNV()     new_body_type(SVt_PVNV)
1054 #define del_XPVNV(p)    del_body_type(p, SVt_PVNV)
1055
1056 #define new_XPVAV()     new_body_allocated(SVt_PVAV)
1057 #define del_XPVAV(p)    del_body_allocated(p, SVt_PVAV)
1058
1059 #define new_XPVHV()     new_body_allocated(SVt_PVHV)
1060 #define del_XPVHV(p)    del_body_allocated(p, SVt_PVHV)
1061
1062 #define new_XPVMG()     new_body_type(SVt_PVMG)
1063 #define del_XPVMG(p)    del_body_type(p, SVt_PVMG)
1064
1065 #define new_XPVGV()     new_body_type(SVt_PVGV)
1066 #define del_XPVGV(p)    del_body_type(p, SVt_PVGV)
1067
1068 #endif /* PURIFY */
1069
1070 /* no arena for you! */
1071
1072 #define new_NOARENA(details) \
1073         my_safemalloc((details)->body_size + (details)->offset)
1074 #define new_NOARENAZ(details) \
1075         my_safecalloc((details)->body_size + (details)->offset)
1076
1077 STATIC void *
1078 S_more_bodies (pTHX_ const svtype sv_type)
1079 {
1080     dVAR;
1081     void ** const root = &PL_body_roots[sv_type];
1082     const struct body_details * const bdp = &bodies_by_type[sv_type];
1083     const size_t body_size = bdp->body_size;
1084     char *start;
1085     const char *end;
1086     const size_t arena_size = Perl_malloc_good_size(bdp->arena_size);
1087 #if defined(DEBUGGING) && !defined(PERL_GLOBAL_STRUCT_PRIVATE)
1088     static bool done_sanity_check;
1089
1090     /* PERL_GLOBAL_STRUCT_PRIVATE cannot coexist with global
1091      * variables like done_sanity_check. */
1092     if (!done_sanity_check) {
1093         unsigned int i = SVt_LAST;
1094
1095         done_sanity_check = TRUE;
1096
1097         while (i--)
1098             assert (bodies_by_type[i].type == i);
1099     }
1100 #endif
1101
1102     assert(bdp->arena_size);
1103
1104     start = (char*) Perl_get_arena(aTHX_ arena_size, sv_type);
1105
1106     end = start + arena_size - 2 * body_size;
1107
1108     /* computed count doesnt reflect the 1st slot reservation */
1109 #if defined(MYMALLOC) || defined(HAS_MALLOC_GOOD_SIZE)
1110     DEBUG_m(PerlIO_printf(Perl_debug_log,
1111                           "arena %p end %p arena-size %d (from %d) type %d "
1112                           "size %d ct %d\n",
1113                           (void*)start, (void*)end, (int)arena_size,
1114                           (int)bdp->arena_size, sv_type, (int)body_size,
1115                           (int)arena_size / (int)body_size));
1116 #else
1117     DEBUG_m(PerlIO_printf(Perl_debug_log,
1118                           "arena %p end %p arena-size %d type %d size %d ct %d\n",
1119                           (void*)start, (void*)end,
1120                           (int)bdp->arena_size, sv_type, (int)body_size,
1121                           (int)bdp->arena_size / (int)body_size));
1122 #endif
1123     *root = (void *)start;
1124
1125     while (start <= end) {
1126         char * const next = start + body_size;
1127         *(void**) start = (void *)next;
1128         start = next;
1129     }
1130     *(void **)start = 0;
1131
1132     return *root;
1133 }
1134
1135 /* grab a new thing from the free list, allocating more if necessary.
1136    The inline version is used for speed in hot routines, and the
1137    function using it serves the rest (unless PURIFY).
1138 */
1139 #define new_body_inline(xpv, sv_type) \
1140     STMT_START { \
1141         void ** const r3wt = &PL_body_roots[sv_type]; \
1142         xpv = (PTR_TBL_ENT_t*) (*((void **)(r3wt))      \
1143           ? *((void **)(r3wt)) : more_bodies(sv_type)); \
1144         *(r3wt) = *(void**)(xpv); \
1145     } STMT_END
1146
1147 #ifndef PURIFY
1148
1149 STATIC void *
1150 S_new_body(pTHX_ const svtype sv_type)
1151 {
1152     dVAR;
1153     void *xpv;
1154     new_body_inline(xpv, sv_type);
1155     return xpv;
1156 }
1157
1158 #endif
1159
1160 static const struct body_details fake_rv =
1161     { 0, 0, 0, SVt_IV, FALSE, NONV, NOARENA, 0 };
1162
1163 /*
1164 =for apidoc sv_upgrade
1165
1166 Upgrade an SV to a more complex form.  Generally adds a new body type to the
1167 SV, then copies across as much information as possible from the old body.
1168 You generally want to use the C<SvUPGRADE> macro wrapper. See also C<svtype>.
1169
1170 =cut
1171 */
1172
1173 void
1174 Perl_sv_upgrade(pTHX_ register SV *const sv, svtype new_type)
1175 {
1176     dVAR;
1177     void*       old_body;
1178     void*       new_body;
1179     const svtype old_type = SvTYPE(sv);
1180     const struct body_details *new_type_details;
1181     const struct body_details *old_type_details
1182         = bodies_by_type + old_type;
1183     SV *referant = NULL;
1184
1185     PERL_ARGS_ASSERT_SV_UPGRADE;
1186
1187     if (new_type != SVt_PV && SvIsCOW(sv)) {
1188         sv_force_normal_flags(sv, 0);
1189     }
1190
1191     if (old_type == new_type)
1192         return;
1193
1194     old_body = SvANY(sv);
1195
1196     /* Copying structures onto other structures that have been neatly zeroed
1197        has a subtle gotcha. Consider XPVMG
1198
1199        +------+------+------+------+------+-------+-------+
1200        |     NV      | CUR  | LEN  |  IV  | MAGIC | STASH |
1201        +------+------+------+------+------+-------+-------+
1202        0      4      8     12     16     20      24      28
1203
1204        where NVs are aligned to 8 bytes, so that sizeof that structure is
1205        actually 32 bytes long, with 4 bytes of padding at the end:
1206
1207        +------+------+------+------+------+-------+-------+------+
1208        |     NV      | CUR  | LEN  |  IV  | MAGIC | STASH | ???  |
1209        +------+------+------+------+------+-------+-------+------+
1210        0      4      8     12     16     20      24      28     32
1211
1212        so what happens if you allocate memory for this structure:
1213
1214        +------+------+------+------+------+-------+-------+------+------+...
1215        |     NV      | CUR  | LEN  |  IV  | MAGIC | STASH |  GP  | NAME |
1216        +------+------+------+------+------+-------+-------+------+------+...
1217        0      4      8     12     16     20      24      28     32     36
1218
1219        zero it, then copy sizeof(XPVMG) bytes on top of it? Not quite what you
1220        expect, because you copy the area marked ??? onto GP. Now, ??? may have
1221        started out as zero once, but it's quite possible that it isn't. So now,
1222        rather than a nicely zeroed GP, you have it pointing somewhere random.
1223        Bugs ensue.
1224
1225        (In fact, GP ends up pointing at a previous GP structure, because the
1226        principle cause of the padding in XPVMG getting garbage is a copy of
1227        sizeof(XPVMG) bytes from a XPVGV structure in sv_unglob. Right now
1228        this happens to be moot because XPVGV has been re-ordered, with GP
1229        no longer after STASH)
1230
1231        So we are careful and work out the size of used parts of all the
1232        structures.  */
1233
1234     switch (old_type) {
1235     case SVt_NULL:
1236         break;
1237     case SVt_IV:
1238         if (SvROK(sv)) {
1239             referant = SvRV(sv);
1240             old_type_details = &fake_rv;
1241             if (new_type == SVt_NV)
1242                 new_type = SVt_PVNV;
1243         } else {
1244             if (new_type < SVt_PVIV) {
1245                 new_type = (new_type == SVt_NV)
1246                     ? SVt_PVNV : SVt_PVIV;
1247             }
1248         }
1249         break;
1250     case SVt_NV:
1251         if (new_type < SVt_PVNV) {
1252             new_type = SVt_PVNV;
1253         }
1254         break;
1255     case SVt_PV:
1256         assert(new_type > SVt_PV);
1257         assert(SVt_IV < SVt_PV);
1258         assert(SVt_NV < SVt_PV);
1259         break;
1260     case SVt_PVIV:
1261         break;
1262     case SVt_PVNV:
1263         break;
1264     case SVt_PVMG:
1265         /* Because the XPVMG of PL_mess_sv isn't allocated from the arena,
1266            there's no way that it can be safely upgraded, because perl.c
1267            expects to Safefree(SvANY(PL_mess_sv))  */
1268         assert(sv != PL_mess_sv);
1269         /* This flag bit is used to mean other things in other scalar types.
1270            Given that it only has meaning inside the pad, it shouldn't be set
1271            on anything that can get upgraded.  */
1272         assert(!SvPAD_TYPED(sv));
1273         break;
1274     default:
1275         if (old_type_details->cant_upgrade)
1276             Perl_croak(aTHX_ "Can't upgrade %s (%" UVuf ") to %" UVuf,
1277                        sv_reftype(sv, 0), (UV) old_type, (UV) new_type);
1278     }
1279
1280     if (old_type > new_type)
1281         Perl_croak(aTHX_ "sv_upgrade from type %d down to type %d",
1282                 (int)old_type, (int)new_type);
1283
1284     new_type_details = bodies_by_type + new_type;
1285
1286     SvFLAGS(sv) &= ~SVTYPEMASK;
1287     SvFLAGS(sv) |= new_type;
1288
1289     /* This can't happen, as SVt_NULL is <= all values of new_type, so one of
1290        the return statements above will have triggered.  */
1291     assert (new_type != SVt_NULL);
1292     switch (new_type) {
1293     case SVt_IV:
1294         assert(old_type == SVt_NULL);
1295         SvANY(sv) = (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
1296         SvIV_set(sv, 0);
1297         return;
1298     case SVt_NV:
1299         assert(old_type == SVt_NULL);
1300         SvANY(sv) = new_XNV();
1301         SvNV_set(sv, 0);
1302         return;
1303     case SVt_PVHV:
1304     case SVt_PVAV:
1305         assert(new_type_details->body_size);
1306
1307 #ifndef PURIFY
1308         assert(new_type_details->arena);
1309         assert(new_type_details->arena_size);
1310         /* This points to the start of the allocated area.  */
1311         new_body_inline(new_body, new_type);
1312         Zero(new_body, new_type_details->body_size, char);
1313         new_body = ((char *)new_body) - new_type_details->offset;
1314 #else
1315         /* We always allocated the full length item with PURIFY. To do this
1316            we fake things so that arena is false for all 16 types..  */
1317         new_body = new_NOARENAZ(new_type_details);
1318 #endif
1319         SvANY(sv) = new_body;
1320         if (new_type == SVt_PVAV) {
1321             AvMAX(sv)   = -1;
1322             AvFILLp(sv) = -1;
1323             AvREAL_only(sv);
1324             if (old_type_details->body_size) {
1325                 AvALLOC(sv) = 0;
1326             } else {
1327                 /* It will have been zeroed when the new body was allocated.
1328                    Lets not write to it, in case it confuses a write-back
1329                    cache.  */
1330             }
1331         } else {
1332             assert(!SvOK(sv));
1333             SvOK_off(sv);
1334 #ifndef NODEFAULT_SHAREKEYS
1335             HvSHAREKEYS_on(sv);         /* key-sharing on by default */
1336 #endif
1337             HvMAX(sv) = 7; /* (start with 8 buckets) */
1338             if (old_type_details->body_size) {
1339                 HvFILL(sv) = 0;
1340             } else {
1341                 /* It will have been zeroed when the new body was allocated.
1342                    Lets not write to it, in case it confuses a write-back
1343                    cache.  */
1344             }
1345         }
1346
1347         /* SVt_NULL isn't the only thing upgraded to AV or HV.
1348            The target created by newSVrv also is, and it can have magic.
1349            However, it never has SvPVX set.
1350         */
1351         if (old_type == SVt_IV) {
1352             assert(!SvROK(sv));
1353         } else if (old_type >= SVt_PV) {
1354             assert(SvPVX_const(sv) == 0);
1355         }
1356
1357         if (old_type >= SVt_PVMG) {
1358             SvMAGIC_set(sv, ((XPVMG*)old_body)->xmg_u.xmg_magic);
1359             SvSTASH_set(sv, ((XPVMG*)old_body)->xmg_stash);
1360         } else {
1361             sv->sv_u.svu_array = NULL; /* or svu_hash  */
1362         }
1363         break;
1364
1365
1366     case SVt_PVIV:
1367         /* XXX Is this still needed?  Was it ever needed?   Surely as there is
1368            no route from NV to PVIV, NOK can never be true  */
1369         assert(!SvNOKp(sv));
1370         assert(!SvNOK(sv));
1371     case SVt_PVIO:
1372     case SVt_PVFM:
1373     case SVt_PVGV:
1374     case SVt_PVCV:
1375     case SVt_PVLV:
1376     case SVt_REGEXP:
1377     case SVt_PVMG:
1378     case SVt_PVNV:
1379     case SVt_PV:
1380
1381         assert(new_type_details->body_size);
1382         /* We always allocated the full length item with PURIFY. To do this
1383            we fake things so that arena is false for all 16 types..  */
1384         if(new_type_details->arena) {
1385             /* This points to the start of the allocated area.  */
1386             new_body_inline(new_body, new_type);
1387             Zero(new_body, new_type_details->body_size, char);
1388             new_body = ((char *)new_body) - new_type_details->offset;
1389         } else {
1390             new_body = new_NOARENAZ(new_type_details);
1391         }
1392         SvANY(sv) = new_body;
1393
1394         if (old_type_details->copy) {
1395             /* There is now the potential for an upgrade from something without
1396                an offset (PVNV or PVMG) to something with one (PVCV, PVFM)  */
1397             int offset = old_type_details->offset;
1398             int length = old_type_details->copy;
1399
1400             if (new_type_details->offset > old_type_details->offset) {
1401                 const int difference
1402                     = new_type_details->offset - old_type_details->offset;
1403                 offset += difference;
1404                 length -= difference;
1405             }
1406             assert (length >= 0);
1407
1408             Copy((char *)old_body + offset, (char *)new_body + offset, length,
1409                  char);
1410         }
1411
1412 #ifndef NV_ZERO_IS_ALLBITS_ZERO
1413         /* If NV 0.0 is stores as all bits 0 then Zero() already creates a
1414          * correct 0.0 for us.  Otherwise, if the old body didn't have an
1415          * NV slot, but the new one does, then we need to initialise the
1416          * freshly created NV slot with whatever the correct bit pattern is
1417          * for 0.0  */
1418         if (old_type_details->zero_nv && !new_type_details->zero_nv
1419             && !isGV_with_GP(sv))
1420             SvNV_set(sv, 0);
1421 #endif
1422
1423         if (new_type == SVt_PVIO)
1424             IoPAGE_LEN(sv) = 60;
1425         if (old_type < SVt_PV) {
1426             /* referant will be NULL unless the old type was SVt_IV emulating
1427                SVt_RV */
1428             sv->sv_u.svu_rv = referant;
1429         }
1430         break;
1431     default:
1432         Perl_croak(aTHX_ "panic: sv_upgrade to unknown type %lu",
1433                    (unsigned long)new_type);
1434     }
1435
1436     if (old_type_details->arena) {
1437         /* If there was an old body, then we need to free it.
1438            Note that there is an assumption that all bodies of types that
1439            can be upgraded came from arenas. Only the more complex non-
1440            upgradable types are allowed to be directly malloc()ed.  */
1441 #ifdef PURIFY
1442         my_safefree(old_body);
1443 #else
1444         del_body((void*)((char*)old_body + old_type_details->offset),
1445                  &PL_body_roots[old_type]);
1446 #endif
1447     }
1448 }
1449
1450 /*
1451 =for apidoc sv_backoff
1452
1453 Remove any string offset. You should normally use the C<SvOOK_off> macro
1454 wrapper instead.
1455
1456 =cut
1457 */
1458
1459 int
1460 Perl_sv_backoff(pTHX_ register SV *const sv)
1461 {
1462     STRLEN delta;
1463     const char * const s = SvPVX_const(sv);
1464
1465     PERL_ARGS_ASSERT_SV_BACKOFF;
1466     PERL_UNUSED_CONTEXT;
1467
1468     assert(SvOOK(sv));
1469     assert(SvTYPE(sv) != SVt_PVHV);
1470     assert(SvTYPE(sv) != SVt_PVAV);
1471
1472     SvOOK_offset(sv, delta);
1473
1474     SvLEN_set(sv, SvLEN(sv) + delta);
1475     SvPV_set(sv, SvPVX(sv) - delta);
1476     Move(s, SvPVX(sv), SvCUR(sv)+1, char);
1477     SvFLAGS(sv) &= ~SVf_OOK;
1478     return 0;
1479 }
1480
1481 /*
1482 =for apidoc sv_grow
1483
1484 Expands the character buffer in the SV.  If necessary, uses C<sv_unref> and
1485 upgrades the SV to C<SVt_PV>.  Returns a pointer to the character buffer.
1486 Use the C<SvGROW> wrapper instead.
1487
1488 =cut
1489 */
1490
1491 char *
1492 Perl_sv_grow(pTHX_ register SV *const sv, register STRLEN newlen)
1493 {
1494     register char *s;
1495
1496     PERL_ARGS_ASSERT_SV_GROW;
1497
1498     if (PL_madskills && newlen >= 0x100000) {
1499         PerlIO_printf(Perl_debug_log,
1500                       "Allocation too large: %"UVxf"\n", (UV)newlen);
1501     }
1502 #ifdef HAS_64K_LIMIT
1503     if (newlen >= 0x10000) {
1504         PerlIO_printf(Perl_debug_log,
1505                       "Allocation too large: %"UVxf"\n", (UV)newlen);
1506         my_exit(1);
1507     }
1508 #endif /* HAS_64K_LIMIT */
1509     if (SvROK(sv))
1510         sv_unref(sv);
1511     if (SvTYPE(sv) < SVt_PV) {
1512         sv_upgrade(sv, SVt_PV);
1513         s = SvPVX_mutable(sv);
1514     }
1515     else if (SvOOK(sv)) {       /* pv is offset? */
1516         sv_backoff(sv);
1517         s = SvPVX_mutable(sv);
1518         if (newlen > SvLEN(sv))
1519             newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
1520 #ifdef HAS_64K_LIMIT
1521         if (newlen >= 0x10000)
1522             newlen = 0xFFFF;
1523 #endif
1524     }
1525     else
1526         s = SvPVX_mutable(sv);
1527
1528     if (newlen > SvLEN(sv)) {           /* need more room? */
1529 #ifndef Perl_safesysmalloc_size
1530         newlen = PERL_STRLEN_ROUNDUP(newlen);
1531 #endif
1532         if (SvLEN(sv) && s) {
1533             s = (char*)saferealloc(s, newlen);
1534         }
1535         else {
1536             s = (char*)safemalloc(newlen);
1537             if (SvPVX_const(sv) && SvCUR(sv)) {
1538                 Move(SvPVX_const(sv), s, (newlen < SvCUR(sv)) ? newlen : SvCUR(sv), char);
1539             }
1540         }
1541         SvPV_set(sv, s);
1542 #ifdef Perl_safesysmalloc_size
1543         /* Do this here, do it once, do it right, and then we will never get
1544            called back into sv_grow() unless there really is some growing
1545            needed.  */
1546         SvLEN_set(sv, Perl_safesysmalloc_size(s));
1547 #else
1548         SvLEN_set(sv, newlen);
1549 #endif
1550     }
1551     return s;
1552 }
1553
1554 /*
1555 =for apidoc sv_setiv
1556
1557 Copies an integer into the given SV, upgrading first if necessary.
1558 Does not handle 'set' magic.  See also C<sv_setiv_mg>.
1559
1560 =cut
1561 */
1562
1563 void
1564 Perl_sv_setiv(pTHX_ register SV *const sv, const IV i)
1565 {
1566     dVAR;
1567
1568     PERL_ARGS_ASSERT_SV_SETIV;
1569
1570     SV_CHECK_THINKFIRST_COW_DROP(sv);
1571     switch (SvTYPE(sv)) {
1572     case SVt_NULL:
1573     case SVt_NV:
1574         sv_upgrade(sv, SVt_IV);
1575         break;
1576     case SVt_PV:
1577         sv_upgrade(sv, SVt_PVIV);
1578         break;
1579
1580     case SVt_PVGV:
1581         if (!isGV_with_GP(sv))
1582             break;
1583     case SVt_PVAV:
1584     case SVt_PVHV:
1585     case SVt_PVCV:
1586     case SVt_PVFM:
1587     case SVt_PVIO:
1588         Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
1589                    OP_DESC(PL_op));
1590     default: NOOP;
1591     }
1592     (void)SvIOK_only(sv);                       /* validate number */
1593     SvIV_set(sv, i);
1594     SvTAINT(sv);
1595 }
1596
1597 /*
1598 =for apidoc sv_setiv_mg
1599
1600 Like C<sv_setiv>, but also handles 'set' magic.
1601
1602 =cut
1603 */
1604
1605 void
1606 Perl_sv_setiv_mg(pTHX_ register SV *const sv, const IV i)
1607 {
1608     PERL_ARGS_ASSERT_SV_SETIV_MG;
1609
1610     sv_setiv(sv,i);
1611     SvSETMAGIC(sv);
1612 }
1613
1614 /*
1615 =for apidoc sv_setuv
1616
1617 Copies an unsigned integer into the given SV, upgrading first if necessary.
1618 Does not handle 'set' magic.  See also C<sv_setuv_mg>.
1619
1620 =cut
1621 */
1622
1623 void
1624 Perl_sv_setuv(pTHX_ register SV *const sv, const UV u)
1625 {
1626     PERL_ARGS_ASSERT_SV_SETUV;
1627
1628     /* With these two if statements:
1629        u=1.49  s=0.52  cu=72.49  cs=10.64  scripts=270  tests=20865
1630
1631        without
1632        u=1.35  s=0.47  cu=73.45  cs=11.43  scripts=270  tests=20865
1633
1634        If you wish to remove them, please benchmark to see what the effect is
1635     */
1636     if (u <= (UV)IV_MAX) {
1637        sv_setiv(sv, (IV)u);
1638        return;
1639     }
1640     sv_setiv(sv, 0);
1641     SvIsUV_on(sv);
1642     SvUV_set(sv, u);
1643 }
1644
1645 /*
1646 =for apidoc sv_setuv_mg
1647
1648 Like C<sv_setuv>, but also handles 'set' magic.
1649
1650 =cut
1651 */
1652
1653 void
1654 Perl_sv_setuv_mg(pTHX_ register SV *const sv, const UV u)
1655 {
1656     PERL_ARGS_ASSERT_SV_SETUV_MG;
1657
1658     sv_setuv(sv,u);
1659     SvSETMAGIC(sv);
1660 }
1661
1662 /*
1663 =for apidoc sv_setnv
1664
1665 Copies a double into the given SV, upgrading first if necessary.
1666 Does not handle 'set' magic.  See also C<sv_setnv_mg>.
1667
1668 =cut
1669 */
1670
1671 void
1672 Perl_sv_setnv(pTHX_ register SV *const sv, const NV num)
1673 {
1674     dVAR;
1675
1676     PERL_ARGS_ASSERT_SV_SETNV;
1677
1678     SV_CHECK_THINKFIRST_COW_DROP(sv);
1679     switch (SvTYPE(sv)) {
1680     case SVt_NULL:
1681     case SVt_IV:
1682         sv_upgrade(sv, SVt_NV);
1683         break;
1684     case SVt_PV:
1685     case SVt_PVIV:
1686         sv_upgrade(sv, SVt_PVNV);
1687         break;
1688
1689     case SVt_PVGV:
1690         if (!isGV_with_GP(sv))
1691             break;
1692     case SVt_PVAV:
1693     case SVt_PVHV:
1694     case SVt_PVCV:
1695     case SVt_PVFM:
1696     case SVt_PVIO:
1697         Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
1698                    OP_NAME(PL_op));
1699     default: NOOP;
1700     }
1701     SvNV_set(sv, num);
1702     (void)SvNOK_only(sv);                       /* validate number */
1703     SvTAINT(sv);
1704 }
1705
1706 /*
1707 =for apidoc sv_setnv_mg
1708
1709 Like C<sv_setnv>, but also handles 'set' magic.
1710
1711 =cut
1712 */
1713
1714 void
1715 Perl_sv_setnv_mg(pTHX_ register SV *const sv, const NV num)
1716 {
1717     PERL_ARGS_ASSERT_SV_SETNV_MG;
1718
1719     sv_setnv(sv,num);
1720     SvSETMAGIC(sv);
1721 }
1722
1723 /* Print an "isn't numeric" warning, using a cleaned-up,
1724  * printable version of the offending string
1725  */
1726
1727 STATIC void
1728 S_not_a_number(pTHX_ SV *const sv)
1729 {
1730      dVAR;
1731      SV *dsv;
1732      char tmpbuf[64];
1733      const char *pv;
1734
1735      PERL_ARGS_ASSERT_NOT_A_NUMBER;
1736
1737      if (DO_UTF8(sv)) {
1738           dsv = newSVpvs_flags("", SVs_TEMP);
1739           pv = sv_uni_display(dsv, sv, 10, 0);
1740      } else {
1741           char *d = tmpbuf;
1742           const char * const limit = tmpbuf + sizeof(tmpbuf) - 8;
1743           /* each *s can expand to 4 chars + "...\0",
1744              i.e. need room for 8 chars */
1745
1746           const char *s = SvPVX_const(sv);
1747           const char * const end = s + SvCUR(sv);
1748           for ( ; s < end && d < limit; s++ ) {
1749                int ch = *s & 0xFF;
1750                if (ch & 128 && !isPRINT_LC(ch)) {
1751                     *d++ = 'M';
1752                     *d++ = '-';
1753                     ch &= 127;
1754                }
1755                if (ch == '\n') {
1756                     *d++ = '\\';
1757                     *d++ = 'n';
1758                }
1759                else if (ch == '\r') {
1760                     *d++ = '\\';
1761                     *d++ = 'r';
1762                }
1763                else if (ch == '\f') {
1764                     *d++ = '\\';
1765                     *d++ = 'f';
1766                }
1767                else if (ch == '\\') {
1768                     *d++ = '\\';
1769                     *d++ = '\\';
1770                }
1771                else if (ch == '\0') {
1772                     *d++ = '\\';
1773                     *d++ = '0';
1774                }
1775                else if (isPRINT_LC(ch))
1776                     *d++ = ch;
1777                else {
1778                     *d++ = '^';
1779                     *d++ = toCTRL(ch);
1780                }
1781           }
1782           if (s < end) {
1783                *d++ = '.';
1784                *d++ = '.';
1785                *d++ = '.';
1786           }
1787           *d = '\0';
1788           pv = tmpbuf;
1789     }
1790
1791     if (PL_op)
1792         Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1793                     "Argument \"%s\" isn't numeric in %s", pv,
1794                     OP_DESC(PL_op));
1795     else
1796         Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1797                     "Argument \"%s\" isn't numeric", pv);
1798 }
1799
1800 /*
1801 =for apidoc looks_like_number
1802
1803 Test if the content of an SV looks like a number (or is a number).
1804 C<Inf> and C<Infinity> are treated as numbers (so will not issue a
1805 non-numeric warning), even if your atof() doesn't grok them.
1806
1807 =cut
1808 */
1809
1810 I32
1811 Perl_looks_like_number(pTHX_ SV *const sv)
1812 {
1813     register const char *sbegin;
1814     STRLEN len;
1815
1816     PERL_ARGS_ASSERT_LOOKS_LIKE_NUMBER;
1817
1818     if (SvPOK(sv)) {
1819         sbegin = SvPVX_const(sv);
1820         len = SvCUR(sv);
1821     }
1822     else if (SvPOKp(sv))
1823         sbegin = SvPV_const(sv, len);
1824     else
1825         return SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK);
1826     return grok_number(sbegin, len, NULL);
1827 }
1828
1829 STATIC bool
1830 S_glob_2number(pTHX_ GV * const gv)
1831 {
1832     const U32 wasfake = SvFLAGS(gv) & SVf_FAKE;
1833     SV *const buffer = sv_newmortal();
1834
1835     PERL_ARGS_ASSERT_GLOB_2NUMBER;
1836
1837     /* FAKE globs can get coerced, so need to turn this off temporarily if it
1838        is on.  */
1839     SvFAKE_off(gv);
1840     gv_efullname3(buffer, gv, "*");
1841     SvFLAGS(gv) |= wasfake;
1842
1843     /* We know that all GVs stringify to something that is not-a-number,
1844         so no need to test that.  */
1845     if (ckWARN(WARN_NUMERIC))
1846         not_a_number(buffer);
1847     /* We just want something true to return, so that S_sv_2iuv_common
1848         can tail call us and return true.  */
1849     return TRUE;
1850 }
1851
1852 STATIC char *
1853 S_glob_2pv(pTHX_ GV * const gv, STRLEN * const len)
1854 {
1855     const U32 wasfake = SvFLAGS(gv) & SVf_FAKE;
1856     SV *const buffer = sv_newmortal();
1857
1858     PERL_ARGS_ASSERT_GLOB_2PV;
1859
1860     /* FAKE globs can get coerced, so need to turn this off temporarily if it
1861        is on.  */
1862     SvFAKE_off(gv);
1863     gv_efullname3(buffer, gv, "*");
1864     SvFLAGS(gv) |= wasfake;
1865
1866     assert(SvPOK(buffer));
1867     if (len) {
1868         *len = SvCUR(buffer);
1869     }
1870     return SvPVX(buffer);
1871 }
1872
1873 /* Actually, ISO C leaves conversion of UV to IV undefined, but
1874    until proven guilty, assume that things are not that bad... */
1875
1876 /*
1877    NV_PRESERVES_UV:
1878
1879    As 64 bit platforms often have an NV that doesn't preserve all bits of
1880    an IV (an assumption perl has been based on to date) it becomes necessary
1881    to remove the assumption that the NV always carries enough precision to
1882    recreate the IV whenever needed, and that the NV is the canonical form.
1883    Instead, IV/UV and NV need to be given equal rights. So as to not lose
1884    precision as a side effect of conversion (which would lead to insanity
1885    and the dragon(s) in t/op/numconvert.t getting very angry) the intent is
1886    1) to distinguish between IV/UV/NV slots that have cached a valid
1887       conversion where precision was lost and IV/UV/NV slots that have a
1888       valid conversion which has lost no precision
1889    2) to ensure that if a numeric conversion to one form is requested that
1890       would lose precision, the precise conversion (or differently
1891       imprecise conversion) is also performed and cached, to prevent
1892       requests for different numeric formats on the same SV causing
1893       lossy conversion chains. (lossless conversion chains are perfectly
1894       acceptable (still))
1895
1896
1897    flags are used:
1898    SvIOKp is true if the IV slot contains a valid value
1899    SvIOK  is true only if the IV value is accurate (UV if SvIOK_UV true)
1900    SvNOKp is true if the NV slot contains a valid value
1901    SvNOK  is true only if the NV value is accurate
1902
1903    so
1904    while converting from PV to NV, check to see if converting that NV to an
1905    IV(or UV) would lose accuracy over a direct conversion from PV to
1906    IV(or UV). If it would, cache both conversions, return NV, but mark
1907    SV as IOK NOKp (ie not NOK).
1908
1909    While converting from PV to IV, check to see if converting that IV to an
1910    NV would lose accuracy over a direct conversion from PV to NV. If it
1911    would, cache both conversions, flag similarly.
1912
1913    Before, the SV value "3.2" could become NV=3.2 IV=3 NOK, IOK quite
1914    correctly because if IV & NV were set NV *always* overruled.
1915    Now, "3.2" will become NV=3.2 IV=3 NOK, IOKp, because the flag's meaning
1916    changes - now IV and NV together means that the two are interchangeable:
1917    SvIVX == (IV) SvNVX && SvNVX == (NV) SvIVX;
1918
1919    The benefit of this is that operations such as pp_add know that if
1920    SvIOK is true for both left and right operands, then integer addition
1921    can be used instead of floating point (for cases where the result won't
1922    overflow). Before, floating point was always used, which could lead to
1923    loss of precision compared with integer addition.
1924
1925    * making IV and NV equal status should make maths accurate on 64 bit
1926      platforms
1927    * may speed up maths somewhat if pp_add and friends start to use
1928      integers when possible instead of fp. (Hopefully the overhead in
1929      looking for SvIOK and checking for overflow will not outweigh the
1930      fp to integer speedup)
1931    * will slow down integer operations (callers of SvIV) on "inaccurate"
1932      values, as the change from SvIOK to SvIOKp will cause a call into
1933      sv_2iv each time rather than a macro access direct to the IV slot
1934    * should speed up number->string conversion on integers as IV is
1935      favoured when IV and NV are equally accurate
1936
1937    ####################################################################
1938    You had better be using SvIOK_notUV if you want an IV for arithmetic:
1939    SvIOK is true if (IV or UV), so you might be getting (IV)SvUV.
1940    On the other hand, SvUOK is true iff UV.
1941    ####################################################################
1942
1943    Your mileage will vary depending your CPU's relative fp to integer
1944    performance ratio.
1945 */
1946
1947 #ifndef NV_PRESERVES_UV
1948 #  define IS_NUMBER_UNDERFLOW_IV 1
1949 #  define IS_NUMBER_UNDERFLOW_UV 2
1950 #  define IS_NUMBER_IV_AND_UV    2
1951 #  define IS_NUMBER_OVERFLOW_IV  4
1952 #  define IS_NUMBER_OVERFLOW_UV  5
1953
1954 /* sv_2iuv_non_preserve(): private routine for use by sv_2iv() and sv_2uv() */
1955
1956 /* For sv_2nv these three cases are "SvNOK and don't bother casting"  */
1957 STATIC int
1958 S_sv_2iuv_non_preserve(pTHX_ register SV *const sv
1959 #  ifdef DEBUGGING
1960                        , I32 numtype
1961 #  endif
1962                        )
1963 {
1964     dVAR;
1965
1966     PERL_ARGS_ASSERT_SV_2IUV_NON_PRESERVE;
1967
1968     DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_2iuv_non '%s', IV=0x%"UVxf" NV=%"NVgf" inttype=%"UVXf"\n", SvPVX_const(sv), SvIVX(sv), SvNVX(sv), (UV)numtype));
1969     if (SvNVX(sv) < (NV)IV_MIN) {
1970         (void)SvIOKp_on(sv);
1971         (void)SvNOK_on(sv);
1972         SvIV_set(sv, IV_MIN);
1973         return IS_NUMBER_UNDERFLOW_IV;
1974     }
1975     if (SvNVX(sv) > (NV)UV_MAX) {
1976         (void)SvIOKp_on(sv);
1977         (void)SvNOK_on(sv);
1978         SvIsUV_on(sv);
1979         SvUV_set(sv, UV_MAX);
1980         return IS_NUMBER_OVERFLOW_UV;
1981     }
1982     (void)SvIOKp_on(sv);
1983     (void)SvNOK_on(sv);
1984     /* Can't use strtol etc to convert this string.  (See truth table in
1985        sv_2iv  */
1986     if (SvNVX(sv) <= (UV)IV_MAX) {
1987         SvIV_set(sv, I_V(SvNVX(sv)));
1988         if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
1989             SvIOK_on(sv); /* Integer is precise. NOK, IOK */
1990         } else {
1991             /* Integer is imprecise. NOK, IOKp */
1992         }
1993         return SvNVX(sv) < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV;
1994     }
1995     SvIsUV_on(sv);
1996     SvUV_set(sv, U_V(SvNVX(sv)));
1997     if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
1998         if (SvUVX(sv) == UV_MAX) {
1999             /* As we know that NVs don't preserve UVs, UV_MAX cannot
2000                possibly be preserved by NV. Hence, it must be overflow.
2001                NOK, IOKp */
2002             return IS_NUMBER_OVERFLOW_UV;
2003         }
2004         SvIOK_on(sv); /* Integer is precise. NOK, UOK */
2005     } else {
2006         /* Integer is imprecise. NOK, IOKp */
2007     }
2008     return IS_NUMBER_OVERFLOW_IV;
2009 }
2010 #endif /* !NV_PRESERVES_UV*/
2011
2012 STATIC bool
2013 S_sv_2iuv_common(pTHX_ SV *const sv)
2014 {
2015     dVAR;
2016
2017     PERL_ARGS_ASSERT_SV_2IUV_COMMON;
2018
2019     if (SvNOKp(sv)) {
2020         /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
2021          * without also getting a cached IV/UV from it at the same time
2022          * (ie PV->NV conversion should detect loss of accuracy and cache
2023          * IV or UV at same time to avoid this. */
2024         /* IV-over-UV optimisation - choose to cache IV if possible */
2025
2026         if (SvTYPE(sv) == SVt_NV)
2027             sv_upgrade(sv, SVt_PVNV);
2028
2029         (void)SvIOKp_on(sv);    /* Must do this first, to clear any SvOOK */
2030         /* < not <= as for NV doesn't preserve UV, ((NV)IV_MAX+1) will almost
2031            certainly cast into the IV range at IV_MAX, whereas the correct
2032            answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary
2033            cases go to UV */
2034 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2035         if (Perl_isnan(SvNVX(sv))) {
2036             SvUV_set(sv, 0);
2037             SvIsUV_on(sv);
2038             return FALSE;
2039         }
2040 #endif
2041         if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2042             SvIV_set(sv, I_V(SvNVX(sv)));
2043             if (SvNVX(sv) == (NV) SvIVX(sv)
2044 #ifndef NV_PRESERVES_UV
2045                 && (((UV)1 << NV_PRESERVES_UV_BITS) >
2046                     (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
2047                 /* Don't flag it as "accurately an integer" if the number
2048                    came from a (by definition imprecise) NV operation, and
2049                    we're outside the range of NV integer precision */
2050 #endif
2051                 ) {
2052                 if (SvNOK(sv))
2053                     SvIOK_on(sv);  /* Can this go wrong with rounding? NWC */
2054                 else {
2055                     /* scalar has trailing garbage, eg "42a" */
2056                 }
2057                 DEBUG_c(PerlIO_printf(Perl_debug_log,
2058                                       "0x%"UVxf" iv(%"NVgf" => %"IVdf") (precise)\n",
2059                                       PTR2UV(sv),
2060                                       SvNVX(sv),
2061                                       SvIVX(sv)));
2062
2063             } else {
2064                 /* IV not precise.  No need to convert from PV, as NV
2065                    conversion would already have cached IV if it detected
2066                    that PV->IV would be better than PV->NV->IV
2067                    flags already correct - don't set public IOK.  */
2068                 DEBUG_c(PerlIO_printf(Perl_debug_log,
2069                                       "0x%"UVxf" iv(%"NVgf" => %"IVdf") (imprecise)\n",
2070                                       PTR2UV(sv),
2071                                       SvNVX(sv),
2072                                       SvIVX(sv)));
2073             }
2074             /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2075                but the cast (NV)IV_MIN rounds to a the value less (more
2076                negative) than IV_MIN which happens to be equal to SvNVX ??
2077                Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2078                NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2079                (NV)UVX == NVX are both true, but the values differ. :-(
2080                Hopefully for 2s complement IV_MIN is something like
2081                0x8000000000000000 which will be exact. NWC */
2082         }
2083         else {
2084             SvUV_set(sv, U_V(SvNVX(sv)));
2085             if (
2086                 (SvNVX(sv) == (NV) SvUVX(sv))
2087 #ifndef  NV_PRESERVES_UV
2088                 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2089                 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2090                 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2091                 /* Don't flag it as "accurately an integer" if the number
2092                    came from a (by definition imprecise) NV operation, and
2093                    we're outside the range of NV integer precision */
2094 #endif
2095                 && SvNOK(sv)
2096                 )
2097                 SvIOK_on(sv);
2098             SvIsUV_on(sv);
2099             DEBUG_c(PerlIO_printf(Perl_debug_log,
2100                                   "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n",
2101                                   PTR2UV(sv),
2102                                   SvUVX(sv),
2103                                   SvUVX(sv)));
2104         }
2105     }
2106     else if (SvPOKp(sv) && SvLEN(sv)) {
2107         UV value;
2108         const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2109         /* We want to avoid a possible problem when we cache an IV/ a UV which
2110            may be later translated to an NV, and the resulting NV is not
2111            the same as the direct translation of the initial string
2112            (eg 123.456 can shortcut to the IV 123 with atol(), but we must
2113            be careful to ensure that the value with the .456 is around if the
2114            NV value is requested in the future).
2115
2116            This means that if we cache such an IV/a UV, we need to cache the
2117            NV as well.  Moreover, we trade speed for space, and do not
2118            cache the NV if we are sure it's not needed.
2119          */
2120
2121         /* SVt_PVNV is one higher than SVt_PVIV, hence this order  */
2122         if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2123              == IS_NUMBER_IN_UV) {
2124             /* It's definitely an integer, only upgrade to PVIV */
2125             if (SvTYPE(sv) < SVt_PVIV)
2126                 sv_upgrade(sv, SVt_PVIV);
2127             (void)SvIOK_on(sv);
2128         } else if (SvTYPE(sv) < SVt_PVNV)
2129             sv_upgrade(sv, SVt_PVNV);
2130
2131         /* If NVs preserve UVs then we only use the UV value if we know that
2132            we aren't going to call atof() below. If NVs don't preserve UVs
2133            then the value returned may have more precision than atof() will
2134            return, even though value isn't perfectly accurate.  */
2135         if ((numtype & (IS_NUMBER_IN_UV
2136 #ifdef NV_PRESERVES_UV
2137                         | IS_NUMBER_NOT_INT
2138 #endif
2139             )) == IS_NUMBER_IN_UV) {
2140             /* This won't turn off the public IOK flag if it was set above  */
2141             (void)SvIOKp_on(sv);
2142
2143             if (!(numtype & IS_NUMBER_NEG)) {
2144                 /* positive */;
2145                 if (value <= (UV)IV_MAX) {
2146                     SvIV_set(sv, (IV)value);
2147                 } else {
2148                     /* it didn't overflow, and it was positive. */
2149                     SvUV_set(sv, value);
2150                     SvIsUV_on(sv);
2151                 }
2152             } else {
2153                 /* 2s complement assumption  */
2154                 if (value <= (UV)IV_MIN) {
2155                     SvIV_set(sv, -(IV)value);
2156                 } else {
2157                     /* Too negative for an IV.  This is a double upgrade, but
2158                        I'm assuming it will be rare.  */
2159                     if (SvTYPE(sv) < SVt_PVNV)
2160                         sv_upgrade(sv, SVt_PVNV);
2161                     SvNOK_on(sv);
2162                     SvIOK_off(sv);
2163                     SvIOKp_on(sv);
2164                     SvNV_set(sv, -(NV)value);
2165                     SvIV_set(sv, IV_MIN);
2166                 }
2167             }
2168         }
2169         /* For !NV_PRESERVES_UV and IS_NUMBER_IN_UV and IS_NUMBER_NOT_INT we
2170            will be in the previous block to set the IV slot, and the next
2171            block to set the NV slot.  So no else here.  */
2172
2173         if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2174             != IS_NUMBER_IN_UV) {
2175             /* It wasn't an (integer that doesn't overflow the UV). */
2176             SvNV_set(sv, Atof(SvPVX_const(sv)));
2177
2178             if (! numtype && ckWARN(WARN_NUMERIC))
2179                 not_a_number(sv);
2180
2181 #if defined(USE_LONG_DOUBLE)
2182             DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" PERL_PRIgldbl ")\n",
2183                                   PTR2UV(sv), SvNVX(sv)));
2184 #else
2185             DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"NVgf")\n",
2186                                   PTR2UV(sv), SvNVX(sv)));
2187 #endif
2188
2189 #ifdef NV_PRESERVES_UV
2190             (void)SvIOKp_on(sv);
2191             (void)SvNOK_on(sv);
2192             if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2193                 SvIV_set(sv, I_V(SvNVX(sv)));
2194                 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2195                     SvIOK_on(sv);
2196                 } else {
2197                     NOOP;  /* Integer is imprecise. NOK, IOKp */
2198                 }
2199                 /* UV will not work better than IV */
2200             } else {
2201                 if (SvNVX(sv) > (NV)UV_MAX) {
2202                     SvIsUV_on(sv);
2203                     /* Integer is inaccurate. NOK, IOKp, is UV */
2204                     SvUV_set(sv, UV_MAX);
2205                 } else {
2206                     SvUV_set(sv, U_V(SvNVX(sv)));
2207                     /* 0xFFFFFFFFFFFFFFFF not an issue in here, NVs
2208                        NV preservse UV so can do correct comparison.  */
2209                     if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2210                         SvIOK_on(sv);
2211                     } else {
2212                         NOOP;   /* Integer is imprecise. NOK, IOKp, is UV */
2213                     }
2214                 }
2215                 SvIsUV_on(sv);
2216             }
2217 #else /* NV_PRESERVES_UV */
2218             if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2219                 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
2220                 /* The IV/UV slot will have been set from value returned by
2221                    grok_number above.  The NV slot has just been set using
2222                    Atof.  */
2223                 SvNOK_on(sv);
2224                 assert (SvIOKp(sv));
2225             } else {
2226                 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2227                     U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2228                     /* Small enough to preserve all bits. */
2229                     (void)SvIOKp_on(sv);
2230                     SvNOK_on(sv);
2231                     SvIV_set(sv, I_V(SvNVX(sv)));
2232                     if ((NV)(SvIVX(sv)) == SvNVX(sv))
2233                         SvIOK_on(sv);
2234                     /* Assumption: first non-preserved integer is < IV_MAX,
2235                        this NV is in the preserved range, therefore: */
2236                     if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
2237                           < (UV)IV_MAX)) {
2238                         Perl_croak(aTHX_ "sv_2iv assumed (U_V(fabs((double)SvNVX(sv))) < (UV)IV_MAX) but SvNVX(sv)=%"NVgf" U_V is 0x%"UVxf", IV_MAX is 0x%"UVxf"\n", SvNVX(sv), U_V(SvNVX(sv)), (UV)IV_MAX);
2239                     }
2240                 } else {
2241                     /* IN_UV NOT_INT
2242                          0      0       already failed to read UV.
2243                          0      1       already failed to read UV.
2244                          1      0       you won't get here in this case. IV/UV
2245                                         slot set, public IOK, Atof() unneeded.
2246                          1      1       already read UV.
2247                        so there's no point in sv_2iuv_non_preserve() attempting
2248                        to use atol, strtol, strtoul etc.  */
2249 #  ifdef DEBUGGING
2250                     sv_2iuv_non_preserve (sv, numtype);
2251 #  else
2252                     sv_2iuv_non_preserve (sv);
2253 #  endif
2254                 }
2255             }
2256 #endif /* NV_PRESERVES_UV */
2257         /* It might be more code efficient to go through the entire logic above
2258            and conditionally set with SvIOKp_on() rather than SvIOK(), but it
2259            gets complex and potentially buggy, so more programmer efficient
2260            to do it this way, by turning off the public flags:  */
2261         if (!numtype)
2262             SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK);
2263         }
2264     }
2265     else  {
2266         if (isGV_with_GP(sv))
2267             return glob_2number((GV *)sv);
2268
2269         if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2270             if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
2271                 report_uninit(sv);
2272         }
2273         if (SvTYPE(sv) < SVt_IV)
2274             /* Typically the caller expects that sv_any is not NULL now.  */
2275             sv_upgrade(sv, SVt_IV);
2276         /* Return 0 from the caller.  */
2277         return TRUE;
2278     }
2279     return FALSE;
2280 }
2281
2282 /*
2283 =for apidoc sv_2iv_flags
2284
2285 Return the integer value of an SV, doing any necessary string
2286 conversion.  If flags includes SV_GMAGIC, does an mg_get() first.
2287 Normally used via the C<SvIV(sv)> and C<SvIVx(sv)> macros.
2288
2289 =cut
2290 */
2291
2292 IV
2293 Perl_sv_2iv_flags(pTHX_ register SV *const sv, const I32 flags)
2294 {
2295     dVAR;
2296     if (!sv)
2297         return 0;
2298     if (SvGMAGICAL(sv) || (SvTYPE(sv) == SVt_PVGV && SvVALID(sv))) {
2299         /* FBMs use the same flag bit as SVf_IVisUV, so must let them
2300            cache IVs just in case. In practice it seems that they never
2301            actually anywhere accessible by user Perl code, let alone get used
2302            in anything other than a string context.  */
2303         if (flags & SV_GMAGIC)
2304             mg_get(sv);
2305         if (SvIOKp(sv))
2306             return SvIVX(sv);
2307         if (SvNOKp(sv)) {
2308             return I_V(SvNVX(sv));
2309         }
2310         if (SvPOKp(sv) && SvLEN(sv)) {
2311             UV value;
2312             const int numtype
2313                 = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2314
2315             if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2316                 == IS_NUMBER_IN_UV) {
2317                 /* It's definitely an integer */
2318                 if (numtype & IS_NUMBER_NEG) {
2319                     if (value < (UV)IV_MIN)
2320                         return -(IV)value;
2321                 } else {
2322                     if (value < (UV)IV_MAX)
2323                         return (IV)value;
2324                 }
2325             }
2326             if (!numtype) {
2327                 if (ckWARN(WARN_NUMERIC))
2328                     not_a_number(sv);
2329             }
2330             return I_V(Atof(SvPVX_const(sv)));
2331         }
2332         if (SvROK(sv)) {
2333             goto return_rok;
2334         }
2335         assert(SvTYPE(sv) >= SVt_PVMG);
2336         /* This falls through to the report_uninit inside S_sv_2iuv_common.  */
2337     } else if (SvTHINKFIRST(sv)) {
2338         if (SvROK(sv)) {
2339         return_rok:
2340             if (SvAMAGIC(sv)) {
2341                 SV * const tmpstr=AMG_CALLun(sv,numer);
2342                 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2343                     return SvIV(tmpstr);
2344                 }
2345             }
2346             return PTR2IV(SvRV(sv));
2347         }
2348         if (SvIsCOW(sv)) {
2349             sv_force_normal_flags(sv, 0);
2350         }
2351         if (SvREADONLY(sv) && !SvOK(sv)) {
2352             if (ckWARN(WARN_UNINITIALIZED))
2353                 report_uninit(sv);
2354             return 0;
2355         }
2356     }
2357     if (!SvIOKp(sv)) {
2358         if (S_sv_2iuv_common(aTHX_ sv))
2359             return 0;
2360     }
2361     DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
2362         PTR2UV(sv),SvIVX(sv)));
2363     return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
2364 }
2365
2366 /*
2367 =for apidoc sv_2uv_flags
2368
2369 Return the unsigned integer value of an SV, doing any necessary string
2370 conversion.  If flags includes SV_GMAGIC, does an mg_get() first.
2371 Normally used via the C<SvUV(sv)> and C<SvUVx(sv)> macros.
2372
2373 =cut
2374 */
2375
2376 UV
2377 Perl_sv_2uv_flags(pTHX_ register SV *const sv, const I32 flags)
2378 {
2379     dVAR;
2380     if (!sv)
2381         return 0;
2382     if (SvGMAGICAL(sv) || (SvTYPE(sv) == SVt_PVGV && SvVALID(sv))) {
2383         /* FBMs use the same flag bit as SVf_IVisUV, so must let them
2384            cache IVs just in case.  */
2385         if (flags & SV_GMAGIC)
2386             mg_get(sv);
2387         if (SvIOKp(sv))
2388             return SvUVX(sv);
2389         if (SvNOKp(sv))
2390             return U_V(SvNVX(sv));
2391         if (SvPOKp(sv) && SvLEN(sv)) {
2392             UV value;
2393             const int numtype
2394                 = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2395
2396             if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2397                 == IS_NUMBER_IN_UV) {
2398                 /* It's definitely an integer */
2399                 if (!(numtype & IS_NUMBER_NEG))
2400                     return value;
2401             }
2402             if (!numtype) {
2403                 if (ckWARN(WARN_NUMERIC))
2404                     not_a_number(sv);
2405             }
2406             return U_V(Atof(SvPVX_const(sv)));
2407         }
2408         if (SvROK(sv)) {
2409             goto return_rok;
2410         }
2411         assert(SvTYPE(sv) >= SVt_PVMG);
2412         /* This falls through to the report_uninit inside S_sv_2iuv_common.  */
2413     } else if (SvTHINKFIRST(sv)) {
2414         if (SvROK(sv)) {
2415         return_rok:
2416             if (SvAMAGIC(sv)) {
2417                 SV *const tmpstr = AMG_CALLun(sv,numer);
2418                 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2419                     return SvUV(tmpstr);
2420                 }
2421             }
2422             return PTR2UV(SvRV(sv));
2423         }
2424         if (SvIsCOW(sv)) {
2425             sv_force_normal_flags(sv, 0);
2426         }
2427         if (SvREADONLY(sv) && !SvOK(sv)) {
2428             if (ckWARN(WARN_UNINITIALIZED))
2429                 report_uninit(sv);
2430             return 0;
2431         }
2432     }
2433     if (!SvIOKp(sv)) {
2434         if (S_sv_2iuv_common(aTHX_ sv))
2435             return 0;
2436     }
2437
2438     DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n",
2439                           PTR2UV(sv),SvUVX(sv)));
2440     return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
2441 }
2442
2443 /*
2444 =for apidoc sv_2nv
2445
2446 Return the num value of an SV, doing any necessary string or integer
2447 conversion, magic etc. Normally used via the C<SvNV(sv)> and C<SvNVx(sv)>
2448 macros.
2449
2450 =cut
2451 */
2452
2453 NV
2454 Perl_sv_2nv(pTHX_ register SV *const sv)
2455 {
2456     dVAR;
2457     if (!sv)
2458         return 0.0;
2459     if (SvGMAGICAL(sv) || (SvTYPE(sv) == SVt_PVGV && SvVALID(sv))) {
2460         /* FBMs use the same flag bit as SVf_IVisUV, so must let them
2461            cache IVs just in case.  */
2462         mg_get(sv);
2463         if (SvNOKp(sv))
2464             return SvNVX(sv);
2465         if ((SvPOKp(sv) && SvLEN(sv)) && !SvIOKp(sv)) {
2466             if (!SvIOKp(sv) && ckWARN(WARN_NUMERIC) &&
2467                 !grok_number(SvPVX_const(sv), SvCUR(sv), NULL))
2468                 not_a_number(sv);
2469             return Atof(SvPVX_const(sv));
2470         }
2471         if (SvIOKp(sv)) {
2472             if (SvIsUV(sv))
2473                 return (NV)SvUVX(sv);
2474             else
2475                 return (NV)SvIVX(sv);
2476         }
2477         if (SvROK(sv)) {
2478             goto return_rok;
2479         }
2480         assert(SvTYPE(sv) >= SVt_PVMG);
2481         /* This falls through to the report_uninit near the end of the
2482            function. */
2483     } else if (SvTHINKFIRST(sv)) {
2484         if (SvROK(sv)) {
2485         return_rok:
2486             if (SvAMAGIC(sv)) {
2487                 SV *const tmpstr = AMG_CALLun(sv,numer);
2488                 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2489                     return SvNV(tmpstr);
2490                 }
2491             }
2492             return PTR2NV(SvRV(sv));
2493         }
2494         if (SvIsCOW(sv)) {
2495             sv_force_normal_flags(sv, 0);
2496         }
2497         if (SvREADONLY(sv) && !SvOK(sv)) {
2498             if (ckWARN(WARN_UNINITIALIZED))
2499                 report_uninit(sv);
2500             return 0.0;
2501         }
2502     }
2503     if (SvTYPE(sv) < SVt_NV) {
2504         /* The logic to use SVt_PVNV if necessary is in sv_upgrade.  */
2505         sv_upgrade(sv, SVt_NV);
2506 #ifdef USE_LONG_DOUBLE
2507         DEBUG_c({
2508             STORE_NUMERIC_LOCAL_SET_STANDARD();
2509             PerlIO_printf(Perl_debug_log,
2510                           "0x%"UVxf" num(%" PERL_PRIgldbl ")\n",
2511                           PTR2UV(sv), SvNVX(sv));
2512             RESTORE_NUMERIC_LOCAL();
2513         });
2514 #else
2515         DEBUG_c({
2516             STORE_NUMERIC_LOCAL_SET_STANDARD();
2517             PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%"NVgf")\n",
2518                           PTR2UV(sv), SvNVX(sv));
2519             RESTORE_NUMERIC_LOCAL();
2520         });
2521 #endif
2522     }
2523     else if (SvTYPE(sv) < SVt_PVNV)
2524         sv_upgrade(sv, SVt_PVNV);
2525     if (SvNOKp(sv)) {
2526         return SvNVX(sv);
2527     }
2528     if (SvIOKp(sv)) {
2529         SvNV_set(sv, SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv));
2530 #ifdef NV_PRESERVES_UV
2531         if (SvIOK(sv))
2532             SvNOK_on(sv);
2533         else
2534             SvNOKp_on(sv);
2535 #else
2536         /* Only set the public NV OK flag if this NV preserves the IV  */
2537         /* Check it's not 0xFFFFFFFFFFFFFFFF */
2538         if (SvIOK(sv) &&
2539             SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv))))
2540                        : (SvIVX(sv) == I_V(SvNVX(sv))))
2541             SvNOK_on(sv);
2542         else
2543             SvNOKp_on(sv);
2544 #endif
2545     }
2546     else if (SvPOKp(sv) && SvLEN(sv)) {
2547         UV value;
2548         const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2549         if (!SvIOKp(sv) && !numtype && ckWARN(WARN_NUMERIC))
2550             not_a_number(sv);
2551 #ifdef NV_PRESERVES_UV
2552         if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2553             == IS_NUMBER_IN_UV) {
2554             /* It's definitely an integer */
2555             SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value);
2556         } else
2557             SvNV_set(sv, Atof(SvPVX_const(sv)));
2558         if (numtype)
2559             SvNOK_on(sv);
2560         else
2561             SvNOKp_on(sv);
2562 #else
2563         SvNV_set(sv, Atof(SvPVX_const(sv)));
2564         /* Only set the public NV OK flag if this NV preserves the value in
2565            the PV at least as well as an IV/UV would.
2566            Not sure how to do this 100% reliably. */
2567         /* if that shift count is out of range then Configure's test is
2568            wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS ==
2569            UV_BITS */
2570         if (((UV)1 << NV_PRESERVES_UV_BITS) >
2571             U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2572             SvNOK_on(sv); /* Definitely small enough to preserve all bits */
2573         } else if (!(numtype & IS_NUMBER_IN_UV)) {
2574             /* Can't use strtol etc to convert this string, so don't try.
2575                sv_2iv and sv_2uv will use the NV to convert, not the PV.  */
2576             SvNOK_on(sv);
2577         } else {
2578             /* value has been set.  It may not be precise.  */
2579             if ((numtype & IS_NUMBER_NEG) && (value > (UV)IV_MIN)) {
2580                 /* 2s complement assumption for (UV)IV_MIN  */
2581                 SvNOK_on(sv); /* Integer is too negative.  */
2582             } else {
2583                 SvNOKp_on(sv);
2584                 SvIOKp_on(sv);
2585
2586                 if (numtype & IS_NUMBER_NEG) {
2587                     SvIV_set(sv, -(IV)value);
2588                 } else if (value <= (UV)IV_MAX) {
2589                     SvIV_set(sv, (IV)value);
2590                 } else {
2591                     SvUV_set(sv, value);
2592                     SvIsUV_on(sv);
2593                 }
2594
2595                 if (numtype & IS_NUMBER_NOT_INT) {
2596                     /* I believe that even if the original PV had decimals,
2597                        they are lost beyond the limit of the FP precision.
2598                        However, neither is canonical, so both only get p
2599                        flags.  NWC, 2000/11/25 */
2600                     /* Both already have p flags, so do nothing */
2601                 } else {
2602                     const NV nv = SvNVX(sv);
2603                     if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2604                         if (SvIVX(sv) == I_V(nv)) {
2605                             SvNOK_on(sv);
2606                         } else {
2607                             /* It had no "." so it must be integer.  */
2608                         }
2609                         SvIOK_on(sv);
2610                     } else {
2611                         /* between IV_MAX and NV(UV_MAX).
2612                            Could be slightly > UV_MAX */
2613
2614                         if (numtype & IS_NUMBER_NOT_INT) {
2615                             /* UV and NV both imprecise.  */
2616                         } else {
2617                             const UV nv_as_uv = U_V(nv);
2618
2619                             if (value == nv_as_uv && SvUVX(sv) != UV_MAX) {
2620                                 SvNOK_on(sv);
2621                             }
2622                             SvIOK_on(sv);
2623                         }
2624                     }
2625                 }
2626             }
2627         }
2628         /* It might be more code efficient to go through the entire logic above
2629            and conditionally set with SvNOKp_on() rather than SvNOK(), but it
2630            gets complex and potentially buggy, so more programmer efficient
2631            to do it this way, by turning off the public flags:  */
2632         if (!numtype)
2633             SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK);
2634 #endif /* NV_PRESERVES_UV */
2635     }
2636     else  {
2637         if (isGV_with_GP(sv)) {
2638             glob_2number((GV *)sv);
2639             return 0.0;
2640         }
2641
2642         if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED))
2643             report_uninit(sv);
2644         assert (SvTYPE(sv) >= SVt_NV);
2645         /* Typically the caller expects that sv_any is not NULL now.  */
2646         /* XXX Ilya implies that this is a bug in callers that assume this
2647            and ideally should be fixed.  */
2648         return 0.0;
2649     }
2650 #if defined(USE_LONG_DOUBLE)
2651     DEBUG_c({
2652         STORE_NUMERIC_LOCAL_SET_STANDARD();
2653         PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
2654                       PTR2UV(sv), SvNVX(sv));
2655         RESTORE_NUMERIC_LOCAL();
2656     });
2657 #else
2658     DEBUG_c({
2659         STORE_NUMERIC_LOCAL_SET_STANDARD();
2660         PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%"NVgf")\n",
2661                       PTR2UV(sv), SvNVX(sv));
2662         RESTORE_NUMERIC_LOCAL();
2663     });
2664 #endif
2665     return SvNVX(sv);
2666 }
2667
2668 /*
2669 =for apidoc sv_2num
2670
2671 Return an SV with the numeric value of the source SV, doing any necessary
2672 reference or overload conversion.  You must use the C<SvNUM(sv)> macro to
2673 access this function.
2674
2675 =cut
2676 */
2677
2678 SV *
2679 Perl_sv_2num(pTHX_ register SV *const sv)
2680 {
2681     PERL_ARGS_ASSERT_SV_2NUM;
2682
2683     if (!SvROK(sv))
2684         return sv;
2685     if (SvAMAGIC(sv)) {
2686         SV * const tmpsv = AMG_CALLun(sv,numer);
2687         if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
2688             return sv_2num(tmpsv);
2689     }
2690     return sv_2mortal(newSVuv(PTR2UV(SvRV(sv))));
2691 }
2692
2693 /* uiv_2buf(): private routine for use by sv_2pv_flags(): print an IV or
2694  * UV as a string towards the end of buf, and return pointers to start and
2695  * end of it.
2696  *
2697  * We assume that buf is at least TYPE_CHARS(UV) long.
2698  */
2699
2700 static char *
2701 S_uiv_2buf(char *const buf, const IV iv, UV uv, const int is_uv, char **const peob)
2702 {
2703     char *ptr = buf + TYPE_CHARS(UV);
2704     char * const ebuf = ptr;
2705     int sign;
2706
2707     PERL_ARGS_ASSERT_UIV_2BUF;
2708
2709     if (is_uv)
2710         sign = 0;
2711     else if (iv >= 0) {
2712         uv = iv;
2713         sign = 0;
2714     } else {
2715         uv = -iv;
2716         sign = 1;
2717     }
2718     do {
2719         *--ptr = '0' + (char)(uv % 10);
2720     } while (uv /= 10);
2721     if (sign)
2722         *--ptr = '-';
2723     *peob = ebuf;
2724     return ptr;
2725 }
2726
2727 /*
2728 =for apidoc sv_2pv_flags
2729
2730 Returns a pointer to the string value of an SV, and sets *lp to its length.
2731 If flags includes SV_GMAGIC, does an mg_get() first. Coerces sv to a string
2732 if necessary.
2733 Normally invoked via the C<SvPV_flags> macro. C<sv_2pv()> and C<sv_2pv_nomg>
2734 usually end up here too.
2735
2736 =cut
2737 */
2738
2739 char *
2740 Perl_sv_2pv_flags(pTHX_ register SV *const sv, STRLEN *const lp, const I32 flags)
2741 {
2742     dVAR;
2743     register char *s;
2744
2745     if (!sv) {
2746         if (lp)
2747             *lp = 0;
2748         return (char *)"";
2749     }
2750     if (SvGMAGICAL(sv)) {
2751         if (flags & SV_GMAGIC)
2752             mg_get(sv);
2753         if (SvPOKp(sv)) {
2754             if (lp)
2755                 *lp = SvCUR(sv);
2756             if (flags & SV_MUTABLE_RETURN)
2757                 return SvPVX_mutable(sv);
2758             if (flags & SV_CONST_RETURN)
2759                 return (char *)SvPVX_const(sv);
2760             return SvPVX(sv);
2761         }
2762         if (SvIOKp(sv) || SvNOKp(sv)) {
2763             char tbuf[64];  /* Must fit sprintf/Gconvert of longest IV/NV */
2764             STRLEN len;
2765
2766             if (SvIOKp(sv)) {
2767                 len = SvIsUV(sv)
2768                     ? my_snprintf(tbuf, sizeof(tbuf), "%"UVuf, (UV)SvUVX(sv))
2769                     : my_snprintf(tbuf, sizeof(tbuf), "%"IVdf, (IV)SvIVX(sv));
2770             } else {
2771                 Gconvert(SvNVX(sv), NV_DIG, 0, tbuf);
2772                 len = strlen(tbuf);
2773             }
2774             assert(!SvROK(sv));
2775             {
2776                 dVAR;
2777
2778 #ifdef FIXNEGATIVEZERO
2779                 if (len == 2 && tbuf[0] == '-' && tbuf[1] == '0') {
2780                     tbuf[0] = '0';
2781                     tbuf[1] = 0;
2782                     len = 1;
2783                 }
2784 #endif
2785                 SvUPGRADE(sv, SVt_PV);
2786                 if (lp)
2787                     *lp = len;
2788                 s = SvGROW_mutable(sv, len + 1);
2789                 SvCUR_set(sv, len);
2790                 SvPOKp_on(sv);
2791                 return (char*)memcpy(s, tbuf, len + 1);
2792             }
2793         }
2794         if (SvROK(sv)) {
2795             goto return_rok;
2796         }
2797         assert(SvTYPE(sv) >= SVt_PVMG);
2798         /* This falls through to the report_uninit near the end of the
2799            function. */
2800     } else if (SvTHINKFIRST(sv)) {
2801         if (SvROK(sv)) {
2802         return_rok:
2803             if (SvAMAGIC(sv)) {
2804                 SV *const tmpstr = AMG_CALLun(sv,string);
2805                 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2806                     /* Unwrap this:  */
2807                     /* char *pv = lp ? SvPV(tmpstr, *lp) : SvPV_nolen(tmpstr);
2808                      */
2809
2810                     char *pv;
2811                     if ((SvFLAGS(tmpstr) & (SVf_POK)) == SVf_POK) {
2812                         if (flags & SV_CONST_RETURN) {
2813                             pv = (char *) SvPVX_const(tmpstr);
2814                         } else {
2815                             pv = (flags & SV_MUTABLE_RETURN)
2816                                 ? SvPVX_mutable(tmpstr) : SvPVX(tmpstr);
2817                         }
2818                         if (lp)
2819                             *lp = SvCUR(tmpstr);
2820                     } else {
2821                         pv = sv_2pv_flags(tmpstr, lp, flags);
2822                     }
2823                     if (SvUTF8(tmpstr))
2824                         SvUTF8_on(sv);
2825                     else
2826                         SvUTF8_off(sv);
2827                     return pv;
2828                 }
2829             }
2830             {
2831                 STRLEN len;
2832                 char *retval;
2833                 char *buffer;
2834                 const SV *const referent = (SV*)SvRV(sv);
2835
2836                 if (!referent) {
2837                     len = 7;
2838                     retval = buffer = savepvn("NULLREF", len);
2839                 } else if (SvTYPE(referent) == SVt_REGEXP) {
2840                     const REGEXP * const re = (REGEXP *)referent;
2841                     I32 seen_evals = 0;
2842
2843                     assert(re);
2844
2845                     /* If the regex is UTF-8 we want the containing scalar to
2846                        have an UTF-8 flag too */
2847                     if (RX_UTF8(re))
2848                         SvUTF8_on(sv);
2849                     else
2850                         SvUTF8_off(sv);
2851
2852                     if ((seen_evals = RX_SEEN_EVALS(re)))
2853                         PL_reginterp_cnt += seen_evals;
2854
2855                     if (lp)
2856                         *lp = RX_WRAPLEN(re);
2857
2858                     return RX_WRAPPED(re);
2859                 } else {
2860                     const char *const typestr = sv_reftype(referent, 0);
2861                     const STRLEN typelen = strlen(typestr);
2862                     UV addr = PTR2UV(referent);
2863                     const char *stashname = NULL;
2864                     STRLEN stashnamelen = 0; /* hush, gcc */
2865                     const char *buffer_end;
2866
2867                     if (SvOBJECT(referent)) {
2868                         const HEK *const name = HvNAME_HEK(SvSTASH(referent));
2869
2870                         if (name) {
2871                             stashname = HEK_KEY(name);
2872                             stashnamelen = HEK_LEN(name);
2873
2874                             if (HEK_UTF8(name)) {
2875                                 SvUTF8_on(sv);
2876                             } else {
2877                                 SvUTF8_off(sv);
2878                             }
2879                         } else {
2880                             stashname = "__ANON__";
2881                             stashnamelen = 8;
2882                         }
2883                         len = stashnamelen + 1 /* = */ + typelen + 3 /* (0x */
2884                             + 2 * sizeof(UV) + 2 /* )\0 */;
2885                     } else {
2886                         len = typelen + 3 /* (0x */
2887                             + 2 * sizeof(UV) + 2 /* )\0 */;
2888                     }
2889
2890                     Newx(buffer, len, char);
2891                     buffer_end = retval = buffer + len;
2892
2893                     /* Working backwards  */
2894                     *--retval = '\0';
2895                     *--retval = ')';
2896                     do {
2897                         *--retval = PL_hexdigit[addr & 15];
2898                     } while (addr >>= 4);
2899                     *--retval = 'x';
2900                     *--retval = '0';
2901                     *--retval = '(';
2902
2903                     retval -= typelen;
2904                     memcpy(retval, typestr, typelen);
2905
2906                     if (stashname) {
2907                         *--retval = '=';
2908                         retval -= stashnamelen;
2909                         memcpy(retval, stashname, stashnamelen);
2910                     }
2911                     /* retval may not neccesarily have reached the start of the
2912                        buffer here.  */
2913                     assert (retval >= buffer);
2914
2915                     len = buffer_end - retval - 1; /* -1 for that \0  */
2916                 }
2917                 if (lp)
2918                     *lp = len;
2919                 SAVEFREEPV(buffer);
2920                 return retval;
2921             }
2922         }
2923         if (SvREADONLY(sv) && !SvOK(sv)) {
2924             if (lp)
2925                 *lp = 0;
2926             if (flags & SV_UNDEF_RETURNS_NULL)
2927                 return NULL;
2928             if (ckWARN(WARN_UNINITIALIZED))
2929                 report_uninit(sv);
2930             return (char *)"";
2931         }
2932     }
2933     if (SvIOK(sv) || ((SvIOKp(sv) && !SvNOKp(sv)))) {
2934         /* I'm assuming that if both IV and NV are equally valid then
2935            converting the IV is going to be more efficient */
2936         const U32 isUIOK = SvIsUV(sv);
2937         char buf[TYPE_CHARS(UV)];
2938         char *ebuf, *ptr;
2939         STRLEN len;
2940
2941         if (SvTYPE(sv) < SVt_PVIV)
2942             sv_upgrade(sv, SVt_PVIV);
2943         ptr = uiv_2buf(buf, SvIVX(sv), SvUVX(sv), isUIOK, &ebuf);
2944         len = ebuf - ptr;
2945         /* inlined from sv_setpvn */
2946         s = SvGROW_mutable(sv, len + 1);
2947         Move(ptr, s, len, char);
2948         s += len;
2949         *s = '\0';
2950     }
2951     else if (SvNOKp(sv)) {
2952         const int olderrno = errno;
2953         if (SvTYPE(sv) < SVt_PVNV)
2954             sv_upgrade(sv, SVt_PVNV);
2955         /* The +20 is pure guesswork.  Configure test needed. --jhi */
2956         s = SvGROW_mutable(sv, NV_DIG + 20);
2957         /* some Xenix systems wipe out errno here */
2958 #ifdef apollo
2959         if (SvNVX(sv) == 0.0)
2960             my_strlcpy(s, "0", SvLEN(sv));
2961         else
2962 #endif /*apollo*/
2963         {
2964             Gconvert(SvNVX(sv), NV_DIG, 0, s);
2965         }
2966         errno = olderrno;
2967 #ifdef FIXNEGATIVEZERO
2968         if (*s == '-' && s[1] == '0' && !s[2]) {
2969             s[0] = '0';
2970             s[1] = 0;
2971         }
2972 #endif
2973         while (*s) s++;
2974 #ifdef hcx
2975         if (s[-1] == '.')
2976             *--s = '\0';
2977 #endif
2978     }
2979     else {
2980         if (isGV_with_GP(sv))
2981             return glob_2pv((GV *)sv, lp);
2982
2983         if (lp)
2984             *lp = 0;
2985         if (flags & SV_UNDEF_RETURNS_NULL)
2986             return NULL;
2987         if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED))
2988             report_uninit(sv);
2989         if (SvTYPE(sv) < SVt_PV)
2990             /* Typically the caller expects that sv_any is not NULL now.  */
2991             sv_upgrade(sv, SVt_PV);
2992         return (char *)"";
2993     }
2994     {
2995         const STRLEN len = s - SvPVX_const(sv);
2996         if (lp)
2997             *lp = len;
2998         SvCUR_set(sv, len);
2999     }
3000     SvPOK_on(sv);
3001     DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
3002                           PTR2UV(sv),SvPVX_const(sv)));
3003     if (flags & SV_CONST_RETURN)
3004         return (char *)SvPVX_const(sv);
3005     if (flags & SV_MUTABLE_RETURN)
3006         return SvPVX_mutable(sv);
3007     return SvPVX(sv);
3008 }
3009
3010 /*
3011 =for apidoc sv_copypv
3012
3013 Copies a stringified representation of the source SV into the
3014 destination SV.  Automatically performs any necessary mg_get and
3015 coercion of numeric values into strings.  Guaranteed to preserve
3016 UTF8 flag even from overloaded objects.  Similar in nature to
3017 sv_2pv[_flags] but operates directly on an SV instead of just the
3018 string.  Mostly uses sv_2pv_flags to do its work, except when that
3019 would lose the UTF-8'ness of the PV.
3020
3021 =cut
3022 */
3023
3024 void
3025 Perl_sv_copypv(pTHX_ SV *const dsv, register SV *const ssv)
3026 {
3027     STRLEN len;
3028     const char * const s = SvPV_const(ssv,len);
3029
3030     PERL_ARGS_ASSERT_SV_COPYPV;
3031
3032     sv_setpvn(dsv,s,len);
3033     if (SvUTF8(ssv))
3034         SvUTF8_on(dsv);
3035     else
3036         SvUTF8_off(dsv);
3037 }
3038
3039 /*
3040 =for apidoc sv_2pvbyte
3041
3042 Return a pointer to the byte-encoded representation of the SV, and set *lp
3043 to its length.  May cause the SV to be downgraded from UTF-8 as a
3044 side-effect.
3045
3046 Usually accessed via the C<SvPVbyte> macro.
3047
3048 =cut
3049 */
3050
3051 char *
3052 Perl_sv_2pvbyte(pTHX_ register SV *const sv, STRLEN *const lp)
3053 {
3054     PERL_ARGS_ASSERT_SV_2PVBYTE;
3055
3056     sv_utf8_downgrade(sv,0);
3057     return lp ? SvPV(sv,*lp) : SvPV_nolen(sv);
3058 }
3059
3060 /*
3061 =for apidoc sv_2pvutf8
3062
3063 Return a pointer to the UTF-8-encoded representation of the SV, and set *lp
3064 to its length.  May cause the SV to be upgraded to UTF-8 as a side-effect.
3065
3066 Usually accessed via the C<SvPVutf8> macro.
3067
3068 =cut
3069 */
3070
3071 char *
3072 Perl_sv_2pvutf8(pTHX_ register SV *const sv, STRLEN *const lp)
3073 {
3074     PERL_ARGS_ASSERT_SV_2PVUTF8;
3075
3076     sv_utf8_upgrade(sv);
3077     return lp ? SvPV(sv,*lp) : SvPV_nolen(sv);
3078 }
3079
3080
3081 /*
3082 =for apidoc sv_2bool
3083
3084 This function is only called on magical items, and is only used by
3085 sv_true() or its macro equivalent.
3086
3087 =cut
3088 */
3089
3090 bool
3091 Perl_sv_2bool(pTHX_ register SV *const sv)
3092 {
3093     dVAR;
3094
3095     PERL_ARGS_ASSERT_SV_2BOOL;
3096
3097     SvGETMAGIC(sv);
3098
3099     if (!SvOK(sv))
3100         return 0;
3101     if (SvROK(sv)) {
3102         if (SvAMAGIC(sv)) {
3103             SV * const tmpsv = AMG_CALLun(sv,bool_);
3104             if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
3105                 return (bool)SvTRUE(tmpsv);
3106         }
3107         return SvRV(sv) != 0;
3108     }
3109     if (SvPOKp(sv)) {
3110         register XPV* const Xpvtmp = (XPV*)SvANY(sv);
3111         if (Xpvtmp &&
3112                 (*sv->sv_u.svu_pv > '0' ||
3113                 Xpvtmp->xpv_cur > 1 ||
3114                 (Xpvtmp->xpv_cur && *sv->sv_u.svu_pv != '0')))
3115             return 1;
3116         else
3117             return 0;
3118     }
3119     else {
3120         if (SvIOKp(sv))
3121             return SvIVX(sv) != 0;
3122         else {
3123             if (SvNOKp(sv))
3124                 return SvNVX(sv) != 0.0;
3125             else {
3126                 if (isGV_with_GP(sv))
3127                     return TRUE;
3128                 else
3129                     return FALSE;
3130             }
3131         }
3132     }
3133 }
3134
3135 /*
3136 =for apidoc sv_utf8_upgrade
3137
3138 Converts the PV of an SV to its UTF-8-encoded form.
3139 Forces the SV to string form if it is not already.
3140 Always sets the SvUTF8 flag to avoid future validity checks even
3141 if all the bytes have hibit clear.
3142
3143 This is not as a general purpose byte encoding to Unicode interface:
3144 use the Encode extension for that.
3145
3146 =for apidoc sv_utf8_upgrade_flags
3147
3148 Converts the PV of an SV to its UTF-8-encoded form.
3149 Forces the SV to string form if it is not already.
3150 Always sets the SvUTF8 flag to avoid future validity checks even
3151 if all the bytes have hibit clear. If C<flags> has C<SV_GMAGIC> bit set,
3152 will C<mg_get> on C<sv> if appropriate, else not. C<sv_utf8_upgrade> and
3153 C<sv_utf8_upgrade_nomg> are implemented in terms of this function.
3154
3155 This is not as a general purpose byte encoding to Unicode interface:
3156 use the Encode extension for that.
3157
3158 =cut
3159 */
3160
3161 STRLEN
3162 Perl_sv_utf8_upgrade_flags(pTHX_ register SV *const sv, const I32 flags)
3163 {
3164     dVAR;
3165
3166     PERL_ARGS_ASSERT_SV_UTF8_UPGRADE_FLAGS;
3167
3168     if (sv == &PL_sv_undef)
3169         return 0;
3170     if (!SvPOK(sv)) {
3171         STRLEN len = 0;
3172         if (SvREADONLY(sv) && (SvPOKp(sv) || SvIOKp(sv) || SvNOKp(sv))) {
3173             (void) sv_2pv_flags(sv,&len, flags);
3174             if (SvUTF8(sv))
3175                 return len;
3176         } else {
3177             (void) SvPV_force(sv,len);
3178         }
3179     }
3180
3181     if (SvUTF8(sv)) {
3182         return SvCUR(sv);
3183     }
3184
3185     if (SvIsCOW(sv)) {
3186         sv_force_normal_flags(sv, 0);
3187     }
3188
3189     if (PL_encoding && !(flags & SV_UTF8_NO_ENCODING))
3190         sv_recode_to_utf8(sv, PL_encoding);
3191     else { /* Assume Latin-1/EBCDIC */
3192         /* This function could be much more efficient if we
3193          * had a FLAG in SVs to signal if there are any hibit
3194          * chars in the PV.  Given that there isn't such a flag
3195          * make the loop as fast as possible. */
3196         const U8 * const s = (U8 *) SvPVX_const(sv);
3197         const U8 * const e = (U8 *) SvEND(sv);
3198         const U8 *t = s;
3199
3200         while (t < e) {
3201             const U8 ch = *t++;
3202             /* Check for hi bit */
3203             if (!NATIVE_IS_INVARIANT(ch)) {
3204                 STRLEN len = SvCUR(sv);
3205                 /* *Currently* bytes_to_utf8() adds a '\0' after every string
3206                    it converts. This isn't documented. It's not clear if it's
3207                    a bad thing to be doing, and should be changed to do exactly
3208                    what the documentation says. If so, this code will have to
3209                    be changed.
3210                    As is, we mustn't rely on our incoming SV being well formed
3211                    and having a trailing '\0', as certain code in pp_formline
3212                    can send us partially built SVs. */
3213                 U8 * const recoded = bytes_to_utf8((U8*)s, &len);
3214
3215                 SvPV_free(sv); /* No longer using what was there before. */
3216                 SvPV_set(sv, (char*)recoded);
3217                 SvCUR_set(sv, len);
3218                 SvLEN_set(sv, len + 1); /* No longer know the real size. */
3219                 break;
3220             }
3221         }
3222         /* Mark as UTF-8 even if no hibit - saves scanning loop */
3223         SvUTF8_on(sv);
3224     }
3225     return SvCUR(sv);
3226 }
3227
3228 /*
3229 =for apidoc sv_utf8_downgrade
3230
3231 Attempts to convert the PV of an SV from characters to bytes.
3232 If the PV contains a character beyond byte, this conversion will fail;
3233 in this case, either returns false or, if C<fail_ok> is not
3234 true, croaks.
3235
3236 This is not as a general purpose Unicode to byte encoding interface:
3237 use the Encode extension for that.
3238
3239 =cut
3240 */
3241
3242 bool
3243 Perl_sv_utf8_downgrade(pTHX_ register SV *const sv, const bool fail_ok)
3244 {
3245     dVAR;
3246
3247     PERL_ARGS_ASSERT_SV_UTF8_DOWNGRADE;
3248
3249     if (SvPOKp(sv) && SvUTF8(sv)) {
3250         if (SvCUR(sv)) {
3251             U8 *s;
3252             STRLEN len;
3253
3254             if (SvIsCOW(sv)) {
3255                 sv_force_normal_flags(sv, 0);
3256             }
3257             s = (U8 *) SvPV(sv, len);
3258             if (!utf8_to_bytes(s, &len)) {
3259                 if (fail_ok)
3260                     return FALSE;
3261                 else {
3262                     if (PL_op)
3263                         Perl_croak(aTHX_ "Wide character in %s",
3264                                    OP_DESC(PL_op));
3265                     else
3266                         Perl_croak(aTHX_ "Wide character");
3267                 }
3268             }
3269             SvCUR_set(sv, len);
3270         }
3271     }
3272     SvUTF8_off(sv);
3273     return TRUE;
3274 }
3275
3276 /*
3277 =for apidoc sv_utf8_encode
3278
3279 Converts the PV of an SV to UTF-8, but then turns the C<SvUTF8>
3280 flag off so that it looks like octets again.
3281
3282 =cut
3283 */
3284
3285 void
3286 Perl_sv_utf8_encode(pTHX_ register SV *const sv)
3287 {
3288     PERL_ARGS_ASSERT_SV_UTF8_ENCODE;
3289
3290     if (SvIsCOW(sv)) {
3291         sv_force_normal_flags(sv, 0);
3292     }
3293     if (SvREADONLY(sv)) {
3294         Perl_croak(aTHX_ PL_no_modify);
3295     }
3296     (void) sv_utf8_upgrade(sv);
3297     SvUTF8_off(sv);
3298 }
3299
3300 /*
3301 =for apidoc sv_utf8_decode
3302
3303 If the PV of the SV is an octet sequence in UTF-8
3304 and contains a multiple-byte character, the C<SvUTF8> flag is turned on
3305 so that it looks like a character. If the PV contains only single-byte
3306 characters, the C<SvUTF8> flag stays being off.
3307 Scans PV for validity and returns false if the PV is invalid UTF-8.
3308
3309 =cut
3310 */
3311
3312 bool
3313 Perl_sv_utf8_decode(pTHX_ register SV *const sv)
3314 {
3315     PERL_ARGS_ASSERT_SV_UTF8_DECODE;
3316
3317     if (SvPOKp(sv)) {
3318         const U8 *c;
3319         const U8 *e;
3320
3321         /* The octets may have got themselves encoded - get them back as
3322          * bytes
3323          */
3324         if (!sv_utf8_downgrade(sv, TRUE))
3325             return FALSE;
3326
3327         /* it is actually just a matter of turning the utf8 flag on, but
3328          * we want to make sure everything inside is valid utf8 first.
3329          */
3330         c = (const U8 *) SvPVX_const(sv);
3331         if (!is_utf8_string(c, SvCUR(sv)+1))
3332             return FALSE;
3333         e = (const U8 *) SvEND(sv);
3334         while (c < e) {
3335             const U8 ch = *c++;
3336             if (!UTF8_IS_INVARIANT(ch)) {
3337                 SvUTF8_on(sv);
3338                 break;
3339             }
3340         }
3341     }
3342     return TRUE;
3343 }
3344
3345 /*
3346 =for apidoc sv_setsv
3347
3348 Copies the contents of the source SV C<ssv> into the destination SV
3349 C<dsv>.  The source SV may be destroyed if it is mortal, so don't use this
3350 function if the source SV needs to be reused. Does not handle 'set' magic.
3351 Loosely speaking, it performs a copy-by-value, obliterating any previous
3352 content of the destination.
3353
3354 You probably want to use one of the assortment of wrappers, such as
3355 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3356 C<SvSetMagicSV_nosteal>.
3357
3358 =for apidoc sv_setsv_flags
3359
3360 Copies the contents of the source SV C<ssv> into the destination SV
3361 C<dsv>.  The source SV may be destroyed if it is mortal, so don't use this
3362 function if the source SV needs to be reused. Does not handle 'set' magic.
3363 Loosely speaking, it performs a copy-by-value, obliterating any previous
3364 content of the destination.
3365 If the C<flags> parameter has the C<SV_GMAGIC> bit set, will C<mg_get> on
3366 C<ssv> if appropriate, else not. If the C<flags> parameter has the
3367 C<NOSTEAL> bit set then the buffers of temps will not be stolen. <sv_setsv>
3368 and C<sv_setsv_nomg> are implemented in terms of this function.
3369
3370 You probably want to use one of the assortment of wrappers, such as
3371 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3372 C<SvSetMagicSV_nosteal>.
3373
3374 This is the primary function for copying scalars, and most other
3375 copy-ish functions and macros use this underneath.
3376
3377 =cut
3378 */
3379
3380 static void
3381 S_glob_assign_glob(pTHX_ SV *const dstr, SV *const sstr, const int dtype)
3382 {
3383     I32 mro_changes = 0; /* 1 = method, 2 = isa */
3384
3385     PERL_ARGS_ASSERT_GLOB_ASSIGN_GLOB;
3386
3387     if (dtype != SVt_PVGV) {
3388         const char * const name = GvNAME(sstr);
3389         const STRLEN len = GvNAMELEN(sstr);
3390         {
3391             if (dtype >= SVt_PV) {
3392                 SvPV_free(dstr);
3393                 SvPV_set(dstr, 0);
3394                 SvLEN_set(dstr, 0);
3395                 SvCUR_set(dstr, 0);
3396             }
3397             SvUPGRADE(dstr, SVt_PVGV);
3398             (void)SvOK_off(dstr);
3399             /* FIXME - why are we doing this, then turning it off and on again
3400                below?  */
3401             isGV_with_GP_on(dstr);
3402         }
3403         GvSTASH(dstr) = GvSTASH(sstr);
3404         if (GvSTASH(dstr))
3405             Perl_sv_add_backref(aTHX_ (SV*)GvSTASH(dstr), dstr);
3406         gv_name_set((GV *)dstr, name, len, GV_ADD);
3407         SvFAKE_on(dstr);        /* can coerce to non-glob */
3408     }
3409
3410 #ifdef GV_UNIQUE_CHECK
3411     if (GvUNIQUE((GV*)dstr)) {
3412         Perl_croak(aTHX_ PL_no_modify);
3413     }
3414 #endif
3415
3416     if(GvGP((GV*)sstr)) {
3417         /* If source has method cache entry, clear it */
3418         if(GvCVGEN(sstr)) {
3419             SvREFCNT_dec(GvCV(sstr));
3420             GvCV(sstr) = NULL;
3421             GvCVGEN(sstr) = 0;
3422         }
3423         /* If source has a real method, then a method is
3424            going to change */
3425         else if(GvCV((GV*)sstr)) {
3426             mro_changes = 1;
3427         }
3428     }
3429
3430     /* If dest already had a real method, that's a change as well */
3431     if(!mro_changes && GvGP((GV*)dstr) && GvCVu((GV*)dstr)) {
3432         mro_changes = 1;
3433     }
3434
3435     if(strEQ(GvNAME((GV*)dstr),"ISA"))
3436         mro_changes = 2;
3437
3438     gp_free((GV*)dstr);
3439     isGV_with_GP_off(dstr);
3440     (void)SvOK_off(dstr);
3441     isGV_with_GP_on(dstr);
3442     GvINTRO_off(dstr);          /* one-shot flag */
3443     GvGP(dstr) = gp_ref(GvGP(sstr));
3444     if (SvTAINTED(sstr))
3445         SvTAINT(dstr);
3446     if (GvIMPORTED(dstr) != GVf_IMPORTED
3447         && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3448         {
3449             GvIMPORTED_on(dstr);
3450         }
3451     GvMULTI_on(dstr);
3452     if(mro_changes == 2) mro_isa_changed_in(GvSTASH(dstr));
3453     else if(mro_changes) mro_method_changed_in(GvSTASH(dstr));
3454     return;
3455 }
3456
3457 static void
3458 S_glob_assign_ref(pTHX_ SV *const dstr, SV *const sstr)
3459 {
3460     SV * const sref = SvREFCNT_inc(SvRV(sstr));
3461     SV *dref = NULL;
3462     const int intro = GvINTRO(dstr);
3463     SV **location;
3464     U8 import_flag = 0;
3465     const U32 stype = SvTYPE(sref);
3466
3467     PERL_ARGS_ASSERT_GLOB_ASSIGN_REF;
3468
3469 #ifdef GV_UNIQUE_CHECK
3470     if (GvUNIQUE((GV*)dstr)) {
3471         Perl_croak(aTHX_ PL_no_modify);
3472     }
3473 #endif
3474
3475     if (intro) {
3476         GvINTRO_off(dstr);      /* one-shot flag */
3477         GvLINE(dstr) = CopLINE(PL_curcop);
3478         GvEGV(dstr) = (GV*)dstr;
3479     }
3480     GvMULTI_on(dstr);
3481     switch (stype) {
3482     case SVt_PVCV:
3483         location = (SV **) &GvCV(dstr);
3484         import_flag = GVf_IMPORTED_CV;
3485         goto common;
3486     case SVt_PVHV:
3487         location = (SV **) &GvHV(dstr);
3488         import_flag = GVf_IMPORTED_HV;
3489         goto common;
3490     case SVt_PVAV:
3491         location = (SV **) &GvAV(dstr);
3492         import_flag = GVf_IMPORTED_AV;
3493         goto common;
3494     case SVt_PVIO:
3495         location = (SV **) &GvIOp(dstr);
3496         goto common;
3497     case SVt_PVFM:
3498         location = (SV **) &GvFORM(dstr);
3499     default:
3500         location = &GvSV(dstr);
3501         import_flag = GVf_IMPORTED_SV;
3502     common:
3503         if (intro) {
3504             if (stype == SVt_PVCV) {
3505                 /*if (GvCVGEN(dstr) && (GvCV(dstr) != (const CV *)sref || GvCVGEN(dstr))) {*/
3506                 if (GvCVGEN(dstr)) {
3507                     SvREFCNT_dec(GvCV(dstr));
3508                     GvCV(dstr) = NULL;
3509                     GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3510                 }
3511             }
3512             SAVEGENERICSV(*location);
3513         }
3514         else
3515             dref = *location;
3516         if (stype == SVt_PVCV && (*location != sref || GvCVGEN(dstr))) {
3517             CV* const cv = MUTABLE_CV(*location);
3518             if (cv) {
3519                 if (!GvCVGEN((GV*)dstr) &&
3520                     (CvROOT(cv) || CvXSUB(cv)))
3521                     {
3522                         /* Redefining a sub - warning is mandatory if
3523                            it was a const and its value changed. */
3524                         if (CvCONST(cv) && CvCONST((const CV *)sref)
3525                             && cv_const_sv(cv)
3526                             == cv_const_sv((const CV *)sref)) {
3527                             NOOP;
3528                             /* They are 2 constant subroutines generated from
3529                                the same constant. This probably means that
3530                                they are really the "same" proxy subroutine
3531                                instantiated in 2 places. Most likely this is
3532                                when a constant is exported twice.  Don't warn.
3533                             */
3534                         }
3535                         else if (ckWARN(WARN_REDEFINE)
3536                                  || (CvCONST(cv)
3537                                      && (!CvCONST((const CV *)sref)
3538                                          || sv_cmp(cv_const_sv(cv),
3539                                                    cv_const_sv((const CV *)
3540                                                                sref))))) {
3541                             Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
3542                                         (const char *)
3543                                         (CvCONST(cv)
3544                                          ? "Constant subroutine %s::%s redefined"
3545                                          : "Subroutine %s::%s redefined"),
3546                                         HvNAME_get(GvSTASH((GV*)dstr)),
3547                                         GvENAME((GV*)dstr));
3548                         }
3549                     }
3550                 if (!intro)
3551                     cv_ckproto_len(cv, (GV*)dstr,
3552                                    SvPOK(sref) ? SvPVX_const(sref) : NULL,
3553                                    SvPOK(sref) ? SvCUR(sref) : 0);
3554             }
3555             GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3556             GvASSUMECV_on(dstr);
3557             if(GvSTASH(dstr)) mro_method_changed_in(GvSTASH(dstr)); /* sub foo { 1 } sub bar { 2 } *bar = \&foo */
3558         }
3559         *location = sref;
3560         if (import_flag && !(GvFLAGS(dstr) & import_flag)
3561             && CopSTASH_ne(PL_curcop, GvSTASH(dstr))) {
3562             GvFLAGS(dstr) |= import_flag;
3563         }
3564         break;
3565     }
3566     SvREFCNT_dec(dref);
3567     if (SvTAINTED(sstr))
3568         SvTAINT(dstr);
3569     return;
3570 }
3571
3572 void
3573 Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV* sstr, const I32 flags)
3574 {
3575     dVAR;
3576     register U32 sflags;
3577     register int dtype;
3578     register svtype stype;
3579
3580     PERL_ARGS_ASSERT_SV_SETSV_FLAGS;
3581
3582     if (sstr == dstr)
3583         return;
3584
3585     if (SvIS_FREED(dstr)) {
3586         Perl_croak(aTHX_ "panic: attempt to copy value %" SVf
3587                    " to a freed scalar %p", SVfARG(sstr), (void *)dstr);
3588     }
3589     SV_CHECK_THINKFIRST_COW_DROP(dstr);
3590     if (!sstr)
3591         sstr = &PL_sv_undef;
3592     if (SvIS_FREED(sstr)) {
3593         Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p to %p",
3594                    (void*)sstr, (void*)dstr);
3595     }
3596     stype = SvTYPE(sstr);
3597     dtype = SvTYPE(dstr);
3598
3599     (void)SvAMAGIC_off(dstr);
3600     if ( SvVOK(dstr) )
3601     {
3602         /* need to nuke the magic */
3603         mg_free(dstr);
3604     }
3605
3606     /* There's a lot of redundancy below but we're going for speed here */
3607
3608     switch (stype) {
3609     case SVt_NULL:
3610       undef_sstr:
3611         if (dtype != SVt_PVGV) {
3612             (void)SvOK_off(dstr);
3613             return;
3614         }
3615         break;
3616     case SVt_IV:
3617         if (SvIOK(sstr)) {
3618             switch (dtype) {
3619             case SVt_NULL:
3620                 sv_upgrade(dstr, SVt_IV);
3621                 break;
3622             case SVt_NV:
3623             case SVt_PV:
3624                 sv_upgrade(dstr, SVt_PVIV);
3625                 break;
3626             case SVt_PVGV:
3627                 goto end_of_first_switch;
3628             }
3629             (void)SvIOK_only(dstr);
3630             SvIV_set(dstr,  SvIVX(sstr));
3631             if (SvIsUV(sstr))
3632                 SvIsUV_on(dstr);
3633             /* SvTAINTED can only be true if the SV has taint magic, which in
3634                turn means that the SV type is PVMG (or greater). This is the
3635                case statement for SVt_IV, so this cannot be true (whatever gcov
3636                may say).  */
3637             assert(!SvTAINTED(sstr));
3638             return;
3639         }
3640         if (!SvROK(sstr))
3641             goto undef_sstr;
3642         if (dtype < SVt_PV && dtype != SVt_IV)
3643             sv_upgrade(dstr, SVt_IV);
3644         break;
3645
3646     case SVt_NV:
3647         if (SvNOK(sstr)) {
3648             switch (dtype) {
3649             case SVt_NULL:
3650             case SVt_IV:
3651                 sv_upgrade(dstr, SVt_NV);
3652                 break;
3653             case SVt_PV:
3654             case SVt_PVIV:
3655                 sv_upgrade(dstr, SVt_PVNV);
3656                 break;
3657             case SVt_PVGV:
3658                 goto end_of_first_switch;
3659             }
3660             SvNV_set(dstr, SvNVX(sstr));
3661             (void)SvNOK_only(dstr);
3662             /* SvTAINTED can only be true if the SV has taint magic, which in
3663                turn means that the SV type is PVMG (or greater). This is the
3664                case statement for SVt_NV, so this cannot be true (whatever gcov
3665                may say).  */
3666             assert(!SvTAINTED(sstr));
3667             return;
3668         }
3669         goto undef_sstr;
3670
3671     case SVt_PVFM:
3672 #ifdef PERL_OLD_COPY_ON_WRITE
3673         if ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS) {
3674             if (dtype < SVt_PVIV)
3675                 sv_upgrade(dstr, SVt_PVIV);
3676             break;
3677         }
3678         /* Fall through */
3679 #endif
3680     case SVt_REGEXP:
3681     case SVt_PV:
3682         if (dtype < SVt_PV)
3683             sv_upgrade(dstr, SVt_PV);
3684         break;
3685     case SVt_PVIV:
3686         if (dtype < SVt_PVIV)
3687             sv_upgrade(dstr, SVt_PVIV);
3688         break;
3689     case SVt_PVNV:
3690         if (dtype < SVt_PVNV)
3691             sv_upgrade(dstr, SVt_PVNV);
3692         break;
3693     default:
3694         {
3695         const char * const type = sv_reftype(sstr,0);
3696         if (PL_op)
3697             Perl_croak(aTHX_ "Bizarre copy of %s in %s", type, OP_NAME(PL_op));
3698         else
3699             Perl_croak(aTHX_ "Bizarre copy of %s", type);
3700         }
3701         break;
3702
3703         /* case SVt_BIND: */
3704     case SVt_PVLV:
3705     case SVt_PVGV:
3706         if (isGV_with_GP(sstr) && dtype <= SVt_PVGV) {
3707             glob_assign_glob(dstr, sstr, dtype);
3708             return;
3709         }
3710         /* SvVALID means that this PVGV is playing at being an FBM.  */
3711         /*FALLTHROUGH*/
3712
3713     case SVt_PVMG:
3714         if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) {
3715             mg_get(sstr);
3716             if (SvTYPE(sstr) != stype) {
3717                 stype = SvTYPE(sstr);
3718                 if (isGV_with_GP(sstr) && stype == SVt_PVGV && dtype <= SVt_PVGV) {
3719                     glob_assign_glob(dstr, sstr, dtype);
3720                     return;
3721                 }
3722             }
3723         }
3724         if (stype == SVt_PVLV)
3725             SvUPGRADE(dstr, SVt_PVNV);
3726         else
3727             SvUPGRADE(dstr, (svtype)stype);
3728     }
3729  end_of_first_switch:
3730
3731     /* dstr may have been upgraded.  */
3732     dtype = SvTYPE(dstr);
3733     sflags = SvFLAGS(sstr);
3734
3735     if (dtype == SVt_PVCV || dtype == SVt_PVFM) {
3736         /* Assigning to a subroutine sets the prototype.  */
3737         if (SvOK(sstr)) {
3738             STRLEN len;
3739             const char *const ptr = SvPV_const(sstr, len);
3740
3741             SvGROW(dstr, len + 1);
3742             Copy(ptr, SvPVX(dstr), len + 1, char);
3743             SvCUR_set(dstr, len);
3744             SvPOK_only(dstr);
3745             SvFLAGS(dstr) |= sflags & SVf_UTF8;
3746         } else {
3747             SvOK_off(dstr);
3748         }
3749     } else if (dtype == SVt_PVAV || dtype == SVt_PVHV) {
3750         const char * const type = sv_reftype(dstr,0);
3751         if (PL_op)
3752             Perl_croak(aTHX_ "Cannot copy to %s in %s", type, OP_NAME(PL_op));
3753         else
3754             Perl_croak(aTHX_ "Cannot copy to %s", type);
3755     } else if (sflags & SVf_ROK) {
3756         if (isGV_with_GP(dstr) && dtype == SVt_PVGV
3757             && SvTYPE(SvRV(sstr)) == SVt_PVGV && isGV_with_GP(SvRV(sstr))) {
3758             sstr = SvRV(sstr);
3759             if (sstr == dstr) {
3760                 if (GvIMPORTED(dstr) != GVf_IMPORTED
3761                     && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3762                 {
3763                     GvIMPORTED_on(dstr);
3764                 }
3765                 GvMULTI_on(dstr);
3766                 return;
3767             }
3768             glob_assign_glob(dstr, sstr, dtype);
3769             return;
3770         }
3771
3772         if (dtype >= SVt_PV) {
3773             if (dtype == SVt_PVGV && isGV_with_GP(dstr)) {
3774                 glob_assign_ref(dstr, sstr);
3775                 return;
3776             }
3777             if (SvPVX_const(dstr)) {
3778                 SvPV_free(dstr);
3779                 SvLEN_set(dstr, 0);
3780                 SvCUR_set(dstr, 0);
3781             }
3782         }
3783         (void)SvOK_off(dstr);
3784         SvRV_set(dstr, SvREFCNT_inc(SvRV(sstr)));
3785         SvFLAGS(dstr) |= sflags & SVf_ROK;
3786         assert(!(sflags & SVp_NOK));
3787         assert(!(sflags & SVp_IOK));
3788         assert(!(sflags & SVf_NOK));
3789         assert(!(sflags & SVf_IOK));
3790     }
3791     else if (dtype == SVt_PVGV && isGV_with_GP(dstr)) {
3792         if (!(sflags & SVf_OK)) {
3793             if (ckWARN(WARN_MISC))
3794                 Perl_warner(aTHX_ packWARN(WARN_MISC),
3795                             "Undefined value assigned to typeglob");
3796         }
3797         else {
3798             GV *gv = gv_fetchsv(sstr, GV_ADD, SVt_PVGV);
3799             if (dstr != (SV*)gv) {
3800                 if (GvGP(dstr))
3801                     gp_free((GV*)dstr);
3802                 GvGP(dstr) = gp_ref(GvGP(gv));
3803             }
3804         }
3805     }
3806     else if (sflags & SVp_POK) {
3807         bool isSwipe = 0;
3808
3809         /*
3810          * Check to see if we can just swipe the string.  If so, it's a
3811          * possible small lose on short strings, but a big win on long ones.
3812          * It might even be a win on short strings if SvPVX_const(dstr)
3813          * has to be allocated and SvPVX_const(sstr) has to be freed.
3814          * Likewise if we can set up COW rather than doing an actual copy, we
3815          * drop to the else clause, as the swipe code and the COW setup code
3816          * have much in common.
3817          */
3818
3819         /* Whichever path we take through the next code, we want this true,
3820            and doing it now facilitates the COW check.  */
3821         (void)SvPOK_only(dstr);
3822
3823         if (
3824             /* If we're already COW then this clause is not true, and if COW
3825                is allowed then we drop down to the else and make dest COW
3826                with us.  If caller hasn't said that we're allowed to COW
3827                shared hash keys then we don't do the COW setup, even if the
3828                source scalar is a shared hash key scalar.  */
3829             (((flags & SV_COW_SHARED_HASH_KEYS)
3830                ? (sflags & (SVf_FAKE|SVf_READONLY)) != (SVf_FAKE|SVf_READONLY)
3831                : 1 /* If making a COW copy is forbidden then the behaviour we
3832                        desire is as if the source SV isn't actually already
3833                        COW, even if it is.  So we act as if the source flags
3834                        are not COW, rather than actually testing them.  */
3835               )
3836 #ifndef PERL_OLD_COPY_ON_WRITE
3837              /* The change that added SV_COW_SHARED_HASH_KEYS makes the logic
3838                 when PERL_OLD_COPY_ON_WRITE is defined a little wrong.
3839                 Conceptually PERL_OLD_COPY_ON_WRITE being defined should
3840                 override SV_COW_SHARED_HASH_KEYS, because it means "always COW"
3841                 but in turn, it's somewhat dead code, never expected to go
3842                 live, but more kept as a placeholder on how to do it better
3843                 in a newer implementation.  */
3844              /* If we are COW and dstr is a suitable target then we drop down
3845                 into the else and make dest a COW of us.  */
3846              || (SvFLAGS(dstr) & CAN_COW_MASK) != CAN_COW_FLAGS
3847 #endif
3848              )
3849             &&
3850             !(isSwipe =
3851                  (sflags & SVs_TEMP) &&   /* slated for free anyway? */
3852                  !(sflags & SVf_OOK) &&   /* and not involved in OOK hack? */
3853                  (!(flags & SV_NOSTEAL)) &&
3854                                         /* and we're allowed to steal temps */
3855                  SvREFCNT(sstr) == 1 &&   /* and no other references to it? */
3856                  SvLEN(sstr)    &&        /* and really is a string */
3857                                 /* and won't be needed again, potentially */
3858               !(PL_op && PL_op->op_type == OP_AASSIGN))
3859 #ifdef PERL_OLD_COPY_ON_WRITE
3860             && ((flags & SV_COW_SHARED_HASH_KEYS)
3861                 ? (!((sflags & CAN_COW_MASK) == CAN_COW_FLAGS
3862                      && (SvFLAGS(dstr) & CAN_COW_MASK) == CAN_COW_FLAGS
3863                      && SvTYPE(sstr) >= SVt_PVIV))
3864                 : 1)
3865 #endif
3866             ) {
3867             /* Failed the swipe test, and it's not a shared hash key either.
3868                Have to copy the string.  */
3869             STRLEN len = SvCUR(sstr);
3870             SvGROW(dstr, len + 1);      /* inlined from sv_setpvn */
3871             Move(SvPVX_const(sstr),SvPVX(dstr),len,char);
3872             SvCUR_set(dstr, len);
3873             *SvEND(dstr) = '\0';
3874         } else {
3875             /* If PERL_OLD_COPY_ON_WRITE is not defined, then isSwipe will always
3876                be true in here.  */
3877             /* Either it's a shared hash key, or it's suitable for
3878                copy-on-write or we can swipe the string.  */
3879             if (DEBUG_C_TEST) {
3880                 PerlIO_printf(Perl_debug_log, "Copy on write: sstr --> dstr\n");
3881                 sv_dump(sstr);
3882                 sv_dump(dstr);
3883             }
3884 #ifdef PERL_OLD_COPY_ON_WRITE
3885             if (!isSwipe) {
3886                 /* I believe I should acquire a global SV mutex if
3887                    it's a COW sv (not a shared hash key) to stop
3888                    it going un copy-on-write.
3889                    If the source SV has gone un copy on write between up there
3890                    and down here, then (assert() that) it is of the correct
3891                    form to make it copy on write again */
3892                 if ((sflags & (SVf_FAKE | SVf_READONLY))
3893                     != (SVf_FAKE | SVf_READONLY)) {
3894                     SvREADONLY_on(sstr);
3895                     SvFAKE_on(sstr);
3896                     /* Make the source SV into a loop of 1.
3897                        (about to become 2) */
3898                     SV_COW_NEXT_SV_SET(sstr, sstr);
3899                 }
3900             }
3901 #endif
3902             /* Initial code is common.  */
3903             if (SvPVX_const(dstr)) {    /* we know that dtype >= SVt_PV */
3904                 SvPV_free(dstr);
3905             }
3906
3907             if (!isSwipe) {
3908                 /* making another shared SV.  */
3909                 STRLEN cur = SvCUR(sstr);
3910                 STRLEN len = SvLEN(sstr);
3911 #ifdef PERL_OLD_COPY_ON_WRITE
3912                 if (len) {
3913                     assert (SvTYPE(dstr) >= SVt_PVIV);
3914                     /* SvIsCOW_normal */
3915                     /* splice us in between source and next-after-source.  */
3916                     SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
3917                     SV_COW_NEXT_SV_SET(sstr, dstr);
3918                     SvPV_set(dstr, SvPVX_mutable(sstr));
3919                 } else
3920 #endif
3921                 {
3922                     /* SvIsCOW_shared_hash */
3923                     DEBUG_C(PerlIO_printf(Perl_debug_log,
3924                                           "Copy on write: Sharing hash\n"));
3925
3926                     assert (SvTYPE(dstr) >= SVt_PV);
3927                     SvPV_set(dstr,
3928                              HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr)))));
3929                 }
3930                 SvLEN_set(dstr, len);
3931                 SvCUR_set(dstr, cur);
3932                 SvREADONLY_on(dstr);
3933                 SvFAKE_on(dstr);
3934                 /* Relesase a global SV mutex.  */
3935             }
3936             else
3937                 {       /* Passes the swipe test.  */
3938                 SvPV_set(dstr, SvPVX_mutable(sstr));
3939                 SvLEN_set(dstr, SvLEN(sstr));
3940                 SvCUR_set(dstr, SvCUR(sstr));
3941
3942                 SvTEMP_off(dstr);
3943                 (void)SvOK_off(sstr);   /* NOTE: nukes most SvFLAGS on sstr */
3944                 SvPV_set(sstr, NULL);
3945                 SvLEN_set(sstr, 0);
3946                 SvCUR_set(sstr, 0);
3947                 SvTEMP_off(sstr);
3948             }
3949         }
3950         if (sflags & SVp_NOK) {
3951             SvNV_set(dstr, SvNVX(sstr));
3952         }
3953         if (sflags & SVp_IOK) {
3954             SvIV_set(dstr, SvIVX(sstr));
3955             /* Must do this otherwise some other overloaded use of 0x80000000
3956                gets confused. I guess SVpbm_VALID */
3957             if (sflags & SVf_IVisUV)
3958                 SvIsUV_on(dstr);
3959         }
3960         SvFLAGS(dstr) |= sflags & (SVf_IOK|SVp_IOK|SVf_NOK|SVp_NOK|SVf_UTF8);
3961         {
3962             const MAGIC * const smg = SvVSTRING_mg(sstr);
3963             if (smg) {
3964                 sv_magic(dstr, NULL, PERL_MAGIC_vstring,
3965                          smg->mg_ptr, smg->mg_len);
3966                 SvRMAGICAL_on(dstr);
3967             }
3968         }
3969     }
3970     else if (sflags & (SVp_IOK|SVp_NOK)) {
3971         (void)SvOK_off(dstr);
3972         SvFLAGS(dstr) |= sflags & (SVf_IOK|SVp_IOK|SVf_IVisUV|SVf_NOK|SVp_NOK);
3973         if (sflags & SVp_IOK) {
3974             /* XXXX Do we want to set IsUV for IV(ROK)?  Be extra safe... */
3975             SvIV_set(dstr, SvIVX(sstr));
3976         }
3977         if (sflags & SVp_NOK) {
3978             SvNV_set(dstr, SvNVX(sstr));
3979         }
3980     }
3981     else {
3982         if (isGV_with_GP(sstr)) {
3983             /* This stringification rule for globs is spread in 3 places.
3984                This feels bad. FIXME.  */
3985             const U32 wasfake = sflags & SVf_FAKE;
3986
3987             /* FAKE globs can get coerced, so need to turn this off
3988                temporarily if it is on.  */
3989             SvFAKE_off(sstr);
3990             gv_efullname3(dstr, (GV *)sstr, "*");
3991             SvFLAGS(sstr) |= wasfake;
3992         }
3993         else
3994             (void)SvOK_off(dstr);
3995     }
3996     if (SvTAINTED(sstr))
3997         SvTAINT(dstr);
3998 }
3999
4000 /*
4001 =for apidoc sv_setsv_mg
4002
4003 Like C<sv_setsv>, but also handles 'set' magic.
4004
4005 =cut
4006 */
4007
4008 void
4009 Perl_sv_setsv_mg(pTHX_ SV *const dstr, register SV *const sstr)
4010 {
4011     PERL_ARGS_ASSERT_SV_SETSV_MG;
4012
4013     sv_setsv(dstr,sstr);
4014     SvSETMAGIC(dstr);
4015 }
4016
4017 #ifdef PERL_OLD_COPY_ON_WRITE
4018 SV *
4019 Perl_sv_setsv_cow(pTHX_ SV *dstr, SV *sstr)
4020 {
4021     STRLEN cur = SvCUR(sstr);
4022     STRLEN len = SvLEN(sstr);
4023     register char *new_pv;
4024
4025     PERL_ARGS_ASSERT_SV_SETSV_COW;
4026
4027     if (DEBUG_C_TEST) {
4028         PerlIO_printf(Perl_debug_log, "Fast copy on write: %p -> %p\n",
4029                       (void*)sstr, (void*)dstr);
4030         sv_dump(sstr);
4031         if (dstr)
4032                     sv_dump(dstr);
4033     }
4034
4035     if (dstr) {
4036         if (SvTHINKFIRST(dstr))
4037             sv_force_normal_flags(dstr, SV_COW_DROP_PV);
4038         else if (SvPVX_const(dstr))
4039             Safefree(SvPVX_const(dstr));
4040     }
4041     else
4042         new_SV(dstr);
4043     SvUPGRADE(dstr, SVt_PVIV);
4044
4045     assert (SvPOK(sstr));
4046     assert (SvPOKp(sstr));
4047     assert (!SvIOK(sstr));
4048     assert (!SvIOKp(sstr));
4049     assert (!SvNOK(sstr));
4050     assert (!SvNOKp(sstr));
4051
4052     if (SvIsCOW(sstr)) {
4053
4054         if (SvLEN(sstr) == 0) {
4055             /* source is a COW shared hash key.  */
4056             DEBUG_C(PerlIO_printf(Perl_debug_log,
4057                                   "Fast copy on write: Sharing hash\n"));
4058             new_pv = HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr))));
4059             goto common_exit;
4060         }
4061         SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
4062     } else {
4063         assert ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS);
4064         SvUPGRADE(sstr, SVt_PVIV);
4065         SvREADONLY_on(sstr);
4066         SvFAKE_on(sstr);
4067         DEBUG_C(PerlIO_printf(Perl_debug_log,
4068                               "Fast copy on write: Converting sstr to COW\n"));
4069         SV_COW_NEXT_SV_SET(dstr, sstr);
4070     }
4071     SV_COW_NEXT_SV_SET(sstr, dstr);
4072     new_pv = SvPVX_mutable(sstr);
4073
4074   common_exit:
4075     SvPV_set(dstr, new_pv);
4076     SvFLAGS(dstr) = (SVt_PVIV|SVf_POK|SVp_POK|SVf_FAKE|SVf_READONLY);
4077     if (SvUTF8(sstr))
4078         SvUTF8_on(dstr);
4079     SvLEN_set(dstr, len);
4080     SvCUR_set(dstr, cur);
4081     if (DEBUG_C_TEST) {
4082         sv_dump(dstr);
4083     }
4084     return dstr;
4085 }
4086 #endif
4087
4088 /*
4089 =for apidoc sv_setpvn
4090
4091 Copies a string into an SV.  The C<len> parameter indicates the number of
4092 bytes to be copied.  If the C<ptr> argument is NULL the SV will become
4093 undefined.  Does not handle 'set' magic.  See C<sv_setpvn_mg>.
4094
4095 =cut
4096 */
4097
4098 void
4099 Perl_sv_setpvn(pTHX_ register SV *const sv, register const char *const ptr, register const STRLEN len)
4100 {
4101     dVAR;
4102     register char *dptr;
4103
4104     PERL_ARGS_ASSERT_SV_SETPVN;
4105
4106     SV_CHECK_THINKFIRST_COW_DROP(sv);
4107     if (!ptr) {
4108         (void)SvOK_off(sv);
4109         return;
4110     }
4111     else {
4112         /* len is STRLEN which is unsigned, need to copy to signed */
4113         const IV iv = len;
4114         if (iv < 0)
4115             Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen");
4116     }
4117     SvUPGRADE(sv, SVt_PV);
4118
4119     dptr = SvGROW(sv, len + 1);
4120     Move(ptr,dptr,len,char);
4121     dptr[len] = '\0';
4122     SvCUR_set(sv, len);
4123     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
4124     SvTAINT(sv);
4125 }
4126
4127 /*
4128 =for apidoc sv_setpvn_mg
4129
4130 Like C<sv_setpvn>, but also handles 'set' magic.
4131
4132 =cut
4133 */
4134
4135 void
4136 Perl_sv_setpvn_mg(pTHX_ register SV *const sv, register const char *const ptr, register const STRLEN len)
4137 {
4138     PERL_ARGS_ASSERT_SV_SETPVN_MG;
4139
4140     sv_setpvn(sv,ptr,len);
4141     SvSETMAGIC(sv);
4142 }
4143
4144 /*
4145 =for apidoc sv_setpv
4146
4147 Copies a string into an SV.  The string must be null-terminated.  Does not
4148 handle 'set' magic.  See C<sv_setpv_mg>.
4149
4150 =cut
4151 */
4152
4153 void
4154 Perl_sv_setpv(pTHX_ register SV *const sv, register const char *const ptr)
4155 {
4156     dVAR;
4157     register STRLEN len;
4158
4159     PERL_ARGS_ASSERT_SV_SETPV;
4160
4161     SV_CHECK_THINKFIRST_COW_DROP(sv);
4162     if (!ptr) {
4163         (void)SvOK_off(sv);
4164         return;
4165     }
4166     len = strlen(ptr);
4167     SvUPGRADE(sv, SVt_PV);
4168
4169     SvGROW(sv, len + 1);
4170     Move(ptr,SvPVX(sv),len+1,char);
4171     SvCUR_set(sv, len);
4172     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
4173     SvTAINT(sv);
4174 }
4175
4176 /*
4177 =for apidoc sv_setpv_mg
4178
4179 Like C<sv_setpv>, but also handles 'set' magic.
4180
4181 =cut
4182 */
4183
4184 void
4185 Perl_sv_setpv_mg(pTHX_ register SV *const sv, register const char *const ptr)
4186 {
4187     PERL_ARGS_ASSERT_SV_SETPV_MG;
4188
4189     sv_setpv(sv,ptr);
4190     SvSETMAGIC(sv);
4191 }
4192
4193 /*
4194 =for apidoc sv_usepvn_flags
4195
4196 Tells an SV to use C<ptr> to find its string value.  Normally the
4197 string is stored inside the SV but sv_usepvn allows the SV to use an
4198 outside string.  The C<ptr> should point to memory that was allocated
4199 by C<malloc>.  The string length, C<len>, must be supplied.  By default
4200 this function will realloc (i.e. move) the memory pointed to by C<ptr>,
4201 so that pointer should not be freed or used by the programmer after
4202 giving it to sv_usepvn, and neither should any pointers from "behind"
4203 that pointer (e.g. ptr + 1) be used.
4204
4205 If C<flags> & SV_SMAGIC is true, will call SvSETMAGIC. If C<flags> &
4206 SV_HAS_TRAILING_NUL is true, then C<ptr[len]> must be NUL, and the realloc
4207 will be skipped. (i.e. the buffer is actually at least 1 byte longer than
4208 C<len>, and already meets the requirements for storing in C<SvPVX>)
4209
4210 =cut
4211 */
4212
4213 void
4214 Perl_sv_usepvn_flags(pTHX_ SV *const sv, char *ptr, const STRLEN len, const U32 flags)
4215 {
4216     dVAR;
4217     STRLEN allocate;
4218
4219     PERL_ARGS_ASSERT_SV_USEPVN_FLAGS;
4220
4221     SV_CHECK_THINKFIRST_COW_DROP(sv);
4222     SvUPGRADE(sv, SVt_PV);
4223     if (!ptr) {
4224         (void)SvOK_off(sv);
4225         if (flags & SV_SMAGIC)
4226             SvSETMAGIC(sv);
4227         return;
4228     }
4229     if (SvPVX_const(sv))
4230         SvPV_free(sv);
4231
4232 #ifdef DEBUGGING
4233     if (flags & SV_HAS_TRAILING_NUL)
4234         assert(ptr[len] == '\0');
4235 #endif
4236
4237     allocate = (flags & SV_HAS_TRAILING_NUL)
4238         ? len + 1 :
4239 #ifdef Perl_safesysmalloc_size
4240         len + 1;
4241 #else
4242         PERL_STRLEN_ROUNDUP(len + 1);
4243 #endif
4244     if (flags & SV_HAS_TRAILING_NUL) {
4245         /* It's long enough - do nothing.
4246            Specfically Perl_newCONSTSUB is relying on this.  */
4247     } else {
4248 #ifdef DEBUGGING
4249         /* Force a move to shake out bugs in callers.  */
4250         char *new_ptr = (char*)safemalloc(allocate);
4251         Copy(ptr, new_ptr, len, char);
4252         PoisonFree(ptr,len,char);
4253         Safefree(ptr);
4254         ptr = new_ptr;
4255 #else
4256         ptr = (char*) saferealloc (ptr, allocate);
4257 #endif
4258     }
4259 #ifdef Perl_safesysmalloc_size
4260     SvLEN_set(sv, Perl_safesysmalloc_size(ptr));
4261 #else
4262     SvLEN_set(sv, allocate);
4263 #endif
4264     SvCUR_set(sv, len);
4265     SvPV_set(sv, ptr);
4266     if (!(flags & SV_HAS_TRAILING_NUL)) {
4267         ptr[len] = '\0';
4268     }
4269     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
4270     SvTAINT(sv);
4271     if (flags & SV_SMAGIC)
4272         SvSETMAGIC(sv);
4273 }
4274
4275 #ifdef PERL_OLD_COPY_ON_WRITE
4276 /* Need to do this *after* making the SV normal, as we need the buffer
4277    pointer to remain valid until after we've copied it.  If we let go too early,
4278    another thread could invalidate it by unsharing last of the same hash key
4279    (which it can do by means other than releasing copy-on-write Svs)
4280    or by changing the other copy-on-write SVs in the loop.  */
4281 STATIC void
4282 S_sv_release_COW(pTHX_ register SV *sv, const char *pvx, SV *after)
4283 {
4284     PERL_ARGS_ASSERT_SV_RELEASE_COW;
4285
4286     { /* this SV was SvIsCOW_normal(sv) */
4287          /* we need to find the SV pointing to us.  */
4288         SV *current = SV_COW_NEXT_SV(after);
4289
4290         if (current == sv) {
4291             /* The SV we point to points back to us (there were only two of us
4292                in the loop.)
4293                Hence other SV is no longer copy on write either.  */
4294             SvFAKE_off(after);
4295             SvREADONLY_off(after);
4296         } else {
4297             /* We need to follow the pointers around the loop.  */
4298             SV *next;
4299             while ((next = SV_COW_NEXT_SV(current)) != sv) {
4300                 assert (next);
4301                 current = next;
4302                  /* don't loop forever if the structure is bust, and we have
4303                     a pointer into a closed loop.  */
4304                 assert (current != after);
4305                 assert (SvPVX_const(current) == pvx);
4306             }
4307             /* Make the SV before us point to the SV after us.  */
4308             SV_COW_NEXT_SV_SET(current, after);
4309         }
4310     }
4311 }
4312 #endif
4313 /*
4314 =for apidoc sv_force_normal_flags
4315
4316 Undo various types of fakery on an SV: if the PV is a shared string, make
4317 a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
4318 an xpvmg; if we're a copy-on-write scalar, this is the on-write time when
4319 we do the copy, and is also used locally. If C<SV_COW_DROP_PV> is set
4320 then a copy-on-write scalar drops its PV buffer (if any) and becomes
4321 SvPOK_off rather than making a copy. (Used where this scalar is about to be
4322 set to some other value.) In addition, the C<flags> parameter gets passed to
4323 C<sv_unref_flags()> when unrefing. C<sv_force_normal> calls this function
4324 with flags set to 0.
4325
4326 =cut
4327 */
4328
4329 void
4330 Perl_sv_force_normal_flags(pTHX_ register SV *const sv, const U32 flags)
4331 {
4332     dVAR;
4333
4334     PERL_ARGS_ASSERT_SV_FORCE_NORMAL_FLAGS;
4335
4336 #ifdef PERL_OLD_COPY_ON_WRITE
4337     if (SvREADONLY(sv)) {
4338         /* At this point I believe I should acquire a global SV mutex.  */
4339         if (SvFAKE(sv)) {
4340             const char * const pvx = SvPVX_const(sv);
4341             const STRLEN len = SvLEN(sv);
4342             const STRLEN cur = SvCUR(sv);
4343             /* next COW sv in the loop.  If len is 0 then this is a shared-hash
4344                key scalar, so we mustn't attempt to call SV_COW_NEXT_SV(), as
4345                we'll fail an assertion.  */
4346             SV * const next = len ? SV_COW_NEXT_SV(sv) : 0;
4347
4348             if (DEBUG_C_TEST) {
4349                 PerlIO_printf(Perl_debug_log,
4350                               "Copy on write: Force normal %ld\n",
4351                               (long) flags);
4352                 sv_dump(sv);
4353             }
4354             SvFAKE_off(sv);
4355             SvREADONLY_off(sv);
4356             /* This SV doesn't own the buffer, so need to Newx() a new one:  */
4357             SvPV_set(sv, NULL);
4358             SvLEN_set(sv, 0);
4359             if (flags & SV_COW_DROP_PV) {
4360                 /* OK, so we don't need to copy our buffer.  */
4361                 SvPOK_off(sv);
4362             } else {
4363                 SvGROW(sv, cur + 1);
4364                 Move(pvx,SvPVX(sv),cur,char);
4365                 SvCUR_set(sv, cur);
4366                 *SvEND(sv) = '\0';
4367             }
4368             if (len) {
4369                 sv_release_COW(sv, pvx, next);
4370             } else {
4371                 unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
4372             }
4373             if (DEBUG_C_TEST) {
4374                 sv_dump(sv);
4375             }
4376         }
4377         else if (IN_PERL_RUNTIME)
4378             Perl_croak(aTHX_ PL_no_modify);
4379         /* At this point I believe that I can drop the global SV mutex.  */
4380     }
4381 #else
4382     if (SvREADONLY(sv)) {
4383         if (SvFAKE(sv)) {
4384             const char * const pvx = SvPVX_const(sv);
4385             const STRLEN len = SvCUR(sv);
4386             SvFAKE_off(sv);
4387             SvREADONLY_off(sv);
4388             SvPV_set(sv, NULL);
4389             SvLEN_set(sv, 0);
4390             SvGROW(sv, len + 1);
4391             Move(pvx,SvPVX(sv),len,char);
4392             *SvEND(sv) = '\0';
4393             unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
4394         }
4395         else if (IN_PERL_RUNTIME)
4396             Perl_croak(aTHX_ PL_no_modify);
4397     }
4398 #endif
4399     if (SvROK(sv))
4400         sv_unref_flags(sv, flags);
4401     else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
4402         sv_unglob(sv);
4403 }
4404
4405 /*
4406 =for apidoc sv_chop
4407
4408 Efficient removal of characters from the beginning of the string buffer.
4409 SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside
4410 the string buffer.  The C<ptr> becomes the first character of the adjusted
4411 string. Uses the "OOK hack".
4412 Beware: after this function returns, C<ptr> and SvPVX_const(sv) may no longer
4413 refer to the same chunk of data.
4414
4415 =cut
4416 */
4417
4418 void
4419 Perl_sv_chop(pTHX_ register SV *const sv, register const char *const ptr)
4420 {
4421     STRLEN delta;
4422     STRLEN old_delta;
4423     U8 *p;
4424 #ifdef DEBUGGING
4425     const U8 *real_start;
4426 #endif
4427     STRLEN max_delta;
4428
4429     PERL_ARGS_ASSERT_SV_CHOP;
4430
4431     if (!ptr || !SvPOKp(sv))
4432         return;
4433     delta = ptr - SvPVX_const(sv);
4434     if (!delta) {
4435         /* Nothing to do.  */
4436         return;
4437     }
4438     /* SvPVX(sv) may move in SV_CHECK_THINKFIRST(sv), but after this line,
4439        nothing uses the value of ptr any more.  */
4440     max_delta = SvLEN(sv) ? SvLEN(sv) : SvCUR(sv);
4441     if (ptr <= SvPVX_const(sv))
4442         Perl_croak(aTHX_ "panic: sv_chop ptr=%p, start=%p, end=%p",
4443                    ptr, SvPVX_const(sv), SvPVX_const(sv) + max_delta);
4444     SV_CHECK_THINKFIRST(sv);
4445     if (delta > max_delta)
4446         Perl_croak(aTHX_ "panic: sv_chop ptr=%p (was %p), start=%p, end=%p",
4447                    SvPVX_const(sv) + delta, ptr, SvPVX_const(sv),
4448                    SvPVX_const(sv) + max_delta);
4449
4450     if (!SvOOK(sv)) {
4451         if (!SvLEN(sv)) { /* make copy of shared string */
4452             const char *pvx = SvPVX_const(sv);
4453             const STRLEN len = SvCUR(sv);
4454             SvGROW(sv, len + 1);
4455             Move(pvx,SvPVX(sv),len,char);
4456             *SvEND(sv) = '\0';
4457         }
4458         SvFLAGS(sv) |= SVf_OOK;
4459         old_delta = 0;
4460     } else {
4461         SvOOK_offset(sv, old_delta);
4462     }
4463     SvLEN_set(sv, SvLEN(sv) - delta);
4464     SvCUR_set(sv, SvCUR(sv) - delta);
4465     SvPV_set(sv, SvPVX(sv) + delta);
4466
4467     p = (U8 *)SvPVX_const(sv);
4468
4469     delta += old_delta;
4470
4471 #ifdef DEBUGGING
4472     real_start = p - delta;
4473 #endif
4474
4475     assert(delta);
4476     if (delta < 0x100) {
4477         *--p = (U8) delta;
4478     } else {
4479         *--p = 0;
4480         p -= sizeof(STRLEN);
4481         Copy((U8*)&delta, p, sizeof(STRLEN), U8);
4482     }
4483
4484 #ifdef DEBUGGING
4485     /* Fill the preceding buffer with sentinals to verify that no-one is
4486        using it.  */
4487     while (p > real_start) {
4488         --p;
4489         *p = (U8)PTR2UV(p);
4490     }
4491 #endif
4492 }
4493
4494 /*
4495 =for apidoc sv_catpvn
4496
4497 Concatenates the string onto the end of the string which is in the SV.  The
4498 C<len> indicates number of bytes to copy.  If the SV has the UTF-8
4499 status set, then the bytes appended should be valid UTF-8.
4500 Handles 'get' magic, but not 'set' magic.  See C<sv_catpvn_mg>.
4501
4502 =for apidoc sv_catpvn_flags
4503
4504 Concatenates the string onto the end of the string which is in the SV.  The
4505 C<len> indicates number of bytes to copy.  If the SV has the UTF-8
4506 status set, then the bytes appended should be valid UTF-8.
4507 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<dsv> if
4508 appropriate, else not. C<sv_catpvn> and C<sv_catpvn_nomg> are implemented
4509 in terms of this function.
4510
4511 =cut
4512 */
4513
4514 void
4515 Perl_sv_catpvn_flags(pTHX_ register SV *const dsv, register const char *sstr, register const STRLEN slen, const I32 flags)
4516 {
4517     dVAR;
4518     STRLEN dlen;
4519     const char * const dstr = SvPV_force_flags(dsv, dlen, flags);
4520
4521     PERL_ARGS_ASSERT_SV_CATPVN_FLAGS;
4522
4523     SvGROW(dsv, dlen + slen + 1);
4524     if (sstr == dstr)
4525         sstr = SvPVX_const(dsv);
4526     Move(sstr, SvPVX(dsv) + dlen, slen, char);
4527     SvCUR_set(dsv, SvCUR(dsv) + slen);
4528     *SvEND(dsv) = '\0';
4529     (void)SvPOK_only_UTF8(dsv);         /* validate pointer */
4530     SvTAINT(dsv);
4531     if (flags & SV_SMAGIC)
4532         SvSETMAGIC(dsv);
4533 }
4534
4535 /*
4536 =for apidoc sv_catsv
4537
4538 Concatenates the string from SV C<ssv> onto the end of the string in
4539 SV C<dsv>.  Modifies C<dsv> but not C<ssv>.  Handles 'get' magic, but
4540 not 'set' magic.  See C<sv_catsv_mg>.
4541
4542 =for apidoc sv_catsv_flags
4543
4544 Concatenates the string from SV C<ssv> onto the end of the string in
4545 SV C<dsv>.  Modifies C<dsv> but not C<ssv>.  If C<flags> has C<SV_GMAGIC>
4546 bit set, will C<mg_get> on the SVs if appropriate, else not. C<sv_catsv>
4547 and C<sv_catsv_nomg> are implemented in terms of this function.
4548
4549 =cut */
4550
4551 void
4552 Perl_sv_catsv_flags(pTHX_ SV *const dsv, register SV *const ssv, const I32 flags)
4553 {
4554     dVAR;
4555
4556     PERL_ARGS_ASSERT_SV_CATSV_FLAGS;
4557
4558    if (ssv) {
4559         STRLEN slen;
4560         const char *spv = SvPV_const(ssv, slen);
4561         if (spv) {
4562             /*  sutf8 and dutf8 were type bool, but under USE_ITHREADS,
4563                 gcc version 2.95.2 20000220 (Debian GNU/Linux) for
4564                 Linux xxx 2.2.17 on sparc64 with gcc -O2, we erroneously
4565                 get dutf8 = 0x20000000, (i.e.  SVf_UTF8) even though
4566                 dsv->sv_flags doesn't have that bit set.
4567                 Andy Dougherty  12 Oct 2001
4568             */
4569             const I32 sutf8 = DO_UTF8(ssv);
4570             I32 dutf8;
4571
4572             if (SvGMAGICAL(dsv) && (flags & SV_GMAGIC))
4573                 mg_get(dsv);
4574             dutf8 = DO_UTF8(dsv);
4575
4576             if (dutf8 != sutf8) {
4577                 if (dutf8) {
4578                     /* Not modifying source SV, so taking a temporary copy. */
4579                     SV* const csv = newSVpvn_flags(spv, slen, SVs_TEMP);
4580
4581                     sv_utf8_upgrade(csv);
4582                     spv = SvPV_const(csv, slen);
4583                 }
4584                 else
4585                     sv_utf8_upgrade_nomg(dsv);
4586             }
4587             sv_catpvn_nomg(dsv, spv, slen);
4588         }
4589     }
4590     if (flags & SV_SMAGIC)
4591         SvSETMAGIC(dsv);
4592 }
4593
4594 /*
4595 =for apidoc sv_catpv
4596
4597 Concatenates the string onto the end of the string which is in the SV.
4598 If the SV has the UTF-8 status set, then the bytes appended should be
4599 valid UTF-8.  Handles 'get' magic, but not 'set' magic.  See C<sv_catpv_mg>.
4600
4601 =cut */
4602
4603 void
4604 Perl_sv_catpv(pTHX_ register SV *const sv, register const char *ptr)
4605 {
4606     dVAR;
4607     register STRLEN len;
4608     STRLEN tlen;
4609     char *junk;
4610
4611     PERL_ARGS_ASSERT_SV_CATPV;
4612
4613     if (!ptr)
4614         return;
4615     junk = SvPV_force(sv, tlen);
4616     len = strlen(ptr);
4617     SvGROW(sv, tlen + len + 1);
4618     if (ptr == junk)
4619         ptr = SvPVX_const(sv);
4620     Move(ptr,SvPVX(sv)+tlen,len+1,char);
4621     SvCUR_set(sv, SvCUR(sv) + len);
4622     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
4623     SvTAINT(sv);
4624 }
4625
4626 /*
4627 =for apidoc sv_catpv_mg
4628
4629 Like C<sv_catpv>, but also handles 'set' magic.
4630
4631 =cut
4632 */
4633
4634 void
4635 Perl_sv_catpv_mg(pTHX_ register SV *const sv, register const char *const ptr)
4636 {
4637     PERL_ARGS_ASSERT_SV_CATPV_MG;
4638
4639     sv_catpv(sv,ptr);
4640     SvSETMAGIC(sv);
4641 }
4642
4643 /*
4644 =for apidoc newSV
4645
4646 Creates a new SV.  A non-zero C<len> parameter indicates the number of
4647 bytes of preallocated string space the SV should have.  An extra byte for a
4648 trailing NUL is also reserved.  (SvPOK is not set for the SV even if string
4649 space is allocated.)  The reference count for the new SV is set to 1.
4650
4651 In 5.9.3, newSV() replaces the older NEWSV() API, and drops the first
4652 parameter, I<x>, a debug aid which allowed callers to identify themselves.
4653 This aid has been superseded by a new build option, PERL_MEM_LOG (see
4654 L<perlhack/PERL_MEM_LOG>).  The older API is still there for use in XS
4655 modules supporting older perls.
4656
4657 =cut
4658 */
4659
4660 SV *
4661 Perl_newSV(pTHX_ const STRLEN len)
4662 {
4663     dVAR;
4664     register SV *sv;
4665
4666     new_SV(sv);
4667     if (len) {
4668         sv_upgrade(sv, SVt_PV);
4669         SvGROW(sv, len + 1);
4670     }
4671     return sv;
4672 }
4673 /*
4674 =for apidoc sv_magicext
4675
4676 Adds magic to an SV, upgrading it if necessary. Applies the
4677 supplied vtable and returns a pointer to the magic added.
4678
4679 Note that C<sv_magicext> will allow things that C<sv_magic> will not.
4680 In particular, you can add magic to SvREADONLY SVs, and add more than
4681 one instance of the same 'how'.
4682
4683 If C<namlen> is greater than zero then a C<savepvn> I<copy> of C<name> is
4684 stored, if C<namlen> is zero then C<name> is stored as-is and - as another
4685 special case - if C<(name && namlen == HEf_SVKEY)> then C<name> is assumed
4686 to contain an C<SV*> and is stored as-is with its REFCNT incremented.
4687
4688 (This is now used as a subroutine by C<sv_magic>.)
4689
4690 =cut
4691 */
4692 MAGIC *
4693 Perl_sv_magicext(pTHX_ SV *const sv, SV *const obj, const int how,
4694                 const MGVTBL *const vtable, const char *const name, const I32 namlen)
4695 {
4696     dVAR;
4697     MAGIC* mg;
4698
4699     PERL_ARGS_ASSERT_SV_MAGICEXT;
4700
4701     SvUPGRADE(sv, SVt_PVMG);
4702     Newxz(mg, 1, MAGIC);
4703     mg->mg_moremagic = SvMAGIC(sv);
4704     SvMAGIC_set(sv, mg);
4705
4706     /* Sometimes a magic contains a reference loop, where the sv and
4707        object refer to each other.  To prevent a reference loop that
4708        would prevent such objects being freed, we look for such loops
4709        and if we find one we avoid incrementing the object refcount.
4710
4711        Note we cannot do this to avoid self-tie loops as intervening RV must
4712        have its REFCNT incremented to keep it in existence.
4713
4714     */
4715     if (!obj || obj == sv ||
4716         how == PERL_MAGIC_arylen ||
4717         how == PERL_MAGIC_symtab ||
4718         (SvTYPE(obj) == SVt_PVGV &&
4719             (GvSV(obj) == sv || GvHV(obj) == (const HV *)sv
4720              || GvAV(obj) == (const AV *)sv || GvCV(obj) == (const CV *)sv
4721              || GvIOp(obj) == (const IO *)sv || GvFORM(obj) == (const CV *)sv)))
4722     {
4723         mg->mg_obj = obj;
4724     }
4725     else {
4726         mg->mg_obj = SvREFCNT_inc_simple(obj);
4727         mg->mg_flags |= MGf_REFCOUNTED;
4728     }
4729
4730     /* Normal self-ties simply pass a null object, and instead of
4731        using mg_obj directly, use the SvTIED_obj macro to produce a
4732        new RV as needed.  For glob "self-ties", we are tieing the PVIO
4733        with an RV obj pointing to the glob containing the PVIO.  In
4734        this case, to avoid a reference loop, we need to weaken the
4735        reference.
4736     */
4737
4738     if (how == PERL_MAGIC_tiedscalar && SvTYPE(sv) == SVt_PVIO &&
4739         obj && SvROK(obj) && GvIO(SvRV(obj)) == (IO*)sv)
4740     {
4741       sv_rvweaken(obj);