sv.c

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