util.c

   1 /*    util.c
   2  *
   3  *    Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001,
   4  *    2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
   5  *
   6  *    You may distribute under the terms of either the GNU General Public
   7  *    License or the Artistic License, as specified in the README file.
   8  *
   9  */
  10
  11 /*
  12  * 'Very useful, no doubt, that was to Saruman; yet it seems that he was
  13  *  not content.'                                    --Gandalf to Pippin
  14  *
  15  *     [p.598 of _The Lord of the Rings_, III/xi: "The Palantír"]
  16  */
  17
  18 /* This file contains assorted utility routines.
  19  * Which is a polite way of saying any stuff that people couldn't think of
  20  * a better place for. Amongst other things, it includes the warning and
  21  * dieing stuff, plus wrappers for malloc code.
  22  */
  23
  24 #include "EXTERN.h"
  25 #define PERL_IN_UTIL_C
  26 #include "perl.h"
  27 #include "reentr.h"
  28
  29 #ifdef USE_PERLIO
  30 #include "perliol.h" /* For PerlIOUnix_refcnt */
  31 #endif
  32
  33 #ifndef PERL_MICRO
  34 #include <signal.h>
  35 #ifndef SIG_ERR
  36 # define SIG_ERR ((Sighandler_t) -1)
  37 #endif
  38 #endif
  39
  40 #include <math.h>
  41 #include <stdlib.h>
  42
  43 #ifdef __Lynx__
  44 /* Missing protos on LynxOS */
  45 int putenv(char *);
  46 #endif
  47
  48 #ifdef HAS_SELECT
  49 # ifdef I_SYS_SELECT
  50 #  include <sys/select.h>
  51 # endif
  52 #endif
  53
  54 #define FLUSH
  55
  56 #if defined(HAS_FCNTL) && defined(F_SETFD) && !defined(FD_CLOEXEC)
  57 #  define FD_CLOEXEC 1                  /* NeXT needs this */
  58 #endif
  59
  60 /* NOTE:  Do not call the next three routines directly.  Use the macros
  61  * in handy.h, so that we can easily redefine everything to do tracking of
  62  * allocated hunks back to the original New to track down any memory leaks.
  63  * XXX This advice seems to be widely ignored :-(   --AD  August 1996.
  64  */
  65
  66 #if defined (DEBUGGING) || defined(PERL_IMPLICIT_SYS) || defined (PERL_TRACK_MEMPOOL)
  67 #  define ALWAYS_NEED_THX
  68 #endif
  69
  70 /* paranoid version of system's malloc() */
  71
  72 Malloc_t
  73 Perl_safesysmalloc(MEM_SIZE size)
  74 {
  75 #ifdef ALWAYS_NEED_THX
  76     dTHX;
  77 #endif
  78     Malloc_t ptr;
  79 #ifdef HAS_64K_LIMIT
  80         if (size > 0xffff) {
  81             PerlIO_printf(Perl_error_log,
  82                           "Allocation too large: %lx\n", size) FLUSH;
  83             my_exit(1);
  84         }
  85 #endif /* HAS_64K_LIMIT */
  86 #ifdef PERL_TRACK_MEMPOOL
  87     size += sTHX;
  88 #endif
  89 #ifdef DEBUGGING
  90     if ((SSize_t)size < 0)
  91         Perl_croak_nocontext("panic: malloc, size=%"UVuf, (UV) size);
  92 #endif
  93     ptr = (Malloc_t)PerlMem_malloc(size?size:1);        /* malloc(0) is NASTY on our system */
  94     PERL_ALLOC_CHECK(ptr);
  95     if (ptr != NULL) {
  96 #ifdef PERL_TRACK_MEMPOOL
  97         struct perl_memory_debug_header *const header
  98             = (struct perl_memory_debug_header *)ptr;
  99 #endif
 100
 101 #ifdef PERL_POISON
 102         PoisonNew(((char *)ptr), size, char);
 103 #endif
 104
 105 #ifdef PERL_TRACK_MEMPOOL
 106         header->interpreter = aTHX;
 107         /* Link us into the list.  */
 108         header->prev = &PL_memory_debug_header;
 109         header->next = PL_memory_debug_header.next;
 110         PL_memory_debug_header.next = header;
 111         header->next->prev = header;
 112 #  ifdef PERL_POISON
 113         header->size = size;
 114 #  endif
 115         ptr = (Malloc_t)((char*)ptr+sTHX);
 116 #endif
 117         DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) malloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
 118         return ptr;
 119 }
 120     else {
 121 #ifndef ALWAYS_NEED_THX
 122         dTHX;
 123 #endif
 124         if (PL_nomemok)
 125             return NULL;
 126         else {
 127             croak_no_mem();
 128         }
 129     }
 130     /*NOTREACHED*/
 131 }
 132
 133 /* paranoid version of system's realloc() */
 134
 135 Malloc_t
 136 Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
 137 {
 138 #ifdef ALWAYS_NEED_THX
 139     dTHX;
 140 #endif
 141     Malloc_t ptr;
 142 #if !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) && !defined(PERL_MICRO)
 143     Malloc_t PerlMem_realloc();
 144 #endif /* !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) */
 145
 146 #ifdef HAS_64K_LIMIT
 147     if (size > 0xffff) {
 148         PerlIO_printf(Perl_error_log,
 149                       "Reallocation too large: %lx\n", size) FLUSH;
 150         my_exit(1);
 151     }
 152 #endif /* HAS_64K_LIMIT */
 153     if (!size) {
 154         safesysfree(where);
 155         return NULL;
 156     }
 157
 158     if (!where)
 159         return safesysmalloc(size);
 160 #ifdef PERL_TRACK_MEMPOOL
 161     where = (Malloc_t)((char*)where-sTHX);
 162     size += sTHX;
 163     {
 164         struct perl_memory_debug_header *const header
 165             = (struct perl_memory_debug_header *)where;
 166
 167         if (header->interpreter != aTHX) {
 168             Perl_croak_nocontext("panic: realloc from wrong pool, %p!=%p",
 169                                  header->interpreter, aTHX);
 170         }
 171         assert(header->next->prev == header);
 172         assert(header->prev->next == header);
 173 #  ifdef PERL_POISON
 174         if (header->size > size) {
 175             const MEM_SIZE freed_up = header->size - size;
 176             char *start_of_freed = ((char *)where) + size;
 177             PoisonFree(start_of_freed, freed_up, char);
 178         }
 179         header->size = size;
 180 #  endif
 181     }
 182 #endif
 183 #ifdef DEBUGGING
 184     if ((SSize_t)size < 0)
 185         Perl_croak_nocontext("panic: realloc, size=%"UVuf, (UV)size);
 186 #endif
 187     ptr = (Malloc_t)PerlMem_realloc(where,size);
 188     PERL_ALLOC_CHECK(ptr);
 189
 190     /* MUST do this fixup first, before doing ANYTHING else, as anything else
 191        might allocate memory/free/move memory, and until we do the fixup, it
 192        may well be chasing (and writing to) free memory.  */
 193 #ifdef PERL_TRACK_MEMPOOL
 194     if (ptr != NULL) {
 195         struct perl_memory_debug_header *const header
 196             = (struct perl_memory_debug_header *)ptr;
 197
 198 #  ifdef PERL_POISON
 199         if (header->size < size) {
 200             const MEM_SIZE fresh = size - header->size;
 201             char *start_of_fresh = ((char *)ptr) + size;
 202             PoisonNew(start_of_fresh, fresh, char);
 203         }
 204 #  endif
 205
 206         header->next->prev = header;
 207         header->prev->next = header;
 208
 209         ptr = (Malloc_t)((char*)ptr+sTHX);
 210     }
 211 #endif
 212
 213     /* In particular, must do that fixup above before logging anything via
 214      *printf(), as it can reallocate memory, which can cause SEGVs.  */
 215
 216     DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) rfree\n",PTR2UV(where),(long)PL_an++));
 217     DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) realloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
 218
 219
 220     if (ptr != NULL) {
 221         return ptr;
 222     }
 223     else {
 224 #ifndef ALWAYS_NEED_THX
 225         dTHX;
 226 #endif
 227         if (PL_nomemok)
 228             return NULL;
 229         else {
 230             croak_no_mem();
 231         }
 232     }
 233     /*NOTREACHED*/
 234 }
 235
 236 /* safe version of system's free() */
 237
 238 Free_t
 239 Perl_safesysfree(Malloc_t where)
 240 {
 241 #ifdef ALWAYS_NEED_THX
 242     dTHX;
 243 #else
 244     dVAR;
 245 #endif
 246     DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) free\n",PTR2UV(where),(long)PL_an++));
 247     if (where) {
 248 #ifdef PERL_TRACK_MEMPOOL
 249         where = (Malloc_t)((char*)where-sTHX);
 250         {
 251             struct perl_memory_debug_header *const header
 252                 = (struct perl_memory_debug_header *)where;
 253
 254             if (header->interpreter != aTHX) {
 255                 Perl_croak_nocontext("panic: free from wrong pool, %p!=%p",
 256                                      header->interpreter, aTHX);
 257             }
 258             if (!header->prev) {
 259                 Perl_croak_nocontext("panic: duplicate free");
 260             }
 261             if (!(header->next))
 262                 Perl_croak_nocontext("panic: bad free, header->next==NULL");
 263             if (header->next->prev != header || header->prev->next != header) {
 264                 Perl_croak_nocontext("panic: bad free, ->next->prev=%p, "
 265                                      "header=%p, ->prev->next=%p",
 266                                      header->next->prev, header,
 267                                      header->prev->next);
 268             }
 269             /* Unlink us from the chain.  */
 270             header->next->prev = header->prev;
 271             header->prev->next = header->next;
 272 #  ifdef PERL_POISON
 273             PoisonNew(where, header->size, char);
 274 #  endif
 275             /* Trigger the duplicate free warning.  */
 276             header->next = NULL;
 277         }
 278 #endif
 279         PerlMem_free(where);
 280     }
 281 }
 282
 283 /* safe version of system's calloc() */
 284
 285 Malloc_t
 286 Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size)
 287 {
 288 #ifdef ALWAYS_NEED_THX
 289     dTHX;
 290 #endif
 291     Malloc_t ptr;
 292 #if defined(PERL_TRACK_MEMPOOL) || defined(HAS_64K_LIMIT) || defined(DEBUGGING)
 293     MEM_SIZE total_size = 0;
 294 #endif
 295
 296     /* Even though calloc() for zero bytes is strange, be robust. */
 297     if (size && (count <= MEM_SIZE_MAX / size)) {
 298 #if defined(PERL_TRACK_MEMPOOL) || defined(HAS_64K_LIMIT) || defined(DEBUGGING)
 299         total_size = size * count;
 300 #endif
 301     }
 302     else
 303         croak_memory_wrap();
 304 #ifdef PERL_TRACK_MEMPOOL
 305     if (sTHX <= MEM_SIZE_MAX - (MEM_SIZE)total_size)
 306         total_size += sTHX;
 307     else
 308         croak_memory_wrap();
 309 #endif
 310 #ifdef HAS_64K_LIMIT
 311     if (total_size > 0xffff) {
 312         PerlIO_printf(Perl_error_log,
 313                       "Allocation too large: %lx\n", total_size) FLUSH;
 314         my_exit(1);
 315     }
 316 #endif /* HAS_64K_LIMIT */
 317 #ifdef DEBUGGING
 318     if ((SSize_t)size < 0 || (SSize_t)count < 0)
 319         Perl_croak_nocontext("panic: calloc, size=%"UVuf", count=%"UVuf,
 320                              (UV)size, (UV)count);
 321 #endif
 322 #ifdef PERL_TRACK_MEMPOOL
 323     /* Have to use malloc() because we've added some space for our tracking
 324        header.  */
 325     /* malloc(0) is non-portable. */
 326     ptr = (Malloc_t)PerlMem_malloc(total_size ? total_size : 1);
 327 #else
 328     /* Use calloc() because it might save a memset() if the memory is fresh
 329        and clean from the OS.  */
 330     if (count && size)
 331         ptr = (Malloc_t)PerlMem_calloc(count, size);
 332     else /* calloc(0) is non-portable. */
 333         ptr = (Malloc_t)PerlMem_calloc(count ? count : 1, size ? size : 1);
 334 #endif
 335     PERL_ALLOC_CHECK(ptr);
 336     DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) calloc %ld x %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)count,(long)total_size));
 337     if (ptr != NULL) {
 338 #ifdef PERL_TRACK_MEMPOOL
 339         {
 340             struct perl_memory_debug_header *const header
 341                 = (struct perl_memory_debug_header *)ptr;
 342
 343             memset((void*)ptr, 0, total_size);
 344             header->interpreter = aTHX;
 345             /* Link us into the list.  */
 346             header->prev = &PL_memory_debug_header;
 347             header->next = PL_memory_debug_header.next;
 348             PL_memory_debug_header.next = header;
 349             header->next->prev = header;
 350 #  ifdef PERL_POISON
 351             header->size = total_size;
 352 #  endif
 353             ptr = (Malloc_t)((char*)ptr+sTHX);
 354         }
 355 #endif
 356         return ptr;
 357     }
 358     else {
 359 #ifndef ALWAYS_NEED_THX
 360         dTHX;
 361 #endif
 362         if (PL_nomemok)
 363             return NULL;
 364         croak_no_mem();
 365     }
 366 }
 367
 368 /* These must be defined when not using Perl's malloc for binary
 369  * compatibility */
 370
 371 #ifndef MYMALLOC
 372
 373 Malloc_t Perl_malloc (MEM_SIZE nbytes)
 374 {
 375     dTHXs;
 376     return (Malloc_t)PerlMem_malloc(nbytes);
 377 }
 378
 379 Malloc_t Perl_calloc (MEM_SIZE elements, MEM_SIZE size)
 380 {
 381     dTHXs;
 382     return (Malloc_t)PerlMem_calloc(elements, size);
 383 }
 384
 385 Malloc_t Perl_realloc (Malloc_t where, MEM_SIZE nbytes)
 386 {
 387     dTHXs;
 388     return (Malloc_t)PerlMem_realloc(where, nbytes);
 389 }
 390
 391 Free_t   Perl_mfree (Malloc_t where)
 392 {
 393     dTHXs;
 394     PerlMem_free(where);
 395 }
 396
 397 #endif
 398
 399 /* copy a string up to some (non-backslashed) delimiter, if any */
 400
 401 char *
 402 Perl_delimcpy(char *to, const char *toend, const char *from, const char *fromend, int delim, I32 *retlen)
 403 {
 404     I32 tolen;
 405
 406     PERL_ARGS_ASSERT_DELIMCPY;
 407
 408     for (tolen = 0; from < fromend; from++, tolen++) {
 409         if (*from == '\\') {
 410             if (from[1] != delim) {
 411                 if (to < toend)
 412                     *to++ = *from;
 413                 tolen++;
 414             }
 415             from++;
 416         }
 417         else if (*from == delim)
 418             break;
 419         if (to < toend)
 420             *to++ = *from;
 421     }
 422     if (to < toend)
 423         *to = '\0';
 424     *retlen = tolen;
 425     return (char *)from;
 426 }
 427
 428 /* return ptr to little string in big string, NULL if not found */
 429 /* This routine was donated by Corey Satten. */
 430
 431 char *
 432 Perl_instr(const char *big, const char *little)
 433 {
 434
 435     PERL_ARGS_ASSERT_INSTR;
 436
 437     /* libc prior to 4.6.27 did not work properly on a NULL 'little' */
 438     if (!little)
 439         return (char*)big;
 440     return strstr((char*)big, (char*)little);
 441 }
 442
 443 /* same as instr but allow embedded nulls.  The end pointers point to 1 beyond
 444  * the final character desired to be checked */
 445
 446 char *
 447 Perl_ninstr(const char *big, const char *bigend, const char *little, const char *lend)
 448 {
 449     PERL_ARGS_ASSERT_NINSTR;
 450     if (little >= lend)
 451         return (char*)big;
 452     {
 453         const char first = *little;
 454         const char *s, *x;
 455         bigend -= lend - little++;
 456     OUTER:
 457         while (big <= bigend) {
 458             if (*big++ == first) {
 459                 for (x=big,s=little; s < lend; x++,s++) {
 460                     if (*s != *x)
 461                         goto OUTER;
 462                 }
 463                 return (char*)(big-1);
 464             }
 465         }
 466     }
 467     return NULL;
 468 }
 469
 470 /* reverse of the above--find last substring */
 471
 472 char *
 473 Perl_rninstr(const char *big, const char *bigend, const char *little, const char *lend)
 474 {
 475     const char *bigbeg;
 476     const I32 first = *little;
 477     const char * const littleend = lend;
 478
 479     PERL_ARGS_ASSERT_RNINSTR;
 480
 481     if (little >= littleend)
 482         return (char*)bigend;
 483     bigbeg = big;
 484     big = bigend - (littleend - little++);
 485     while (big >= bigbeg) {
 486         const char *s, *x;
 487         if (*big-- != first)
 488             continue;
 489         for (x=big+2,s=little; s < littleend; /**/ ) {
 490             if (*s != *x)
 491                 break;
 492             else {
 493                 x++;
 494                 s++;
 495             }
 496         }
 497         if (s >= littleend)
 498             return (char*)(big+1);
 499     }
 500     return NULL;
 501 }
 502
 503 /* As a space optimization, we do not compile tables for strings of length
 504    0 and 1, and for strings of length 2 unless FBMcf_TAIL.  These are
 505    special-cased in fbm_instr().
 506
 507    If FBMcf_TAIL, the table is created as if the string has a trailing \n. */
 508
 509 /*
 510 =head1 Miscellaneous Functions
 511
 512 =for apidoc fbm_compile
 513
 514 Analyses the string in order to make fast searches on it using fbm_instr()
 515 -- the Boyer-Moore algorithm.
 516
 517 =cut
 518 */
 519
 520 void
 521 Perl_fbm_compile(pTHX_ SV *sv, U32 flags)
 522 {
 523     dVAR;
 524     const U8 *s;
 525     STRLEN i;
 526     STRLEN len;
 527     U32 frequency = 256;
 528     MAGIC *mg;
 529     PERL_DEB( STRLEN rarest = 0 );
 530
 531     PERL_ARGS_ASSERT_FBM_COMPILE;
 532
 533     if (isGV_with_GP(sv) || SvROK(sv))
 534         return;
 535
 536     if (SvVALID(sv))
 537         return;
 538
 539     if (flags & FBMcf_TAIL) {
 540         MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL;
 541         sv_catpvs(sv, "\n");            /* Taken into account in fbm_instr() */
 542         if (mg && mg->mg_len >= 0)
 543             mg->mg_len++;
 544     }
 545     if (!SvPOK(sv) || SvNIOKp(sv))
 546         s = (U8*)SvPV_force_mutable(sv, len);
 547     else s = (U8 *)SvPV_mutable(sv, len);
 548     if (len == 0)               /* TAIL might be on a zero-length string. */
 549         return;
 550     SvUPGRADE(sv, SVt_PVMG);
 551     SvIOK_off(sv);
 552     SvNOK_off(sv);
 553     SvVALID_on(sv);
 554
 555     /* "deep magic", the comment used to add. The use of MAGIC itself isn't
 556        really. MAGIC was originally added in 79072805bf63abe5 (perl 5.0 alpha 2)
 557        to call SvVALID_off() if the scalar was assigned to.
 558
 559        The comment itself (and "deeper magic" below) date back to
 560        378cc40b38293ffc (perl 2.0). "deep magic" was an annotation on
 561        str->str_pok |= 2;
 562        where the magic (presumably) was that the scalar had a BM table hidden
 563        inside itself.
 564
 565        As MAGIC is always present on BMs [in Perl 5 :-)], we can use it to store
 566        the table instead of the previous (somewhat hacky) approach of co-opting
 567        the string buffer and storing it after the string.  */
 568
 569     assert(!mg_find(sv, PERL_MAGIC_bm));
 570     mg = sv_magicext(sv, NULL, PERL_MAGIC_bm, &PL_vtbl_bm, NULL, 0);
 571     assert(mg);
 572
 573     if (len > 2) {
 574         /* Shorter strings are special-cased in Perl_fbm_instr(), and don't use
 575            the BM table.  */
 576         const U8 mlen = (len>255) ? 255 : (U8)len;
 577         const unsigned char *const sb = s + len - mlen; /* first char (maybe) */
 578         U8 *table;
 579
 580         Newx(table, 256, U8);
 581         memset((void*)table, mlen, 256);
 582         mg->mg_ptr = (char *)table;
 583         mg->mg_len = 256;
 584
 585         s += len - 1; /* last char */
 586         i = 0;
 587         while (s >= sb) {
 588             if (table[*s] == mlen)
 589                 table[*s] = (U8)i;
 590             s--, i++;
 591         }
 592     }
 593
 594     s = (const unsigned char*)(SvPVX_const(sv));        /* deeper magic */
 595     for (i = 0; i < len; i++) {
 596         if (PL_freq[s[i]] < frequency) {
 597             PERL_DEB( rarest = i );
 598             frequency = PL_freq[s[i]];
 599         }
 600     }
 601     BmUSEFUL(sv) = 100;                 /* Initial value */
 602     if (flags & FBMcf_TAIL)
 603         SvTAIL_on(sv);
 604     DEBUG_r(PerlIO_printf(Perl_debug_log, "rarest char %c at %"UVuf"\n",
 605                           s[rarest], (UV)rarest));
 606 }
 607
 608 /* If SvTAIL(littlestr), it has a fake '\n' at end. */
 609 /* If SvTAIL is actually due to \Z or \z, this gives false positives
 610    if multiline */
 611
 612 /*
 613 =for apidoc fbm_instr
 614
 615 Returns the location of the SV in the string delimited by C<big> and
 616 C<bigend>.  It returns C<NULL> if the string can't be found.  The C<sv>
 617 does not have to be fbm_compiled, but the search will not be as fast
 618 then.
 619
 620 =cut
 621 */
 622
 623 char *
 624 Perl_fbm_instr(pTHX_ unsigned char *big, unsigned char *bigend, SV *littlestr, U32 flags)
 625 {
 626     unsigned char *s;
 627     STRLEN l;
 628     const unsigned char *little = (const unsigned char *)SvPV_const(littlestr,l);
 629     STRLEN littlelen = l;
 630     const I32 multiline = flags & FBMrf_MULTILINE;
 631
 632     PERL_ARGS_ASSERT_FBM_INSTR;
 633
 634     if ((STRLEN)(bigend - big) < littlelen) {
 635         if ( SvTAIL(littlestr)
 636              && ((STRLEN)(bigend - big) == littlelen - 1)
 637              && (littlelen == 1
 638                  || (*big == *little &&
 639                      memEQ((char *)big, (char *)little, littlelen - 1))))
 640             return (char*)big;
 641         return NULL;
 642     }
 643
 644     switch (littlelen) { /* Special cases for 0, 1 and 2  */
 645     case 0:
 646         return (char*)big;              /* Cannot be SvTAIL! */
 647     case 1:
 648             if (SvTAIL(littlestr) && !multiline) { /* Anchor only! */
 649                 /* Know that bigend != big.  */
 650                 if (bigend[-1] == '\n')
 651                     return (char *)(bigend - 1);
 652                 return (char *) bigend;
 653             }
 654             s = big;
 655             while (s < bigend) {
 656                 if (*s == *little)
 657                     return (char *)s;
 658                 s++;
 659             }
 660             if (SvTAIL(littlestr))
 661                 return (char *) bigend;
 662             return NULL;
 663     case 2:
 664         if (SvTAIL(littlestr) && !multiline) {
 665             if (bigend[-1] == '\n' && bigend[-2] == *little)
 666                 return (char*)bigend - 2;
 667             if (bigend[-1] == *little)
 668                 return (char*)bigend - 1;
 669             return NULL;
 670         }
 671         {
 672             /* This should be better than FBM if c1 == c2, and almost
 673                as good otherwise: maybe better since we do less indirection.
 674                And we save a lot of memory by caching no table. */
 675             const unsigned char c1 = little[0];
 676             const unsigned char c2 = little[1];
 677
 678             s = big + 1;
 679             bigend--;
 680             if (c1 != c2) {
 681                 while (s <= bigend) {
 682                     if (s[0] == c2) {
 683                         if (s[-1] == c1)
 684                             return (char*)s - 1;
 685                         s += 2;
 686                         continue;
 687                     }
 688                   next_chars:
 689                     if (s[0] == c1) {
 690                         if (s == bigend)
 691                             goto check_1char_anchor;
 692                         if (s[1] == c2)
 693                             return (char*)s;
 694                         else {
 695                             s++;
 696                             goto next_chars;
 697                         }
 698                     }
 699                     else
 700                         s += 2;
 701                 }
 702                 goto check_1char_anchor;
 703             }
 704             /* Now c1 == c2 */
 705             while (s <= bigend) {
 706                 if (s[0] == c1) {
 707                     if (s[-1] == c1)
 708                         return (char*)s - 1;
 709                     if (s == bigend)
 710                         goto check_1char_anchor;
 711                     if (s[1] == c1)
 712                         return (char*)s;
 713                     s += 3;
 714                 }
 715                 else
 716                     s += 2;
 717             }
 718         }
 719       check_1char_anchor:               /* One char and anchor! */
 720         if (SvTAIL(littlestr) && (*bigend == *little))
 721             return (char *)bigend;      /* bigend is already decremented. */
 722         return NULL;
 723     default:
 724         break; /* Only lengths 0 1 and 2 have special-case code.  */
 725     }
 726
 727     if (SvTAIL(littlestr) && !multiline) {      /* tail anchored? */
 728         s = bigend - littlelen;
 729         if (s >= big && bigend[-1] == '\n' && *s == *little
 730             /* Automatically of length > 2 */
 731             && memEQ((char*)s + 1, (char*)little + 1, littlelen - 2))
 732         {
 733             return (char*)s;            /* how sweet it is */
 734         }
 735         if (s[1] == *little
 736             && memEQ((char*)s + 2, (char*)little + 1, littlelen - 2))
 737         {
 738             return (char*)s + 1;        /* how sweet it is */
 739         }
 740         return NULL;
 741     }
 742     if (!SvVALID(littlestr)) {
 743         char * const b = ninstr((char*)big,(char*)bigend,
 744                          (char*)little, (char*)little + littlelen);
 745
 746         if (!b && SvTAIL(littlestr)) {  /* Automatically multiline!  */
 747             /* Chop \n from littlestr: */
 748             s = bigend - littlelen + 1;
 749             if (*s == *little
 750                 && memEQ((char*)s + 1, (char*)little + 1, littlelen - 2))
 751             {
 752                 return (char*)s;
 753             }
 754             return NULL;
 755         }
 756         return b;
 757     }
 758
 759     /* Do actual FBM.  */
 760     if (littlelen > (STRLEN)(bigend - big))
 761         return NULL;
 762
 763     {
 764         const MAGIC *const mg = mg_find(littlestr, PERL_MAGIC_bm);
 765         const unsigned char * const table = (const unsigned char *) mg->mg_ptr;
 766         const unsigned char *oldlittle;
 767
 768         --littlelen;                    /* Last char found by table lookup */
 769
 770         s = big + littlelen;
 771         little += littlelen;            /* last char */
 772         oldlittle = little;
 773         if (s < bigend) {
 774             I32 tmp;
 775
 776           top2:
 777             if ((tmp = table[*s])) {
 778                 if ((s += tmp) < bigend)
 779                     goto top2;
 780                 goto check_end;
 781             }
 782             else {              /* less expensive than calling strncmp() */
 783                 unsigned char * const olds = s;
 784
 785                 tmp = littlelen;
 786
 787                 while (tmp--) {
 788                     if (*--s == *--little)
 789                         continue;
 790                     s = olds + 1;       /* here we pay the price for failure */
 791                     little = oldlittle;
 792                     if (s < bigend)     /* fake up continue to outer loop */
 793                         goto top2;
 794                     goto check_end;
 795                 }
 796                 return (char *)s;
 797             }
 798         }
 799       check_end:
 800         if ( s == bigend
 801              && SvTAIL(littlestr)
 802              && memEQ((char *)(bigend - littlelen),
 803                       (char *)(oldlittle - littlelen), littlelen) )
 804             return (char*)bigend - littlelen;
 805         return NULL;
 806     }
 807 }
 808
 809 char *
 810 Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift, I32 *old_posp, I32 last)
 811 {
 812     dVAR;
 813     PERL_ARGS_ASSERT_SCREAMINSTR;
 814     PERL_UNUSED_ARG(bigstr);
 815     PERL_UNUSED_ARG(littlestr);
 816     PERL_UNUSED_ARG(start_shift);
 817     PERL_UNUSED_ARG(end_shift);
 818     PERL_UNUSED_ARG(old_posp);
 819     PERL_UNUSED_ARG(last);
 820
 821     /* This function must only ever be called on a scalar with study magic,
 822        but those do not happen any more. */
 823     Perl_croak(aTHX_ "panic: screaminstr");
 824     return NULL;
 825 }
 826
 827 /*
 828 =for apidoc foldEQ
 829
 830 Returns true if the leading len bytes of the strings s1 and s2 are the same
 831 case-insensitively; false otherwise.  Uppercase and lowercase ASCII range bytes
 832 match themselves and their opposite case counterparts.  Non-cased and non-ASCII
 833 range bytes match only themselves.
 834
 835 =cut
 836 */
 837
 838
 839 I32
 840 Perl_foldEQ(const char *s1, const char *s2, I32 len)
 841 {
 842     const U8 *a = (const U8 *)s1;
 843     const U8 *b = (const U8 *)s2;
 844
 845     PERL_ARGS_ASSERT_FOLDEQ;
 846
 847     assert(len >= 0);
 848
 849     while (len--) {
 850         if (*a != *b && *a != PL_fold[*b])
 851             return 0;
 852         a++,b++;
 853     }
 854     return 1;
 855 }
 856 I32
 857 Perl_foldEQ_latin1(const char *s1, const char *s2, I32 len)
 858 {
 859     /* Compare non-utf8 using Unicode (Latin1) semantics.  Does not work on
 860      * MICRO_SIGN, LATIN_SMALL_LETTER_SHARP_S, nor
 861      * LATIN_SMALL_LETTER_Y_WITH_DIAERESIS, and does not check for these.  Nor
 862      * does it check that the strings each have at least 'len' characters */
 863
 864     const U8 *a = (const U8 *)s1;
 865     const U8 *b = (const U8 *)s2;
 866
 867     PERL_ARGS_ASSERT_FOLDEQ_LATIN1;
 868
 869     assert(len >= 0);
 870
 871     while (len--) {
 872         if (*a != *b && *a != PL_fold_latin1[*b]) {
 873             return 0;
 874         }
 875         a++, b++;
 876     }
 877     return 1;
 878 }
 879
 880 /*
 881 =for apidoc foldEQ_locale
 882
 883 Returns true if the leading len bytes of the strings s1 and s2 are the same
 884 case-insensitively in the current locale; false otherwise.
 885
 886 =cut
 887 */
 888
 889 I32
 890 Perl_foldEQ_locale(const char *s1, const char *s2, I32 len)
 891 {
 892     dVAR;
 893     const U8 *a = (const U8 *)s1;
 894     const U8 *b = (const U8 *)s2;
 895
 896     PERL_ARGS_ASSERT_FOLDEQ_LOCALE;
 897
 898     assert(len >= 0);
 899
 900     while (len--) {
 901         if (*a != *b && *a != PL_fold_locale[*b])
 902             return 0;
 903         a++,b++;
 904     }
 905     return 1;
 906 }
 907
 908 /* copy a string to a safe spot */
 909
 910 /*
 911 =head1 Memory Management
 912
 913 =for apidoc savepv
 914
 915 Perl's version of C<strdup()>. Returns a pointer to a newly allocated
 916 string which is a duplicate of C<pv>. The size of the string is
 917 determined by C<strlen()>. The memory allocated for the new string can
 918 be freed with the C<Safefree()> function.
 919
 920 =cut
 921 */
 922
 923 char *
 924 Perl_savepv(pTHX_ const char *pv)
 925 {
 926     PERL_UNUSED_CONTEXT;
 927     if (!pv)
 928         return NULL;
 929     else {
 930         char *newaddr;
 931         const STRLEN pvlen = strlen(pv)+1;
 932         Newx(newaddr, pvlen, char);
 933         return (char*)memcpy(newaddr, pv, pvlen);
 934     }
 935 }
 936
 937 /* same thing but with a known length */
 938
 939 /*
 940 =for apidoc savepvn
 941
 942 Perl's version of what C<strndup()> would be if it existed. Returns a
 943 pointer to a newly allocated string which is a duplicate of the first
 944 C<len> bytes from C<pv>, plus a trailing NUL byte. The memory allocated for
 945 the new string can be freed with the C<Safefree()> function.
 946
 947 =cut
 948 */
 949
 950 char *
 951 Perl_savepvn(pTHX_ const char *pv, I32 len)
 952 {
 953     char *newaddr;
 954     PERL_UNUSED_CONTEXT;
 955
 956     assert(len >= 0);
 957
 958     Newx(newaddr,len+1,char);
 959     /* Give a meaning to NULL pointer mainly for the use in sv_magic() */
 960     if (pv) {
 961         /* might not be null terminated */
 962         newaddr[len] = '\0';
 963         return (char *) CopyD(pv,newaddr,len,char);
 964     }
 965     else {
 966         return (char *) ZeroD(newaddr,len+1,char);
 967     }
 968 }
 969
 970 /*
 971 =for apidoc savesharedpv
 972
 973 A version of C<savepv()> which allocates the duplicate string in memory
 974 which is shared between threads.
 975
 976 =cut
 977 */
 978 char *
 979 Perl_savesharedpv(pTHX_ const char *pv)
 980 {
 981     char *newaddr;
 982     STRLEN pvlen;
 983     if (!pv)
 984         return NULL;
 985
 986     pvlen = strlen(pv)+1;
 987     newaddr = (char*)PerlMemShared_malloc(pvlen);
 988     if (!newaddr) {
 989         croak_no_mem();
 990     }
 991     return (char*)memcpy(newaddr, pv, pvlen);
 992 }
 993
 994 /*
 995 =for apidoc savesharedpvn
 996
 997 A version of C<savepvn()> which allocates the duplicate string in memory
 998 which is shared between threads. (With the specific difference that a NULL
 999 pointer is not acceptable)
1000
1001 =cut
1002 */
1003 char *
1004 Perl_savesharedpvn(pTHX_ const char *const pv, const STRLEN len)
1005 {
1006     char *const newaddr = (char*)PerlMemShared_malloc(len + 1);
1007
1008     /* PERL_ARGS_ASSERT_SAVESHAREDPVN; */
1009
1010     if (!newaddr) {
1011         croak_no_mem();
1012     }
1013     newaddr[len] = '\0';
1014     return (char*)memcpy(newaddr, pv, len);
1015 }
1016
1017 /*
1018 =for apidoc savesvpv
1019
1020 A version of C<savepv()>/C<savepvn()> which gets the string to duplicate from
1021 the passed in SV using C<SvPV()>
1022
1023 =cut
1024 */
1025
1026 char *
1027 Perl_savesvpv(pTHX_ SV *sv)
1028 {
1029     STRLEN len;
1030     const char * const pv = SvPV_const(sv, len);
1031     char *newaddr;
1032
1033     PERL_ARGS_ASSERT_SAVESVPV;
1034
1035     ++len;
1036     Newx(newaddr,len,char);
1037     return (char *) CopyD(pv,newaddr,len,char);
1038 }
1039
1040 /*
1041 =for apidoc savesharedsvpv
1042
1043 A version of C<savesharedpv()> which allocates the duplicate string in
1044 memory which is shared between threads.
1045
1046 =cut
1047 */
1048
1049 char *
1050 Perl_savesharedsvpv(pTHX_ SV *sv)
1051 {
1052     STRLEN len;
1053     const char * const pv = SvPV_const(sv, len);
1054
1055     PERL_ARGS_ASSERT_SAVESHAREDSVPV;
1056
1057     return savesharedpvn(pv, len);
1058 }
1059
1060 /* the SV for Perl_form() and mess() is not kept in an arena */
1061
1062 STATIC SV *
1063 S_mess_alloc(pTHX)
1064 {
1065     dVAR;
1066     SV *sv;
1067     XPVMG *any;
1068
1069     if (PL_phase != PERL_PHASE_DESTRUCT)
1070         return newSVpvs_flags("", SVs_TEMP);
1071
1072     if (PL_mess_sv)
1073         return PL_mess_sv;
1074
1075     /* Create as PVMG now, to avoid any upgrading later */
1076     Newx(sv, 1, SV);
1077     Newxz(any, 1, XPVMG);
1078     SvFLAGS(sv) = SVt_PVMG;
1079     SvANY(sv) = (void*)any;
1080     SvPV_set(sv, NULL);
1081     SvREFCNT(sv) = 1 << 30; /* practically infinite */
1082     PL_mess_sv = sv;
1083     return sv;
1084 }
1085
1086 #if defined(PERL_IMPLICIT_CONTEXT)
1087 char *
1088 Perl_form_nocontext(const char* pat, ...)
1089 {
1090     dTHX;
1091     char *retval;
1092     va_list args;
1093     PERL_ARGS_ASSERT_FORM_NOCONTEXT;
1094     va_start(args, pat);
1095     retval = vform(pat, &args);
1096     va_end(args);
1097     return retval;
1098 }
1099 #endif /* PERL_IMPLICIT_CONTEXT */
1100
1101 /*
1102 =head1 Miscellaneous Functions
1103 =for apidoc form
1104
1105 Takes a sprintf-style format pattern and conventional
1106 (non-SV) arguments and returns the formatted string.
1107
1108     (char *) Perl_form(pTHX_ const char* pat, ...)
1109
1110 can be used any place a string (char *) is required:
1111
1112     char * s = Perl_form("%d.%d",major,minor);
1113
1114 Uses a single private buffer so if you want to format several strings you
1115 must explicitly copy the earlier strings away (and free the copies when you
1116 are done).
1117
1118 =cut
1119 */
1120
1121 char *
1122 Perl_form(pTHX_ const char* pat, ...)
1123 {
1124     char *retval;
1125     va_list args;
1126     PERL_ARGS_ASSERT_FORM;
1127     va_start(args, pat);
1128     retval = vform(pat, &args);
1129     va_end(args);
1130     return retval;
1131 }
1132
1133 char *
1134 Perl_vform(pTHX_ const char *pat, va_list *args)
1135 {
1136     SV * const sv = mess_alloc();
1137     PERL_ARGS_ASSERT_VFORM;
1138     sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
1139     return SvPVX(sv);
1140 }
1141
1142 /*
1143 =for apidoc Am|SV *|mess|const char *pat|...
1144
1145 Take a sprintf-style format pattern and argument list.  These are used to
1146 generate a string message.  If the message does not end with a newline,
1147 then it will be extended with some indication of the current location
1148 in the code, as described for L</mess_sv>.
1149
1150 Normally, the resulting message is returned in a new mortal SV.
1151 During global destruction a single SV may be shared between uses of
1152 this function.
1153
1154 =cut
1155 */
1156
1157 #if defined(PERL_IMPLICIT_CONTEXT)
1158 SV *
1159 Perl_mess_nocontext(const char *pat, ...)
1160 {
1161     dTHX;
1162     SV *retval;
1163     va_list args;
1164     PERL_ARGS_ASSERT_MESS_NOCONTEXT;
1165     va_start(args, pat);
1166     retval = vmess(pat, &args);
1167     va_end(args);
1168     return retval;
1169 }
1170 #endif /* PERL_IMPLICIT_CONTEXT */
1171
1172 SV *
1173 Perl_mess(pTHX_ const char *pat, ...)
1174 {
1175     SV *retval;
1176     va_list args;
1177     PERL_ARGS_ASSERT_MESS;
1178     va_start(args, pat);
1179     retval = vmess(pat, &args);
1180     va_end(args);
1181     return retval;
1182 }
1183
1184 const COP*
1185 Perl_closest_cop(pTHX_ const COP *cop, const OP *o, const OP *curop,
1186                        bool opnext)
1187 {
1188     dVAR;
1189     /* Look for curop starting from o.  cop is the last COP we've seen. */
1190     /* opnext means that curop is actually the ->op_next of the op we are
1191        seeking. */
1192
1193     PERL_ARGS_ASSERT_CLOSEST_COP;
1194
1195     if (!o || !curop || (
1196         opnext ? o->op_next == curop && o->op_type != OP_SCOPE : o == curop
1197     ))
1198         return cop;
1199
1200     if (o->op_flags & OPf_KIDS) {
1201         const OP *kid;
1202         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
1203             const COP *new_cop;
1204
1205             /* If the OP_NEXTSTATE has been optimised away we can still use it
1206              * the get the file and line number. */
1207
1208             if (kid->op_type == OP_NULL && kid->op_targ == OP_NEXTSTATE)
1209                 cop = (const COP *)kid;
1210
1211             /* Keep searching, and return when we've found something. */
1212
1213             new_cop = closest_cop(cop, kid, curop, opnext);
1214             if (new_cop)
1215                 return new_cop;
1216         }
1217     }
1218
1219     /* Nothing found. */
1220
1221     return NULL;
1222 }
1223
1224 /*
1225 =for apidoc Am|SV *|mess_sv|SV *basemsg|bool consume
1226
1227 Expands a message, intended for the user, to include an indication of
1228 the current location in the code, if the message does not already appear
1229 to be complete.
1230
1231 C<basemsg> is the initial message or object.  If it is a reference, it
1232 will be used as-is and will be the result of this function.  Otherwise it
1233 is used as a string, and if it already ends with a newline, it is taken
1234 to be complete, and the result of this function will be the same string.
1235 If the message does not end with a newline, then a segment such as C<at
1236 foo.pl line 37> will be appended, and possibly other clauses indicating
1237 the current state of execution.  The resulting message will end with a
1238 dot and a newline.
1239
1240 Normally, the resulting message is returned in a new mortal SV.
1241 During global destruction a single SV may be shared between uses of this
1242 function.  If C<consume> is true, then the function is permitted (but not
1243 required) to modify and return C<basemsg> instead of allocating a new SV.
1244
1245 =cut
1246 */
1247
1248 SV *
1249 Perl_mess_sv(pTHX_ SV *basemsg, bool consume)
1250 {
1251     dVAR;
1252     SV *sv;
1253
1254     PERL_ARGS_ASSERT_MESS_SV;
1255
1256     if (SvROK(basemsg)) {
1257         if (consume) {
1258             sv = basemsg;
1259         }
1260         else {
1261             sv = mess_alloc();
1262             sv_setsv(sv, basemsg);
1263         }
1264         return sv;
1265     }
1266
1267     if (SvPOK(basemsg) && consume) {
1268         sv = basemsg;
1269     }
1270     else {
1271         sv = mess_alloc();
1272         sv_copypv(sv, basemsg);
1273     }
1274
1275     if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') {
1276         /*
1277          * Try and find the file and line for PL_op.  This will usually be
1278          * PL_curcop, but it might be a cop that has been optimised away.  We
1279          * can try to find such a cop by searching through the optree starting
1280          * from the sibling of PL_curcop.
1281          */
1282
1283         const COP *cop =
1284             closest_cop(PL_curcop, PL_curcop->op_sibling, PL_op, FALSE);
1285         if (!cop)
1286             cop = PL_curcop;
1287
1288         if (CopLINE(cop))
1289             Perl_sv_catpvf(aTHX_ sv, " at %s line %"IVdf,
1290             OutCopFILE(cop), (IV)CopLINE(cop));
1291         /* Seems that GvIO() can be untrustworthy during global destruction. */
1292         if (GvIO(PL_last_in_gv) && (SvTYPE(GvIOp(PL_last_in_gv)) == SVt_PVIO)
1293                 && IoLINES(GvIOp(PL_last_in_gv)))
1294         {
1295             STRLEN l;
1296             const bool line_mode = (RsSIMPLE(PL_rs) &&
1297                                    *SvPV_const(PL_rs,l) == '\n' && l == 1);
1298             Perl_sv_catpvf(aTHX_ sv, ", <%"SVf"> %s %"IVdf,
1299                            SVfARG(PL_last_in_gv == PL_argvgv
1300                                  ? &PL_sv_no
1301                                  : sv_2mortal(newSVhek(GvNAME_HEK(PL_last_in_gv)))),
1302                            line_mode ? "line" : "chunk",
1303                            (IV)IoLINES(GvIOp(PL_last_in_gv)));
1304         }
1305         if (PL_phase == PERL_PHASE_DESTRUCT)
1306             sv_catpvs(sv, " during global destruction");
1307         sv_catpvs(sv, ".\n");
1308     }
1309     return sv;
1310 }
1311
1312 /*
1313 =for apidoc Am|SV *|vmess|const char *pat|va_list *args
1314
1315 C<pat> and C<args> are a sprintf-style format pattern and encapsulated
1316 argument list.  These are used to generate a string message.  If the
1317 message does not end with a newline, then it will be extended with
1318 some indication of the current location in the code, as described for
1319 L</mess_sv>.
1320
1321 Normally, the resulting message is returned in a new mortal SV.
1322 During global destruction a single SV may be shared between uses of
1323 this function.
1324
1325 =cut
1326 */
1327
1328 SV *
1329 Perl_vmess(pTHX_ const char *pat, va_list *args)
1330 {
1331     dVAR;
1332     SV * const sv = mess_alloc();
1333
1334     PERL_ARGS_ASSERT_VMESS;
1335
1336     sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
1337     return mess_sv(sv, 1);
1338 }
1339
1340 void
1341 Perl_write_to_stderr(pTHX_ SV* msv)
1342 {
1343     dVAR;
1344     IO *io;
1345     MAGIC *mg;
1346
1347     PERL_ARGS_ASSERT_WRITE_TO_STDERR;
1348
1349     if (PL_stderrgv && SvREFCNT(PL_stderrgv)
1350         && (io = GvIO(PL_stderrgv))
1351         && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
1352         Perl_magic_methcall(aTHX_ MUTABLE_SV(io), mg, SV_CONST(PRINT),
1353                             G_SCALAR | G_DISCARD | G_WRITING_TO_STDERR, 1, msv);
1354     else {
1355 #ifdef USE_SFIO
1356         /* SFIO can really mess with your errno */
1357         dSAVED_ERRNO;
1358 #endif
1359         PerlIO * const serr = Perl_error_log;
1360
1361         do_print(msv, serr);
1362         (void)PerlIO_flush(serr);
1363 #ifdef USE_SFIO
1364         RESTORE_ERRNO;
1365 #endif
1366     }
1367 }
1368
1369 /*
1370 =head1 Warning and Dieing
1371 */
1372
1373 /* Common code used in dieing and warning */
1374
1375 STATIC SV *
1376 S_with_queued_errors(pTHX_ SV *ex)
1377 {
1378     PERL_ARGS_ASSERT_WITH_QUEUED_ERRORS;
1379     if (PL_errors && SvCUR(PL_errors) && !SvROK(ex)) {
1380         sv_catsv(PL_errors, ex);
1381         ex = sv_mortalcopy(PL_errors);
1382         SvCUR_set(PL_errors, 0);
1383     }
1384     return ex;
1385 }
1386
1387 STATIC bool
1388 S_invoke_exception_hook(pTHX_ SV *ex, bool warn)
1389 {
1390     dVAR;
1391     HV *stash;
1392     GV *gv;
1393     CV *cv;
1394     SV **const hook = warn ? &PL_warnhook : &PL_diehook;
1395     /* sv_2cv might call Perl_croak() or Perl_warner() */
1396     SV * const oldhook = *hook;
1397
1398     if (!oldhook)
1399         return FALSE;
1400
1401     ENTER;
1402     SAVESPTR(*hook);
1403     *hook = NULL;
1404     cv = sv_2cv(oldhook, &stash, &gv, 0);
1405     LEAVE;
1406     if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
1407         dSP;
1408         SV *exarg;
1409
1410         ENTER;
1411         save_re_context();
1412         if (warn) {
1413             SAVESPTR(*hook);
1414             *hook = NULL;
1415         }
1416         exarg = newSVsv(ex);
1417         SvREADONLY_on(exarg);
1418         SAVEFREESV(exarg);
1419
1420         PUSHSTACKi(warn ? PERLSI_WARNHOOK : PERLSI_DIEHOOK);
1421         PUSHMARK(SP);
1422         XPUSHs(exarg);
1423         PUTBACK;
1424         call_sv(MUTABLE_SV(cv), G_DISCARD);
1425         POPSTACK;
1426         LEAVE;
1427         return TRUE;
1428     }
1429     return FALSE;
1430 }
1431
1432 /*
1433 =for apidoc Am|OP *|die_sv|SV *baseex
1434
1435 Behaves the same as L</croak_sv>, except for the return type.
1436 It should be used only where the C<OP *> return type is required.
1437 The function never actually returns.
1438
1439 =cut
1440 */
1441
1442 OP *
1443 Perl_die_sv(pTHX_ SV *baseex)
1444 {
1445     PERL_ARGS_ASSERT_DIE_SV;
1446     croak_sv(baseex);
1447     assert(0); /* NOTREACHED */
1448     return NULL;
1449 }
1450
1451 /*
1452 =for apidoc Am|OP *|die|const char *pat|...
1453
1454 Behaves the same as L</croak>, except for the return type.
1455 It should be used only where the C<OP *> return type is required.
1456 The function never actually returns.
1457
1458 =cut
1459 */
1460
1461 #if defined(PERL_IMPLICIT_CONTEXT)
1462 OP *
1463 Perl_die_nocontext(const char* pat, ...)
1464 {
1465     dTHX;
1466     va_list args;
1467     va_start(args, pat);
1468     vcroak(pat, &args);
1469     assert(0); /* NOTREACHED */
1470     va_end(args);
1471     return NULL;
1472 }
1473 #endif /* PERL_IMPLICIT_CONTEXT */
1474
1475 OP *
1476 Perl_die(pTHX_ const char* pat, ...)
1477 {
1478     va_list args;
1479     va_start(args, pat);
1480     vcroak(pat, &args);
1481     assert(0); /* NOTREACHED */
1482     va_end(args);
1483     return NULL;
1484 }
1485
1486 /*
1487 =for apidoc Am|void|croak_sv|SV *baseex
1488
1489 This is an XS interface to Perl's C<die> function.
1490
1491 C<baseex> is the error message or object.  If it is a reference, it
1492 will be used as-is.  Otherwise it is used as a string, and if it does
1493 not end with a newline then it will be extended with some indication of
1494 the current location in the code, as described for L</mess_sv>.
1495
1496 The error message or object will be used as an exception, by default
1497 returning control to the nearest enclosing C<eval>, but subject to
1498 modification by a C<$SIG{__DIE__}> handler.  In any case, the C<croak_sv>
1499 function never returns normally.
1500
1501 To die with a simple string message, the L</croak> function may be
1502 more convenient.
1503
1504 =cut
1505 */
1506
1507 void
1508 Perl_croak_sv(pTHX_ SV *baseex)
1509 {
1510     SV *ex = with_queued_errors(mess_sv(baseex, 0));
1511     PERL_ARGS_ASSERT_CROAK_SV;
1512     invoke_exception_hook(ex, FALSE);
1513     die_unwind(ex);
1514 }
1515
1516 /*
1517 =for apidoc Am|void|vcroak|const char *pat|va_list *args
1518
1519 This is an XS interface to Perl's C<die> function.
1520
1521 C<pat> and C<args> are a sprintf-style format pattern and encapsulated
1522 argument list.  These are used to generate a string message.  If the
1523 message does not end with a newline, then it will be extended with
1524 some indication of the current location in the code, as described for
1525 L</mess_sv>.
1526
1527 The error message will be used as an exception, by default
1528 returning control to the nearest enclosing C<eval>, but subject to
1529 modification by a C<$SIG{__DIE__}> handler.  In any case, the C<croak>
1530 function never returns normally.
1531
1532 For historical reasons, if C<pat> is null then the contents of C<ERRSV>
1533 (C<$@>) will be used as an error message or object instead of building an
1534 error message from arguments.  If you want to throw a non-string object,
1535 or build an error message in an SV yourself, it is preferable to use
1536 the L</croak_sv> function, which does not involve clobbering C<ERRSV>.
1537
1538 =cut
1539 */
1540
1541 void
1542 Perl_vcroak(pTHX_ const char* pat, va_list *args)
1543 {
1544     SV *ex = with_queued_errors(pat ? vmess(pat, args) : mess_sv(ERRSV, 0));
1545     invoke_exception_hook(ex, FALSE);
1546     die_unwind(ex);
1547 }
1548
1549 /*
1550 =for apidoc Am|void|croak|const char *pat|...
1551
1552 This is an XS interface to Perl's C<die> function.
1553
1554 Take a sprintf-style format pattern and argument list.  These are used to
1555 generate a string message.  If the message does not end with a newline,
1556 then it will be extended with some indication of the current location
1557 in the code, as described for L</mess_sv>.
1558
1559 The error message will be used as an exception, by default
1560 returning control to the nearest enclosing C<eval>, but subject to
1561 modification by a C<$SIG{__DIE__}> handler.  In any case, the C<croak>
1562 function never returns normally.
1563
1564 For historical reasons, if C<pat> is null then the contents of C<ERRSV>
1565 (C<$@>) will be used as an error message or object instead of building an
1566 error message from arguments.  If you want to throw a non-string object,
1567 or build an error message in an SV yourself, it is preferable to use
1568 the L</croak_sv> function, which does not involve clobbering C<ERRSV>.
1569
1570 =cut
1571 */
1572
1573 #if defined(PERL_IMPLICIT_CONTEXT)
1574 void
1575 Perl_croak_nocontext(const char *pat, ...)
1576 {
1577     dTHX;
1578     va_list args;
1579     va_start(args, pat);
1580     vcroak(pat, &args);
1581     assert(0); /* NOTREACHED */
1582     va_end(args);
1583 }
1584 #endif /* PERL_IMPLICIT_CONTEXT */
1585
1586 void
1587 Perl_croak(pTHX_ const char *pat, ...)
1588 {
1589     va_list args;
1590     va_start(args, pat);
1591     vcroak(pat, &args);
1592     assert(0); /* NOTREACHED */
1593     va_end(args);
1594 }
1595
1596 /*
1597 =for apidoc Am|void|croak_no_modify
1598
1599 Exactly equivalent to C<Perl_croak(aTHX_ "%s", PL_no_modify)>, but generates
1600 terser object code than using C<Perl_croak>. Less code used on exception code
1601 paths reduces CPU cache pressure.
1602
1603 =cut
1604 */
1605
1606 void
1607 Perl_croak_no_modify()
1608 {
1609     Perl_croak_nocontext( "%s", PL_no_modify);
1610 }
1611
1612 /* does not return, used in util.c perlio.c and win32.c
1613    This is typically called when malloc returns NULL.
1614 */
1615 void
1616 Perl_croak_no_mem()
1617 {
1618     dTHX;
1619
1620     /* Can't use PerlIO to write as it allocates memory */
1621     PerlLIO_write(PerlIO_fileno(Perl_error_log),
1622                   PL_no_mem, sizeof(PL_no_mem)-1);
1623     my_exit(1);
1624 }
1625
1626 /* does not return, used only in POPSTACK */
1627 void
1628 Perl_croak_popstack(void)
1629 {
1630     dTHX;
1631     PerlIO_printf(Perl_error_log, "panic: POPSTACK\n");
1632     my_exit(1);
1633 }
1634
1635 /*
1636 =for apidoc Am|void|warn_sv|SV *baseex
1637
1638 This is an XS interface to Perl's C<warn> function.
1639
1640 C<baseex> is the error message or object.  If it is a reference, it
1641 will be used as-is.  Otherwise it is used as a string, and if it does
1642 not end with a newline then it will be extended with some indication of
1643 the current location in the code, as described for L</mess_sv>.
1644
1645 The error message or object will by default be written to standard error,
1646 but this is subject to modification by a C<$SIG{__WARN__}> handler.
1647
1648 To warn with a simple string message, the L</warn> function may be
1649 more convenient.
1650
1651 =cut
1652 */
1653
1654 void
1655 Perl_warn_sv(pTHX_ SV *baseex)
1656 {
1657     SV *ex = mess_sv(baseex, 0);
1658     PERL_ARGS_ASSERT_WARN_SV;
1659     if (!invoke_exception_hook(ex, TRUE))
1660         write_to_stderr(ex);
1661 }
1662
1663 /*
1664 =for apidoc Am|void|vwarn|const char *pat|va_list *args
1665
1666 This is an XS interface to Perl's C<warn> function.
1667
1668 C<pat> and C<args> are a sprintf-style format pattern and encapsulated
1669 argument list.  These are used to generate a string message.  If the
1670 message does not end with a newline, then it will be extended with
1671 some indication of the current location in the code, as described for
1672 L</mess_sv>.
1673
1674 The error message or object will by default be written to standard error,
1675 but this is subject to modification by a C<$SIG{__WARN__}> handler.
1676
1677 Unlike with L</vcroak>, C<pat> is not permitted to be null.
1678
1679 =cut
1680 */
1681
1682 void
1683 Perl_vwarn(pTHX_ const char* pat, va_list *args)
1684 {
1685     SV *ex = vmess(pat, args);
1686     PERL_ARGS_ASSERT_VWARN;
1687     if (!invoke_exception_hook(ex, TRUE))
1688         write_to_stderr(ex);
1689 }
1690
1691 /*
1692 =for apidoc Am|void|warn|const char *pat|...
1693
1694 This is an XS interface to Perl's C<warn> function.
1695
1696 Take a sprintf-style format pattern and argument list.  These are used to
1697 generate a string message.  If the message does not end with a newline,
1698 then it will be extended with some indication of the current location
1699 in the code, as described for L</mess_sv>.
1700
1701 The error message or object will by default be written to standard error,
1702 but this is subject to modification by a C<$SIG{__WARN__}> handler.
1703
1704 Unlike with L</croak>, C<pat> is not permitted to be null.
1705
1706 =cut
1707 */
1708
1709 #if defined(PERL_IMPLICIT_CONTEXT)
1710 void
1711 Perl_warn_nocontext(const char *pat, ...)
1712 {
1713     dTHX;
1714     va_list args;
1715     PERL_ARGS_ASSERT_WARN_NOCONTEXT;
1716     va_start(args, pat);
1717     vwarn(pat, &args);
1718     va_end(args);
1719 }
1720 #endif /* PERL_IMPLICIT_CONTEXT */
1721
1722 void
1723 Perl_warn(pTHX_ const char *pat, ...)
1724 {
1725     va_list args;
1726     PERL_ARGS_ASSERT_WARN;
1727     va_start(args, pat);
1728     vwarn(pat, &args);
1729     va_end(args);
1730 }
1731
1732 #if defined(PERL_IMPLICIT_CONTEXT)
1733 void
1734 Perl_warner_nocontext(U32 err, const char *pat, ...)
1735 {
1736     dTHX;
1737     va_list args;
1738     PERL_ARGS_ASSERT_WARNER_NOCONTEXT;
1739     va_start(args, pat);
1740     vwarner(err, pat, &args);
1741     va_end(args);
1742 }
1743 #endif /* PERL_IMPLICIT_CONTEXT */
1744
1745 void
1746 Perl_ck_warner_d(pTHX_ U32 err, const char* pat, ...)
1747 {
1748     PERL_ARGS_ASSERT_CK_WARNER_D;
1749
1750     if (Perl_ckwarn_d(aTHX_ err)) {
1751         va_list args;
1752         va_start(args, pat);
1753         vwarner(err, pat, &args);
1754         va_end(args);
1755     }
1756 }
1757
1758 void
1759 Perl_ck_warner(pTHX_ U32 err, const char* pat, ...)
1760 {
1761     PERL_ARGS_ASSERT_CK_WARNER;
1762
1763     if (Perl_ckwarn(aTHX_ err)) {
1764         va_list args;
1765         va_start(args, pat);
1766         vwarner(err, pat, &args);
1767         va_end(args);
1768     }
1769 }
1770
1771 void
1772 Perl_warner(pTHX_ U32  err, const char* pat,...)
1773 {
1774     va_list args;
1775     PERL_ARGS_ASSERT_WARNER;
1776     va_start(args, pat);
1777     vwarner(err, pat, &args);
1778     va_end(args);
1779 }
1780
1781 void
1782 Perl_vwarner(pTHX_ U32  err, const char* pat, va_list* args)
1783 {
1784     dVAR;
1785     PERL_ARGS_ASSERT_VWARNER;
1786     if (PL_warnhook == PERL_WARNHOOK_FATAL || ckDEAD(err)) {
1787         SV * const msv = vmess(pat, args);
1788
1789         invoke_exception_hook(msv, FALSE);
1790         die_unwind(msv);
1791     }
1792     else {
1793         Perl_vwarn(aTHX_ pat, args);
1794     }
1795 }
1796
1797 /* implements the ckWARN? macros */
1798
1799 bool
1800 Perl_ckwarn(pTHX_ U32 w)
1801 {
1802     dVAR;
1803     /* If lexical warnings have not been set, use $^W.  */
1804     if (isLEXWARN_off)
1805         return PL_dowarn & G_WARN_ON;
1806
1807     return ckwarn_common(w);
1808 }
1809
1810 /* implements the ckWARN?_d macro */
1811
1812 bool
1813 Perl_ckwarn_d(pTHX_ U32 w)
1814 {
1815     dVAR;
1816     /* If lexical warnings have not been set then default classes warn.  */
1817     if (isLEXWARN_off)
1818         return TRUE;
1819
1820     return ckwarn_common(w);
1821 }
1822
1823 static bool
1824 S_ckwarn_common(pTHX_ U32 w)
1825 {
1826     if (PL_curcop->cop_warnings == pWARN_ALL)
1827         return TRUE;
1828
1829     if (PL_curcop->cop_warnings == pWARN_NONE)
1830         return FALSE;
1831
1832     /* Check the assumption that at least the first slot is non-zero.  */
1833     assert(unpackWARN1(w));
1834
1835     /* Check the assumption that it is valid to stop as soon as a zero slot is
1836        seen.  */
1837     if (!unpackWARN2(w)) {
1838         assert(!unpackWARN3(w));
1839         assert(!unpackWARN4(w));
1840     } else if (!unpackWARN3(w)) {
1841         assert(!unpackWARN4(w));
1842     }
1843
1844     /* Right, dealt with all the special cases, which are implemented as non-
1845        pointers, so there is a pointer to a real warnings mask.  */
1846     do {
1847         if (isWARN_on(PL_curcop->cop_warnings, unpackWARN1(w)))
1848             return TRUE;
1849     } while (w >>= WARNshift);
1850
1851     return FALSE;
1852 }
1853
1854 /* Set buffer=NULL to get a new one.  */
1855 STRLEN *
1856 Perl_new_warnings_bitfield(pTHX_ STRLEN *buffer, const char *const bits,
1857                            STRLEN size) {
1858     const MEM_SIZE len_wanted =
1859         sizeof(STRLEN) + (size > WARNsize ? size : WARNsize);
1860     PERL_UNUSED_CONTEXT;
1861     PERL_ARGS_ASSERT_NEW_WARNINGS_BITFIELD;
1862
1863     buffer = (STRLEN*)
1864         (specialWARN(buffer) ?
1865          PerlMemShared_malloc(len_wanted) :
1866          PerlMemShared_realloc(buffer, len_wanted));
1867     buffer[0] = size;
1868     Copy(bits, (buffer + 1), size, char);
1869     if (size < WARNsize)
1870         Zero((char *)(buffer + 1) + size, WARNsize - size, char);
1871     return buffer;
1872 }
1873
1874 /* since we've already done strlen() for both nam and val
1875  * we can use that info to make things faster than
1876  * sprintf(s, "%s=%s", nam, val)
1877  */
1878 #define my_setenv_format(s, nam, nlen, val, vlen) \
1879    Copy(nam, s, nlen, char); \
1880    *(s+nlen) = '='; \
1881    Copy(val, s+(nlen+1), vlen, char); \
1882    *(s+(nlen+1+vlen)) = '\0'
1883
1884 #ifdef USE_ENVIRON_ARRAY
1885        /* VMS' my_setenv() is in vms.c */
1886 #if !defined(WIN32) && !defined(NETWARE)
1887 void
1888 Perl_my_setenv(pTHX_ const char *nam, const char *val)
1889 {
1890   dVAR;
1891 #ifdef USE_ITHREADS
1892   /* only parent thread can modify process environment */
1893   if (PL_curinterp == aTHX)
1894 #endif
1895   {
1896 #ifndef PERL_USE_SAFE_PUTENV
1897     if (!PL_use_safe_putenv) {
1898     /* most putenv()s leak, so we manipulate environ directly */
1899     I32 i;
1900     const I32 len = strlen(nam);
1901     int nlen, vlen;
1902
1903     /* where does it go? */
1904     for (i = 0; environ[i]; i++) {
1905         if (strnEQ(environ[i],nam,len) && environ[i][len] == '=')
1906             break;
1907     }
1908
1909     if (environ == PL_origenviron) {   /* need we copy environment? */
1910        I32 j;
1911        I32 max;
1912        char **tmpenv;
1913
1914        max = i;
1915        while (environ[max])
1916            max++;
1917        tmpenv = (char**)safesysmalloc((max+2) * sizeof(char*));
1918        for (j=0; j<max; j++) {         /* copy environment */
1919            const int len = strlen(environ[j]);
1920            tmpenv[j] = (char*)safesysmalloc((len+1)*sizeof(char));
1921            Copy(environ[j], tmpenv[j], len+1, char);
1922        }
1923        tmpenv[max] = NULL;
1924        environ = tmpenv;               /* tell exec where it is now */
1925     }
1926     if (!val) {
1927        safesysfree(environ[i]);
1928        while (environ[i]) {
1929            environ[i] = environ[i+1];
1930            i++;
1931         }
1932        return;
1933     }
1934     if (!environ[i]) {                 /* does not exist yet */
1935        environ = (char**)safesysrealloc(environ, (i+2) * sizeof(char*));
1936        environ[i+1] = NULL;    /* make sure it's null terminated */
1937     }
1938     else
1939        safesysfree(environ[i]);
1940        nlen = strlen(nam);
1941        vlen = strlen(val);
1942
1943        environ[i] = (char*)safesysmalloc((nlen+vlen+2) * sizeof(char));
1944        /* all that work just for this */
1945        my_setenv_format(environ[i], nam, nlen, val, vlen);
1946     } else {
1947 # endif
1948 #   if defined(__CYGWIN__)|| defined(__SYMBIAN32__) || defined(__riscos__)
1949 #       if defined(HAS_UNSETENV)
1950         if (val == NULL) {
1951             (void)unsetenv(nam);
1952         } else {
1953             (void)setenv(nam, val, 1);
1954         }
1955 #       else /* ! HAS_UNSETENV */
1956         (void)setenv(nam, val, 1);
1957 #       endif /* HAS_UNSETENV */
1958 #   else
1959 #       if defined(HAS_UNSETENV)
1960         if (val == NULL) {
1961             if (environ) /* old glibc can crash with null environ */
1962                 (void)unsetenv(nam);
1963         } else {
1964             const int nlen = strlen(nam);
1965             const int vlen = strlen(val);
1966             char * const new_env =
1967                 (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
1968             my_setenv_format(new_env, nam, nlen, val, vlen);
1969             (void)putenv(new_env);
1970         }
1971 #       else /* ! HAS_UNSETENV */
1972         char *new_env;
1973         const int nlen = strlen(nam);
1974         int vlen;
1975         if (!val) {
1976            val = "";
1977         }
1978         vlen = strlen(val);
1979         new_env = (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
1980         /* all that work just for this */
1981         my_setenv_format(new_env, nam, nlen, val, vlen);
1982         (void)putenv(new_env);
1983 #       endif /* HAS_UNSETENV */
1984 #   endif /* __CYGWIN__ */
1985 #ifndef PERL_USE_SAFE_PUTENV
1986     }
1987 #endif
1988   }
1989 }
1990
1991 #else /* WIN32 || NETWARE */
1992
1993 void
1994 Perl_my_setenv(pTHX_ const char *nam, const char *val)
1995 {
1996     dVAR;
1997     char *envstr;
1998     const int nlen = strlen(nam);
1999     int vlen;
2000
2001     if (!val) {
2002        val = "";
2003     }
2004     vlen = strlen(val);
2005     Newx(envstr, nlen+vlen+2, char);
2006     my_setenv_format(envstr, nam, nlen, val, vlen);
2007     (void)PerlEnv_putenv(envstr);
2008     Safefree(envstr);
2009 }
2010
2011 #endif /* WIN32 || NETWARE */
2012
2013 #endif /* !VMS */
2014
2015 #ifdef UNLINK_ALL_VERSIONS
2016 I32
2017 Perl_unlnk(pTHX_ const char *f) /* unlink all versions of a file */
2018 {
2019     I32 retries = 0;
2020
2021     PERL_ARGS_ASSERT_UNLNK;
2022
2023     while (PerlLIO_unlink(f) >= 0)
2024         retries++;
2025     return retries ? 0 : -1;
2026 }
2027 #endif
2028
2029 /* this is a drop-in replacement for bcopy() */
2030 #if (!defined(HAS_MEMCPY) && !defined(HAS_BCOPY)) || (!defined(HAS_MEMMOVE) && !defined(HAS_SAFE_MEMCPY) && !defined(HAS_SAFE_BCOPY))
2031 char *
2032 Perl_my_bcopy(const char *from, char *to, I32 len)
2033 {
2034     char * const retval = to;
2035
2036     PERL_ARGS_ASSERT_MY_BCOPY;
2037
2038     assert(len >= 0);
2039
2040     if (from - to >= 0) {
2041         while (len--)
2042             *to++ = *from++;
2043     }
2044     else {
2045         to += len;
2046         from += len;
2047         while (len--)
2048             *(--to) = *(--from);
2049     }
2050     return retval;
2051 }
2052 #endif
2053
2054 /* this is a drop-in replacement for memset() */
2055 #ifndef HAS_MEMSET
2056 void *
2057 Perl_my_memset(char *loc, I32 ch, I32 len)
2058 {
2059     char * const retval = loc;
2060
2061     PERL_ARGS_ASSERT_MY_MEMSET;
2062
2063     assert(len >= 0);
2064
2065     while (len--)
2066         *loc++ = ch;
2067     return retval;
2068 }
2069 #endif
2070
2071 /* this is a drop-in replacement for bzero() */
2072 #if !defined(HAS_BZERO) && !defined(HAS_MEMSET)
2073 char *
2074 Perl_my_bzero(char *loc, I32 len)
2075 {
2076     char * const retval = loc;
2077
2078     PERL_ARGS_ASSERT_MY_BZERO;
2079
2080     assert(len >= 0);
2081
2082     while (len--)
2083         *loc++ = 0;
2084     return retval;
2085 }
2086 #endif
2087
2088 /* this is a drop-in replacement for memcmp() */
2089 #if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP)
2090 I32
2091 Perl_my_memcmp(const char *s1, const char *s2, I32 len)
2092 {
2093     const U8 *a = (const U8 *)s1;
2094     const U8 *b = (const U8 *)s2;
2095     I32 tmp;
2096
2097     PERL_ARGS_ASSERT_MY_MEMCMP;
2098
2099     assert(len >= 0);
2100
2101     while (len--) {
2102         if ((tmp = *a++ - *b++))
2103             return tmp;
2104     }
2105     return 0;
2106 }
2107 #endif /* !HAS_MEMCMP || !HAS_SANE_MEMCMP */
2108
2109 #ifndef HAS_VPRINTF
2110 /* This vsprintf replacement should generally never get used, since
2111    vsprintf was available in both System V and BSD 2.11.  (There may
2112    be some cross-compilation or embedded set-ups where it is needed,
2113    however.)
2114
2115    If you encounter a problem in this function, it's probably a symptom
2116    that Configure failed to detect your system's vprintf() function.
2117    See the section on "item vsprintf" in the INSTALL file.
2118
2119    This version may compile on systems with BSD-ish <stdio.h>,
2120    but probably won't on others.
2121 */
2122
2123 #ifdef USE_CHAR_VSPRINTF
2124 char *
2125 #else
2126 int
2127 #endif
2128 vsprintf(char *dest, const char *pat, void *args)
2129 {
2130     FILE fakebuf;
2131
2132 #if defined(STDIO_PTR_LVALUE) && defined(STDIO_CNT_LVALUE)
2133     FILE_ptr(&fakebuf) = (STDCHAR *) dest;
2134     FILE_cnt(&fakebuf) = 32767;
2135 #else
2136     /* These probably won't compile -- If you really need
2137        this, you'll have to figure out some other method. */
2138     fakebuf._ptr = dest;
2139     fakebuf._cnt = 32767;
2140 #endif
2141 #ifndef _IOSTRG
2142 #define _IOSTRG 0
2143 #endif
2144     fakebuf._flag = _IOWRT|_IOSTRG;
2145     _doprnt(pat, args, &fakebuf);       /* what a kludge */
2146 #if defined(STDIO_PTR_LVALUE)
2147     *(FILE_ptr(&fakebuf)++) = '\0';
2148 #else
2149     /* PerlIO has probably #defined away fputc, but we want it here. */
2150 #  ifdef fputc
2151 #    undef fputc  /* XXX Should really restore it later */
2152 #  endif
2153     (void)fputc('\0', &fakebuf);
2154 #endif
2155 #ifdef USE_CHAR_VSPRINTF
2156     return(dest);
2157 #else
2158     return 0;           /* perl doesn't use return value */
2159 #endif
2160 }
2161
2162 #endif /* HAS_VPRINTF */
2163
2164 PerlIO *
2165 Perl_my_popen_list(pTHX_ const char *mode, int n, SV **args)
2166 {
2167 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(OS2) && !defined(VMS) && !defined(NETWARE) && !defined(__LIBCATAMOUNT__)
2168     dVAR;
2169     int p[2];
2170     I32 This, that;
2171     Pid_t pid;
2172     SV *sv;
2173     I32 did_pipes = 0;
2174     int pp[2];
2175
2176     PERL_ARGS_ASSERT_MY_POPEN_LIST;
2177
2178     PERL_FLUSHALL_FOR_CHILD;
2179     This = (*mode == 'w');
2180     that = !This;
2181     if (TAINTING_get) {
2182         taint_env();
2183         taint_proper("Insecure %s%s", "EXEC");
2184     }
2185     if (PerlProc_pipe(p) < 0)
2186         return NULL;
2187     /* Try for another pipe pair for error return */
2188     if (PerlProc_pipe(pp) >= 0)
2189         did_pipes = 1;
2190     while ((pid = PerlProc_fork()) < 0) {
2191         if (errno != EAGAIN) {
2192             PerlLIO_close(p[This]);
2193             PerlLIO_close(p[that]);
2194             if (did_pipes) {
2195                 PerlLIO_close(pp[0]);
2196                 PerlLIO_close(pp[1]);
2197             }
2198             return NULL;
2199         }
2200         Perl_ck_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds");
2201         sleep(5);
2202     }
2203     if (pid == 0) {
2204         /* Child */
2205 #undef THIS
2206 #undef THAT
2207 #define THIS that
2208 #define THAT This
2209         /* Close parent's end of error status pipe (if any) */
2210         if (did_pipes) {
2211             PerlLIO_close(pp[0]);
2212 #if defined(HAS_FCNTL) && defined(F_SETFD)
2213             /* Close error pipe automatically if exec works */
2214             fcntl(pp[1], F_SETFD, FD_CLOEXEC);
2215 #endif
2216         }
2217         /* Now dup our end of _the_ pipe to right position */
2218         if (p[THIS] != (*mode == 'r')) {
2219             PerlLIO_dup2(p[THIS], *mode == 'r');
2220             PerlLIO_close(p[THIS]);
2221             if (p[THAT] != (*mode == 'r'))      /* if dup2() didn't close it */
2222                 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
2223         }
2224         else
2225             PerlLIO_close(p[THAT]);     /* close parent's end of _the_ pipe */
2226 #if !defined(HAS_FCNTL) || !defined(F_SETFD)
2227         /* No automatic close - do it by hand */
2228 #  ifndef NOFILE
2229 #  define NOFILE 20
2230 #  endif
2231         {
2232             int fd;
2233
2234             for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++) {
2235                 if (fd != pp[1])
2236                     PerlLIO_close(fd);
2237             }
2238         }
2239 #endif
2240         do_aexec5(NULL, args-1, args-1+n, pp[1], did_pipes);
2241         PerlProc__exit(1);
2242 #undef THIS
2243 #undef THAT
2244     }
2245     /* Parent */
2246     do_execfree();      /* free any memory malloced by child on fork */
2247     if (did_pipes)
2248         PerlLIO_close(pp[1]);
2249     /* Keep the lower of the two fd numbers */
2250     if (p[that] < p[This]) {
2251         PerlLIO_dup2(p[This], p[that]);
2252         PerlLIO_close(p[This]);
2253         p[This] = p[that];
2254     }
2255     else
2256         PerlLIO_close(p[that]);         /* close child's end of pipe */
2257
2258     sv = *av_fetch(PL_fdpid,p[This],TRUE);
2259     SvUPGRADE(sv,SVt_IV);
2260     SvIV_set(sv, pid);
2261     PL_forkprocess = pid;
2262     /* If we managed to get status pipe check for exec fail */
2263     if (did_pipes && pid > 0) {
2264         int errkid;
2265         unsigned n = 0;
2266         SSize_t n1;
2267
2268         while (n < sizeof(int)) {
2269             n1 = PerlLIO_read(pp[0],
2270                               (void*)(((char*)&errkid)+n),
2271                               (sizeof(int)) - n);
2272             if (n1 <= 0)
2273                 break;
2274             n += n1;
2275         }
2276         PerlLIO_close(pp[0]);
2277         did_pipes = 0;
2278         if (n) {                        /* Error */
2279             int pid2, status;
2280             PerlLIO_close(p[This]);
2281             if (n != sizeof(int))
2282                 Perl_croak(aTHX_ "panic: kid popen errno read, n=%u", n);
2283             do {
2284                 pid2 = wait4pid(pid, &status, 0);
2285             } while (pid2 == -1 && errno == EINTR);
2286             errno = errkid;             /* Propagate errno from kid */
2287             return NULL;
2288         }
2289     }
2290     if (did_pipes)
2291          PerlLIO_close(pp[0]);
2292     return PerlIO_fdopen(p[This], mode);
2293 #else
2294 #  ifdef OS2    /* Same, without fork()ing and all extra overhead... */
2295     return my_syspopen4(aTHX_ NULL, mode, n, args);
2296 #  else
2297     Perl_croak(aTHX_ "List form of piped open not implemented");
2298     return (PerlIO *) NULL;
2299 #  endif
2300 #endif
2301 }
2302
2303     /* VMS' my_popen() is in VMS.c, same with OS/2. */
2304 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__LIBCATAMOUNT__)
2305 PerlIO *
2306 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2307 {
2308     dVAR;
2309     int p[2];
2310     I32 This, that;
2311     Pid_t pid;
2312     SV *sv;
2313     const I32 doexec = !(*cmd == '-' && cmd[1] == '\0');
2314     I32 did_pipes = 0;
2315     int pp[2];
2316
2317     PERL_ARGS_ASSERT_MY_POPEN;
2318
2319     PERL_FLUSHALL_FOR_CHILD;
2320 #ifdef OS2
2321     if (doexec) {
2322         return my_syspopen(aTHX_ cmd,mode);
2323     }
2324 #endif
2325     This = (*mode == 'w');
2326     that = !This;
2327     if (doexec && TAINTING_get) {
2328         taint_env();
2329         taint_proper("Insecure %s%s", "EXEC");
2330     }
2331     if (PerlProc_pipe(p) < 0)
2332         return NULL;
2333     if (doexec && PerlProc_pipe(pp) >= 0)
2334         did_pipes = 1;
2335     while ((pid = PerlProc_fork()) < 0) {
2336         if (errno != EAGAIN) {
2337             PerlLIO_close(p[This]);
2338             PerlLIO_close(p[that]);
2339             if (did_pipes) {
2340                 PerlLIO_close(pp[0]);
2341                 PerlLIO_close(pp[1]);
2342             }
2343             if (!doexec)
2344                 Perl_croak(aTHX_ "Can't fork: %s", Strerror(errno));
2345             return NULL;
2346         }
2347         Perl_ck_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds");
2348         sleep(5);
2349     }
2350     if (pid == 0) {
2351
2352 #undef THIS
2353 #undef THAT
2354 #define THIS that
2355 #define THAT This
2356         if (did_pipes) {
2357             PerlLIO_close(pp[0]);
2358 #if defined(HAS_FCNTL) && defined(F_SETFD)
2359             fcntl(pp[1], F_SETFD, FD_CLOEXEC);
2360 #endif
2361         }
2362         if (p[THIS] != (*mode == 'r')) {
2363             PerlLIO_dup2(p[THIS], *mode == 'r');
2364             PerlLIO_close(p[THIS]);
2365             if (p[THAT] != (*mode == 'r'))      /* if dup2() didn't close it */
2366                 PerlLIO_close(p[THAT]);
2367         }
2368         else
2369             PerlLIO_close(p[THAT]);
2370 #ifndef OS2
2371         if (doexec) {
2372 #if !defined(HAS_FCNTL) || !defined(F_SETFD)
2373 #ifndef NOFILE
2374 #define NOFILE 20
2375 #endif
2376             {
2377                 int fd;
2378
2379                 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++)
2380                     if (fd != pp[1])
2381                         PerlLIO_close(fd);
2382             }
2383 #endif
2384             /* may or may not use the shell */
2385             do_exec3(cmd, pp[1], did_pipes);
2386             PerlProc__exit(1);
2387         }
2388 #endif  /* defined OS2 */
2389
2390 #ifdef PERLIO_USING_CRLF
2391    /* Since we circumvent IO layers when we manipulate low-level
2392       filedescriptors directly, need to manually switch to the
2393       default, binary, low-level mode; see PerlIOBuf_open(). */
2394    PerlLIO_setmode((*mode == 'r'), O_BINARY);
2395 #endif
2396         PL_forkprocess = 0;
2397 #ifdef PERL_USES_PL_PIDSTATUS
2398         hv_clear(PL_pidstatus); /* we have no children */
2399 #endif
2400         return NULL;
2401 #undef THIS
2402 #undef THAT
2403     }
2404     do_execfree();      /* free any memory malloced by child on vfork */
2405     if (did_pipes)
2406         PerlLIO_close(pp[1]);
2407     if (p[that] < p[This]) {
2408         PerlLIO_dup2(p[This], p[that]);
2409         PerlLIO_close(p[This]);
2410         p[This] = p[that];
2411     }
2412     else
2413         PerlLIO_close(p[that]);
2414
2415     sv = *av_fetch(PL_fdpid,p[This],TRUE);
2416     SvUPGRADE(sv,SVt_IV);
2417     SvIV_set(sv, pid);
2418     PL_forkprocess = pid;
2419     if (did_pipes && pid > 0) {
2420         int errkid;
2421         unsigned n = 0;
2422         SSize_t n1;
2423
2424         while (n < sizeof(int)) {
2425             n1 = PerlLIO_read(pp[0],
2426                               (void*)(((char*)&errkid)+n),
2427                               (sizeof(int)) - n);
2428             if (n1 <= 0)
2429                 break;
2430             n += n1;
2431         }
2432         PerlLIO_close(pp[0]);
2433         did_pipes = 0;
2434         if (n) {                        /* Error */
2435             int pid2, status;
2436             PerlLIO_close(p[This]);
2437             if (n != sizeof(int))
2438                 Perl_croak(aTHX_ "panic: kid popen errno read, n=%u", n);
2439             do {
2440                 pid2 = wait4pid(pid, &status, 0);
2441             } while (pid2 == -1 && errno == EINTR);
2442             errno = errkid;             /* Propagate errno from kid */
2443             return NULL;
2444         }
2445     }
2446     if (did_pipes)
2447          PerlLIO_close(pp[0]);
2448     return PerlIO_fdopen(p[This], mode);
2449 }
2450 #else
2451 #if defined(DJGPP)
2452 FILE *djgpp_popen();
2453 PerlIO *
2454 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2455 {
2456     PERL_FLUSHALL_FOR_CHILD;
2457     /* Call system's popen() to get a FILE *, then import it.
2458        used 0 for 2nd parameter to PerlIO_importFILE;
2459        apparently not used
2460     */
2461     return PerlIO_importFILE(djgpp_popen(cmd, mode), 0);
2462 }
2463 #else
2464 #if defined(__LIBCATAMOUNT__)
2465 PerlIO *
2466 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2467 {
2468     return NULL;
2469 }
2470 #endif
2471 #endif
2472
2473 #endif /* !DOSISH */
2474
2475 /* this is called in parent before the fork() */
2476 void
2477 Perl_atfork_lock(void)
2478 {
2479    dVAR;
2480 #if defined(USE_ITHREADS)
2481     /* locks must be held in locking order (if any) */
2482 #  ifdef USE_PERLIO
2483     MUTEX_LOCK(&PL_perlio_mutex);
2484 #  endif
2485 #  ifdef MYMALLOC
2486     MUTEX_LOCK(&PL_malloc_mutex);
2487 #  endif
2488     OP_REFCNT_LOCK;
2489 #endif
2490 }
2491
2492 /* this is called in both parent and child after the fork() */
2493 void
2494 Perl_atfork_unlock(void)
2495 {
2496     dVAR;
2497 #if defined(USE_ITHREADS)
2498     /* locks must be released in same order as in atfork_lock() */
2499 #  ifdef USE_PERLIO
2500     MUTEX_UNLOCK(&PL_perlio_mutex);
2501 #  endif
2502 #  ifdef MYMALLOC
2503     MUTEX_UNLOCK(&PL_malloc_mutex);
2504 #  endif
2505     OP_REFCNT_UNLOCK;
2506 #endif
2507 }
2508
2509 Pid_t
2510 Perl_my_fork(void)
2511 {
2512 #if defined(HAS_FORK)
2513     Pid_t pid;
2514 #if defined(USE_ITHREADS) && !defined(HAS_PTHREAD_ATFORK)
2515     atfork_lock();
2516     pid = fork();
2517     atfork_unlock();
2518 #else
2519     /* atfork_lock() and atfork_unlock() are installed as pthread_atfork()
2520      * handlers elsewhere in the code */
2521     pid = fork();
2522 #endif
2523     return pid;
2524 #else
2525     /* this "canna happen" since nothing should be calling here if !HAS_FORK */
2526     Perl_croak_nocontext("fork() not available");
2527     return 0;
2528 #endif /* HAS_FORK */
2529 }
2530
2531 #ifdef DUMP_FDS
2532 void
2533 Perl_dump_fds(pTHX_ const char *const s)
2534 {
2535     int fd;
2536     Stat_t tmpstatbuf;
2537
2538     PERL_ARGS_ASSERT_DUMP_FDS;
2539
2540     PerlIO_printf(Perl_debug_log,"%s", s);
2541     for (fd = 0; fd < 32; fd++) {
2542         if (PerlLIO_fstat(fd,&tmpstatbuf) >= 0)
2543             PerlIO_printf(Perl_debug_log," %d",fd);
2544     }
2545     PerlIO_printf(Perl_debug_log,"\n");
2546     return;
2547 }
2548 #endif  /* DUMP_FDS */
2549
2550 #ifndef HAS_DUP2
2551 int
2552 dup2(int oldfd, int newfd)
2553 {
2554 #if defined(HAS_FCNTL) && defined(F_DUPFD)
2555     if (oldfd == newfd)
2556         return oldfd;
2557     PerlLIO_close(newfd);
2558     return fcntl(oldfd, F_DUPFD, newfd);
2559 #else
2560 #define DUP2_MAX_FDS 256
2561     int fdtmp[DUP2_MAX_FDS];
2562     I32 fdx = 0;
2563     int fd;
2564
2565     if (oldfd == newfd)
2566         return oldfd;
2567     PerlLIO_close(newfd);
2568     /* good enough for low fd's... */
2569     while ((fd = PerlLIO_dup(oldfd)) != newfd && fd >= 0) {
2570         if (fdx >= DUP2_MAX_FDS) {
2571             PerlLIO_close(fd);
2572             fd = -1;
2573             break;
2574         }
2575         fdtmp[fdx++] = fd;
2576     }
2577     while (fdx > 0)
2578         PerlLIO_close(fdtmp[--fdx]);
2579     return fd;
2580 #endif
2581 }
2582 #endif
2583
2584 #ifndef PERL_MICRO
2585 #ifdef HAS_SIGACTION
2586
2587 Sighandler_t
2588 Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
2589 {
2590     dVAR;
2591     struct sigaction act, oact;
2592
2593 #ifdef USE_ITHREADS
2594     /* only "parent" interpreter can diddle signals */
2595     if (PL_curinterp != aTHX)
2596         return (Sighandler_t) SIG_ERR;
2597 #endif
2598
2599     act.sa_handler = (void(*)(int))handler;
2600     sigemptyset(&act.sa_mask);
2601     act.sa_flags = 0;
2602 #ifdef SA_RESTART
2603     if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2604         act.sa_flags |= SA_RESTART;     /* SVR4, 4.3+BSD */
2605 #endif
2606 #if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
2607     if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
2608         act.sa_flags |= SA_NOCLDWAIT;
2609 #endif
2610     if (sigaction(signo, &act, &oact) == -1)
2611         return (Sighandler_t) SIG_ERR;
2612     else
2613         return (Sighandler_t) oact.sa_handler;
2614 }
2615
2616 Sighandler_t
2617 Perl_rsignal_state(pTHX_ int signo)
2618 {
2619     struct sigaction oact;
2620     PERL_UNUSED_CONTEXT;
2621
2622     if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1)
2623         return (Sighandler_t) SIG_ERR;
2624     else
2625         return (Sighandler_t) oact.sa_handler;
2626 }
2627
2628 int
2629 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
2630 {
2631     dVAR;
2632     struct sigaction act;
2633
2634     PERL_ARGS_ASSERT_RSIGNAL_SAVE;
2635
2636 #ifdef USE_ITHREADS
2637     /* only "parent" interpreter can diddle signals */
2638     if (PL_curinterp != aTHX)
2639         return -1;
2640 #endif
2641
2642     act.sa_handler = (void(*)(int))handler;
2643     sigemptyset(&act.sa_mask);
2644     act.sa_flags = 0;
2645 #ifdef SA_RESTART
2646     if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2647         act.sa_flags |= SA_RESTART;     /* SVR4, 4.3+BSD */
2648 #endif
2649 #if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
2650     if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
2651         act.sa_flags |= SA_NOCLDWAIT;
2652 #endif
2653     return sigaction(signo, &act, save);
2654 }
2655
2656 int
2657 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
2658 {
2659     dVAR;
2660 #ifdef USE_ITHREADS
2661     /* only "parent" interpreter can diddle signals */
2662     if (PL_curinterp != aTHX)
2663         return -1;
2664 #endif
2665
2666     return sigaction(signo, save, (struct sigaction *)NULL);
2667 }
2668
2669 #else /* !HAS_SIGACTION */
2670
2671 Sighandler_t
2672 Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
2673 {
2674 #if defined(USE_ITHREADS) && !defined(WIN32)
2675     /* only "parent" interpreter can diddle signals */
2676     if (PL_curinterp != aTHX)
2677         return (Sighandler_t) SIG_ERR;
2678 #endif
2679
2680     return PerlProc_signal(signo, handler);
2681 }
2682
2683 static Signal_t
2684 sig_trap(int signo)
2685 {
2686     dVAR;
2687     PL_sig_trapped++;
2688 }
2689
2690 Sighandler_t
2691 Perl_rsignal_state(pTHX_ int signo)
2692 {
2693     dVAR;
2694     Sighandler_t oldsig;
2695
2696 #if defined(USE_ITHREADS) && !defined(WIN32)
2697     /* only "parent" interpreter can diddle signals */
2698     if (PL_curinterp != aTHX)
2699         return (Sighandler_t) SIG_ERR;
2700 #endif
2701
2702     PL_sig_trapped = 0;
2703     oldsig = PerlProc_signal(signo, sig_trap);
2704     PerlProc_signal(signo, oldsig);
2705     if (PL_sig_trapped)
2706         PerlProc_kill(PerlProc_getpid(), signo);
2707     return oldsig;
2708 }
2709
2710 int
2711 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
2712 {
2713 #if defined(USE_ITHREADS) && !defined(WIN32)
2714     /* only "parent" interpreter can diddle signals */
2715     if (PL_curinterp != aTHX)
2716         return -1;
2717 #endif
2718     *save = PerlProc_signal(signo, handler);
2719     return (*save == (Sighandler_t) SIG_ERR) ? -1 : 0;
2720 }
2721
2722 int
2723 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
2724 {
2725 #if defined(USE_ITHREADS) && !defined(WIN32)
2726     /* only "parent" interpreter can diddle signals */
2727     if (PL_curinterp != aTHX)
2728         return -1;
2729 #endif
2730     return (PerlProc_signal(signo, *save) == (Sighandler_t) SIG_ERR) ? -1 : 0;
2731 }
2732
2733 #endif /* !HAS_SIGACTION */
2734 #endif /* !PERL_MICRO */
2735
2736     /* VMS' my_pclose() is in VMS.c; same with OS/2 */
2737 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__LIBCATAMOUNT__)
2738 I32
2739 Perl_my_pclose(pTHX_ PerlIO *ptr)
2740 {
2741     dVAR;
2742     int status;
2743     SV **svp;
2744     Pid_t pid;
2745     Pid_t pid2 = 0;
2746     bool close_failed;
2747     dSAVEDERRNO;
2748     const int fd = PerlIO_fileno(ptr);
2749
2750 #ifdef USE_PERLIO
2751     /* Find out whether the refcount is low enough for us to wait for the
2752        child proc without blocking. */
2753     const bool should_wait = PerlIOUnix_refcnt(fd) == 1;
2754 #else
2755     const bool should_wait = 1;
2756 #endif
2757
2758     svp = av_fetch(PL_fdpid,fd,TRUE);
2759     pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1;
2760     SvREFCNT_dec(*svp);
2761     *svp = NULL;
2762 #ifdef OS2
2763     if (pid == -1) {                    /* Opened by popen. */
2764         return my_syspclose(ptr);
2765     }
2766 #endif
2767     close_failed = (PerlIO_close(ptr) == EOF);
2768     SAVE_ERRNO;
2769     if (should_wait) do {
2770         pid2 = wait4pid(pid, &status, 0);
2771     } while (pid2 == -1 && errno == EINTR);
2772     if (close_failed) {
2773         RESTORE_ERRNO;
2774         return -1;
2775     }
2776     return(
2777       should_wait
2778        ? pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status)
2779        : 0
2780     );
2781 }
2782 #else
2783 #if defined(__LIBCATAMOUNT__)
2784 I32
2785 Perl_my_pclose(pTHX_ PerlIO *ptr)
2786 {
2787     return -1;
2788 }
2789 #endif
2790 #endif /* !DOSISH */
2791
2792 #if  (!defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(NETWARE)) && !defined(__LIBCATAMOUNT__)
2793 I32
2794 Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
2795 {
2796     dVAR;
2797     I32 result = 0;
2798     PERL_ARGS_ASSERT_WAIT4PID;
2799     if (!pid)
2800         return -1;
2801 #ifdef PERL_USES_PL_PIDSTATUS
2802     {
2803         if (pid > 0) {
2804             /* The keys in PL_pidstatus are now the raw 4 (or 8) bytes of the
2805                pid, rather than a string form.  */
2806             SV * const * const svp = hv_fetch(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),FALSE);
2807             if (svp && *svp != &PL_sv_undef) {
2808                 *statusp = SvIVX(*svp);
2809                 (void)hv_delete(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),
2810                                 G_DISCARD);
2811                 return pid;
2812             }
2813         }
2814         else {
2815             HE *entry;
2816
2817             hv_iterinit(PL_pidstatus);
2818             if ((entry = hv_iternext(PL_pidstatus))) {
2819                 SV * const sv = hv_iterval(PL_pidstatus,entry);
2820                 I32 len;
2821                 const char * const spid = hv_iterkey(entry,&len);
2822
2823                 assert (len == sizeof(Pid_t));
2824                 memcpy((char *)&pid, spid, len);
2825                 *statusp = SvIVX(sv);
2826                 /* The hash iterator is currently on this entry, so simply
2827                    calling hv_delete would trigger the lazy delete, which on
2828                    aggregate does more work, beacuse next call to hv_iterinit()
2829                    would spot the flag, and have to call the delete routine,
2830                    while in the meantime any new entries can't re-use that
2831                    memory.  */
2832                 hv_iterinit(PL_pidstatus);
2833                 (void)hv_delete(PL_pidstatus,spid,len,G_DISCARD);
2834                 return pid;
2835             }
2836         }
2837     }
2838 #endif
2839 #ifdef HAS_WAITPID
2840 #  ifdef HAS_WAITPID_RUNTIME
2841     if (!HAS_WAITPID_RUNTIME)
2842         goto hard_way;
2843 #  endif
2844     result = PerlProc_waitpid(pid,statusp,flags);
2845     goto finish;
2846 #endif
2847 #if !defined(HAS_WAITPID) && defined(HAS_WAIT4)
2848     result = wait4((pid==-1)?0:pid,statusp,flags,NULL);
2849     goto finish;
2850 #endif
2851 #ifdef PERL_USES_PL_PIDSTATUS
2852 #if defined(HAS_WAITPID) && defined(HAS_WAITPID_RUNTIME)
2853   hard_way:
2854 #endif
2855     {
2856         if (flags)
2857             Perl_croak(aTHX_ "Can't do waitpid with flags");
2858         else {
2859             while ((result = PerlProc_wait(statusp)) != pid && pid > 0 && result >= 0)
2860                 pidgone(result,*statusp);
2861             if (result < 0)
2862                 *statusp = -1;
2863         }
2864     }
2865 #endif
2866 #if defined(HAS_WAITPID) || defined(HAS_WAIT4)
2867   finish:
2868 #endif
2869     if (result < 0 && errno == EINTR) {
2870         PERL_ASYNC_CHECK();
2871         errno = EINTR; /* reset in case a signal handler changed $! */
2872     }
2873     return result;
2874 }
2875 #endif /* !DOSISH || OS2 || WIN32 || NETWARE */
2876
2877 #ifdef PERL_USES_PL_PIDSTATUS
2878 void
2879 S_pidgone(pTHX_ Pid_t pid, int status)
2880 {
2881     SV *sv;
2882
2883     sv = *hv_fetch(PL_pidstatus,(const char*)&pid,sizeof(Pid_t),TRUE);
2884     SvUPGRADE(sv,SVt_IV);
2885     SvIV_set(sv, status);
2886     return;
2887 }
2888 #endif
2889
2890 #if defined(OS2)
2891 int pclose();
2892 #ifdef HAS_FORK
2893 int                                     /* Cannot prototype with I32
2894                                            in os2ish.h. */
2895 my_syspclose(PerlIO *ptr)
2896 #else
2897 I32
2898 Perl_my_pclose(pTHX_ PerlIO *ptr)
2899 #endif
2900 {
2901     /* Needs work for PerlIO ! */
2902     FILE * const f = PerlIO_findFILE(ptr);
2903     const I32 result = pclose(f);
2904     PerlIO_releaseFILE(ptr,f);
2905     return result;
2906 }
2907 #endif
2908
2909 #if defined(DJGPP)
2910 int djgpp_pclose();
2911 I32
2912 Perl_my_pclose(pTHX_ PerlIO *ptr)
2913 {
2914     /* Needs work for PerlIO ! */
2915     FILE * const f = PerlIO_findFILE(ptr);
2916     I32 result = djgpp_pclose(f);
2917     result = (result << 8) & 0xff00;
2918     PerlIO_releaseFILE(ptr,f);
2919     return result;
2920 }
2921 #endif
2922
2923 #define PERL_REPEATCPY_LINEAR 4
2924 void
2925 Perl_repeatcpy(char *to, const char *from, I32 len, IV count)
2926 {
2927     PERL_ARGS_ASSERT_REPEATCPY;
2928
2929     assert(len >= 0);
2930
2931     if (count < 0)
2932         croak_memory_wrap();
2933
2934     if (len == 1)
2935         memset(to, *from, count);
2936     else if (count) {
2937         char *p = to;
2938         IV items, linear, half;
2939
2940         linear = count < PERL_REPEATCPY_LINEAR ? count : PERL_REPEATCPY_LINEAR;
2941         for (items = 0; items < linear; ++items) {
2942             const char *q = from;
2943             IV todo;
2944             for (todo = len; todo > 0; todo--)
2945                 *p++ = *q++;
2946         }
2947
2948         half = count / 2;
2949         while (items <= half) {
2950             IV size = items * len;
2951             memcpy(p, to, size);
2952             p     += size;
2953             items *= 2;
2954         }
2955
2956         if (count > items)
2957             memcpy(p, to, (count - items) * len);
2958     }
2959 }
2960
2961 #ifndef HAS_RENAME
2962 I32
2963 Perl_same_dirent(pTHX_ const char *a, const char *b)
2964 {
2965     char *fa = strrchr(a,'/');
2966     char *fb = strrchr(b,'/');
2967     Stat_t tmpstatbuf1;
2968     Stat_t tmpstatbuf2;
2969     SV * const tmpsv = sv_newmortal();
2970
2971     PERL_ARGS_ASSERT_SAME_DIRENT;
2972
2973     if (fa)
2974         fa++;
2975     else
2976         fa = a;
2977     if (fb)
2978         fb++;
2979     else
2980         fb = b;
2981     if (strNE(a,b))
2982         return FALSE;
2983     if (fa == a)
2984         sv_setpvs(tmpsv, ".");
2985     else
2986         sv_setpvn(tmpsv, a, fa - a);
2987     if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf1) < 0)
2988         return FALSE;
2989     if (fb == b)
2990         sv_setpvs(tmpsv, ".");
2991     else
2992         sv_setpvn(tmpsv, b, fb - b);
2993     if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf2) < 0)
2994         return FALSE;
2995     return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev &&
2996            tmpstatbuf1.st_ino == tmpstatbuf2.st_ino;
2997 }
2998 #endif /* !HAS_RENAME */
2999
3000 char*
3001 Perl_find_script(pTHX_ const char *scriptname, bool dosearch,
3002                  const char *const *const search_ext, I32 flags)
3003 {
3004     dVAR;
3005     const char *xfound = NULL;
3006     char *xfailed = NULL;
3007     char tmpbuf[MAXPATHLEN];
3008     char *s;
3009     I32 len = 0;
3010     int retval;
3011     char *bufend;
3012 #if defined(DOSISH) && !defined(OS2)
3013 #  define SEARCH_EXTS ".bat", ".cmd", NULL
3014 #  define MAX_EXT_LEN 4
3015 #endif
3016 #ifdef OS2
3017 #  define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
3018 #  define MAX_EXT_LEN 4
3019 #endif
3020 #ifdef VMS
3021 #  define SEARCH_EXTS ".pl", ".com", NULL
3022 #  define MAX_EXT_LEN 4
3023 #endif
3024     /* additional extensions to try in each dir if scriptname not found */
3025 #ifdef SEARCH_EXTS
3026     static const char *const exts[] = { SEARCH_EXTS };
3027     const char *const *const ext = search_ext ? search_ext : exts;
3028     int extidx = 0, i = 0;
3029     const char *curext = NULL;
3030 #else
3031     PERL_UNUSED_ARG(search_ext);
3032 #  define MAX_EXT_LEN 0
3033 #endif
3034
3035     PERL_ARGS_ASSERT_FIND_SCRIPT;
3036
3037     /*
3038      * If dosearch is true and if scriptname does not contain path
3039      * delimiters, search the PATH for scriptname.
3040      *
3041      * If SEARCH_EXTS is also defined, will look for each
3042      * scriptname{SEARCH_EXTS} whenever scriptname is not found
3043      * while searching the PATH.
3044      *
3045      * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
3046      * proceeds as follows:
3047      *   If DOSISH or VMSISH:
3048      *     + look for ./scriptname{,.foo,.bar}
3049      *     + search the PATH for scriptname{,.foo,.bar}
3050      *
3051      *   If !DOSISH:
3052      *     + look *only* in the PATH for scriptname{,.foo,.bar} (note
3053      *       this will not look in '.' if it's not in the PATH)
3054      */
3055     tmpbuf[0] = '\0';
3056
3057 #ifdef VMS
3058 #  ifdef ALWAYS_DEFTYPES
3059     len = strlen(scriptname);
3060     if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') {
3061         int idx = 0, deftypes = 1;
3062         bool seen_dot = 1;
3063
3064         const int hasdir = !dosearch || (strpbrk(scriptname,":[</") != NULL);
3065 #  else
3066     if (dosearch) {
3067         int idx = 0, deftypes = 1;
3068         bool seen_dot = 1;
3069
3070         const int hasdir = (strpbrk(scriptname,":[</") != NULL);
3071 #  endif
3072         /* The first time through, just add SEARCH_EXTS to whatever we
3073          * already have, so we can check for default file types. */
3074         while (deftypes ||
3075                (!hasdir && my_trnlnm("DCL$PATH",tmpbuf,idx++)) )
3076         {
3077             if (deftypes) {
3078                 deftypes = 0;
3079                 *tmpbuf = '\0';
3080             }
3081             if ((strlen(tmpbuf) + strlen(scriptname)
3082                  + MAX_EXT_LEN) >= sizeof tmpbuf)
3083                 continue;       /* don't search dir with too-long name */
3084             my_strlcat(tmpbuf, scriptname, sizeof(tmpbuf));
3085 #else  /* !VMS */
3086
3087 #ifdef DOSISH
3088     if (strEQ(scriptname, "-"))
3089         dosearch = 0;
3090     if (dosearch) {             /* Look in '.' first. */
3091         const char *cur = scriptname;
3092 #ifdef SEARCH_EXTS
3093         if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
3094             while (ext[i])
3095                 if (strEQ(ext[i++],curext)) {
3096                     extidx = -1;                /* already has an ext */
3097                     break;
3098                 }
3099         do {
3100 #endif
3101             DEBUG_p(PerlIO_printf(Perl_debug_log,
3102                                   "Looking for %s\n",cur));
3103             if (PerlLIO_stat(cur,&PL_statbuf) >= 0
3104                 && !S_ISDIR(PL_statbuf.st_mode)) {
3105                 dosearch = 0;
3106                 scriptname = cur;
3107 #ifdef SEARCH_EXTS
3108                 break;
3109 #endif
3110             }
3111 #ifdef SEARCH_EXTS
3112             if (cur == scriptname) {
3113                 len = strlen(scriptname);
3114                 if (len+MAX_EXT_LEN+1 >= sizeof(tmpbuf))
3115                     break;
3116                 my_strlcpy(tmpbuf, scriptname, sizeof(tmpbuf));
3117                 cur = tmpbuf;
3118             }
3119         } while (extidx >= 0 && ext[extidx]     /* try an extension? */
3120                  && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len));
3121 #endif
3122     }
3123 #endif
3124
3125     if (dosearch && !strchr(scriptname, '/')
3126 #ifdef DOSISH
3127                  && !strchr(scriptname, '\\')
3128 #endif
3129                  && (s = PerlEnv_getenv("PATH")))
3130     {
3131         bool seen_dot = 0;
3132
3133         bufend = s + strlen(s);
3134         while (s < bufend) {
3135 #  ifdef DOSISH
3136             for (len = 0; *s
3137                     && *s != ';'; len++, s++) {
3138                 if (len < sizeof tmpbuf)
3139                     tmpbuf[len] = *s;
3140             }
3141             if (len < sizeof tmpbuf)
3142                 tmpbuf[len] = '\0';
3143 #  else
3144             s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, bufend,
3145                         ':',
3146                         &len);
3147 #  endif
3148             if (s < bufend)
3149                 s++;
3150             if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf)
3151                 continue;       /* don't search dir with too-long name */
3152             if (len
3153 #  ifdef DOSISH
3154                 && tmpbuf[len - 1] != '/'
3155                 && tmpbuf[len - 1] != '\\'
3156 #  endif
3157                )
3158                 tmpbuf[len++] = '/';
3159             if (len == 2 && tmpbuf[0] == '.')
3160                 seen_dot = 1;
3161             (void)my_strlcpy(tmpbuf + len, scriptname, sizeof(tmpbuf) - len);
3162 #endif  /* !VMS */
3163
3164 #ifdef SEARCH_EXTS
3165             len = strlen(tmpbuf);
3166             if (extidx > 0)     /* reset after previous loop */
3167                 extidx = 0;
3168             do {
3169 #endif
3170                 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tmpbuf));
3171                 retval = PerlLIO_stat(tmpbuf,&PL_statbuf);
3172                 if (S_ISDIR(PL_statbuf.st_mode)) {
3173                     retval = -1;
3174                 }
3175 #ifdef SEARCH_EXTS
3176             } while (  retval < 0               /* not there */
3177                     && extidx>=0 && ext[extidx] /* try an extension? */
3178                     && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len)
3179                 );
3180 #endif
3181             if (retval < 0)
3182                 continue;
3183             if (S_ISREG(PL_statbuf.st_mode)
3184                 && cando(S_IRUSR,TRUE,&PL_statbuf)
3185 #if !defined(DOSISH)
3186                 && cando(S_IXUSR,TRUE,&PL_statbuf)
3187 #endif
3188                 )
3189             {
3190                 xfound = tmpbuf;                /* bingo! */
3191                 break;
3192             }
3193             if (!xfailed)
3194                 xfailed = savepv(tmpbuf);
3195         }
3196 #ifndef DOSISH
3197         if (!xfound && !seen_dot && !xfailed &&
3198             (PerlLIO_stat(scriptname,&PL_statbuf) < 0
3199              || S_ISDIR(PL_statbuf.st_mode)))
3200 #endif
3201             seen_dot = 1;                       /* Disable message. */
3202         if (!xfound) {
3203             if (flags & 1) {                    /* do or die? */
3204                 /* diag_listed_as: Can't execute %s */
3205                 Perl_croak(aTHX_ "Can't %s %s%s%s",
3206                       (xfailed ? "execute" : "find"),
3207                       (xfailed ? xfailed : scriptname),
3208                       (xfailed ? "" : " on PATH"),
3209                       (xfailed || seen_dot) ? "" : ", '.' not in PATH");
3210             }
3211             scriptname = NULL;
3212         }
3213         Safefree(xfailed);
3214         scriptname = xfound;
3215     }
3216     return (scriptname ? savepv(scriptname) : NULL);
3217 }
3218
3219 #ifndef PERL_GET_CONTEXT_DEFINED
3220
3221 void *
3222 Perl_get_context(void)
3223 {
3224     dVAR;
3225 #if defined(USE_ITHREADS)
3226 #  ifdef OLD_PTHREADS_API
3227     pthread_addr_t t;
3228     int error = pthread_getspecific(PL_thr_key, &t)
3229     if (error)
3230         Perl_croak_nocontext("panic: pthread_getspecific, error=%d", error);
3231     return (void*)t;
3232 #  else
3233 #    ifdef I_MACH_CTHREADS
3234     return (void*)cthread_data(cthread_self());
3235 #    else
3236     return (void*)PTHREAD_GETSPECIFIC(PL_thr_key);
3237 #    endif
3238 #  endif
3239 #else
3240     return (void*)NULL;
3241 #endif
3242 }
3243
3244 void
3245 Perl_set_context(void *t)
3246 {
3247     dVAR;
3248     PERL_ARGS_ASSERT_SET_CONTEXT;
3249 #if defined(USE_ITHREADS)
3250 #  ifdef I_MACH_CTHREADS
3251     cthread_set_data(cthread_self(), t);
3252 #  else
3253     {
3254         const int error = pthread_setspecific(PL_thr_key, t);
3255         if (error)
3256             Perl_croak_nocontext("panic: pthread_setspecific, error=%d", error);
3257     }
3258 #  endif
3259 #else
3260     PERL_UNUSED_ARG(t);
3261 #endif
3262 }
3263
3264 #endif /* !PERL_GET_CONTEXT_DEFINED */
3265
3266 #if defined(PERL_GLOBAL_STRUCT) && !defined(PERL_GLOBAL_STRUCT_PRIVATE)
3267 struct perl_vars *
3268 Perl_GetVars(pTHX)
3269 {
3270  return &PL_Vars;
3271 }
3272 #endif
3273
3274 char **
3275 Perl_get_op_names(pTHX)
3276 {
3277     PERL_UNUSED_CONTEXT;
3278     return (char **)PL_op_name;
3279 }
3280
3281 char **
3282 Perl_get_op_descs(pTHX)
3283 {
3284     PERL_UNUSED_CONTEXT;
3285     return (char **)PL_op_desc;
3286 }
3287
3288 const char *
3289 Perl_get_no_modify(pTHX)
3290 {
3291     PERL_UNUSED_CONTEXT;
3292     return PL_no_modify;
3293 }
3294
3295 U32 *
3296 Perl_get_opargs(pTHX)
3297 {
3298     PERL_UNUSED_CONTEXT;
3299     return (U32 *)PL_opargs;
3300 }
3301
3302 PPADDR_t*
3303 Perl_get_ppaddr(pTHX)
3304 {
3305     dVAR;
3306     PERL_UNUSED_CONTEXT;
3307     return (PPADDR_t*)PL_ppaddr;
3308 }
3309
3310 #ifndef HAS_GETENV_LEN
3311 char *
3312 Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len)
3313 {
3314     char * const env_trans = PerlEnv_getenv(env_elem);
3315     PERL_UNUSED_CONTEXT;
3316     PERL_ARGS_ASSERT_GETENV_LEN;
3317     if (env_trans)
3318         *len = strlen(env_trans);
3319     return env_trans;
3320 }
3321 #endif
3322
3323
3324 MGVTBL*
3325 Perl_get_vtbl(pTHX_ int vtbl_id)
3326 {
3327     PERL_UNUSED_CONTEXT;
3328
3329     return (vtbl_id < 0 || vtbl_id >= magic_vtable_max)
3330         ? NULL : PL_magic_vtables + vtbl_id;
3331 }
3332
3333 I32
3334 Perl_my_fflush_all(pTHX)
3335 {
3336 #if defined(USE_PERLIO) || defined(FFLUSH_NULL) || defined(USE_SFIO)
3337     return PerlIO_flush(NULL);
3338 #else
3339 # if defined(HAS__FWALK)
3340     extern int fflush(FILE *);
3341     /* undocumented, unprototyped, but very useful BSDism */
3342     extern void _fwalk(int (*)(FILE *));
3343     _fwalk(&fflush);
3344     return 0;
3345 # else
3346 #  if defined(FFLUSH_ALL) && defined(HAS_STDIO_STREAM_ARRAY)
3347     long open_max = -1;
3348 #   ifdef PERL_FFLUSH_ALL_FOPEN_MAX
3349     open_max = PERL_FFLUSH_ALL_FOPEN_MAX;
3350 #   else
3351 #    if defined(HAS_SYSCONF) && defined(_SC_OPEN_MAX)
3352     open_max = sysconf(_SC_OPEN_MAX);
3353 #     else
3354 #      ifdef FOPEN_MAX
3355     open_max = FOPEN_MAX;
3356 #      else
3357 #       ifdef OPEN_MAX
3358     open_max = OPEN_MAX;
3359 #       else
3360 #        ifdef _NFILE
3361     open_max = _NFILE;
3362 #        endif
3363 #       endif
3364 #      endif
3365 #     endif
3366 #    endif
3367     if (open_max > 0) {
3368       long i;
3369       for (i = 0; i < open_max; i++)
3370             if (STDIO_STREAM_ARRAY[i]._file >= 0 &&
3371                 STDIO_STREAM_ARRAY[i]._file < open_max &&
3372                 STDIO_STREAM_ARRAY[i]._flag)
3373                 PerlIO_flush(&STDIO_STREAM_ARRAY[i]);
3374       return 0;
3375     }
3376 #  endif
3377     SETERRNO(EBADF,RMS_IFI);
3378     return EOF;
3379 # endif
3380 #endif
3381 }
3382
3383 void
3384 Perl_report_wrongway_fh(pTHX_ const GV *gv, const char have)
3385 {
3386     if (ckWARN(WARN_IO)) {
3387         HEK * const name
3388            = gv && (isGV_with_GP(gv))
3389                 ? GvENAME_HEK((gv))
3390                 : NULL;
3391         const char * const direction = have == '>' ? "out" : "in";
3392
3393         if (name && HEK_LEN(name))
3394             Perl_warner(aTHX_ packWARN(WARN_IO),
3395                         "Filehandle %"HEKf" opened only for %sput",
3396                         name, direction);
3397         else
3398             Perl_warner(aTHX_ packWARN(WARN_IO),
3399                         "Filehandle opened only for %sput", direction);
3400     }
3401 }
3402
3403 void
3404 Perl_report_evil_fh(pTHX_ const GV *gv)
3405 {
3406     const IO *io = gv ? GvIO(gv) : NULL;
3407     const PERL_BITFIELD16 op = PL_op->op_type;
3408     const char *vile;
3409     I32 warn_type;
3410
3411     if (io && IoTYPE(io) == IoTYPE_CLOSED) {
3412         vile = "closed";
3413         warn_type = WARN_CLOSED;
3414     }
3415     else {
3416         vile = "unopened";
3417         warn_type = WARN_UNOPENED;
3418     }
3419
3420     if (ckWARN(warn_type)) {
3421         SV * const name
3422             = gv && isGV_with_GP(gv) && GvENAMELEN(gv) ?
3423                                      sv_2mortal(newSVhek(GvENAME_HEK(gv))) : NULL;
3424         const char * const pars =
3425             (const char *)(OP_IS_FILETEST(op) ? "" : "()");
3426         const char * const func =
3427             (const char *)
3428             (op == OP_READLINE   ? "readline"  :        /* "<HANDLE>" not nice */
3429              op == OP_LEAVEWRITE ? "write" :            /* "write exit" not nice */
3430              PL_op_desc[op]);
3431         const char * const type =
3432             (const char *)
3433             (OP_IS_SOCKET(op) || (io && IoTYPE(io) == IoTYPE_SOCKET)
3434              ? "socket" : "filehandle");
3435         const bool have_name = name && SvCUR(name);
3436         Perl_warner(aTHX_ packWARN(warn_type),
3437                    "%s%s on %s %s%s%"SVf, func, pars, vile, type,
3438                     have_name ? " " : "",
3439                     SVfARG(have_name ? name : &PL_sv_no));
3440         if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3441                 Perl_warner(
3442                             aTHX_ packWARN(warn_type),
3443                         "\t(Are you trying to call %s%s on dirhandle%s%"SVf"?)\n",
3444                         func, pars, have_name ? " " : "",
3445                         SVfARG(have_name ? name : &PL_sv_no)
3446                             );
3447     }
3448 }
3449
3450 /* To workaround core dumps from the uninitialised tm_zone we get the
3451  * system to give us a reasonable struct to copy.  This fix means that
3452  * strftime uses the tm_zone and tm_gmtoff values returned by
3453  * localtime(time()). That should give the desired result most of the
3454  * time. But probably not always!
3455  *
3456  * This does not address tzname aspects of NETaa14816.
3457  *
3458  */
3459
3460 #ifdef HAS_GNULIBC
3461 # ifndef STRUCT_TM_HASZONE
3462 #    define STRUCT_TM_HASZONE
3463 # endif
3464 #endif
3465
3466 #ifdef STRUCT_TM_HASZONE /* Backward compat */
3467 # ifndef HAS_TM_TM_ZONE
3468 #    define HAS_TM_TM_ZONE
3469 # endif
3470 #endif
3471
3472 void
3473 Perl_init_tm(pTHX_ struct tm *ptm)      /* see mktime, strftime and asctime */
3474 {
3475 #ifdef HAS_TM_TM_ZONE
3476     Time_t now;
3477     const struct tm* my_tm;
3478     PERL_ARGS_ASSERT_INIT_TM;
3479     (void)time(&now);
3480     my_tm = localtime(&now);
3481     if (my_tm)
3482         Copy(my_tm, ptm, 1, struct tm);
3483 #else
3484     PERL_ARGS_ASSERT_INIT_TM;
3485     PERL_UNUSED_ARG(ptm);
3486 #endif
3487 }
3488
3489 /*
3490  * mini_mktime - normalise struct tm values without the localtime()
3491  * semantics (and overhead) of mktime().
3492  */
3493 void
3494 Perl_mini_mktime(pTHX_ struct tm *ptm)
3495 {
3496     int yearday;
3497     int secs;
3498     int month, mday, year, jday;
3499     int odd_cent, odd_year;
3500     PERL_UNUSED_CONTEXT;
3501
3502     PERL_ARGS_ASSERT_MINI_MKTIME;
3503
3504 #define DAYS_PER_YEAR   365
3505 #define DAYS_PER_QYEAR  (4*DAYS_PER_YEAR+1)
3506 #define DAYS_PER_CENT   (25*DAYS_PER_QYEAR-1)
3507 #define DAYS_PER_QCENT  (4*DAYS_PER_CENT+1)
3508 #define SECS_PER_HOUR   (60*60)
3509 #define SECS_PER_DAY    (24*SECS_PER_HOUR)
3510 /* parentheses deliberately absent on these two, otherwise they don't work */
3511 #define MONTH_TO_DAYS   153/5
3512 #define DAYS_TO_MONTH   5/153
3513 /* offset to bias by March (month 4) 1st between month/mday & year finding */
3514 #define YEAR_ADJUST     (4*MONTH_TO_DAYS+1)
3515 /* as used here, the algorithm leaves Sunday as day 1 unless we adjust it */
3516 #define WEEKDAY_BIAS    6       /* (1+6)%7 makes Sunday 0 again */
3517
3518 /*
3519  * Year/day algorithm notes:
3520  *
3521  * With a suitable offset for numeric value of the month, one can find
3522  * an offset into the year by considering months to have 30.6 (153/5) days,
3523  * using integer arithmetic (i.e., with truncation).  To avoid too much
3524  * messing about with leap days, we consider January and February to be
3525  * the 13th and 14th month of the previous year.  After that transformation,
3526  * we need the month index we use to be high by 1 from 'normal human' usage,
3527  * so the month index values we use run from 4 through 15.
3528  *
3529  * Given that, and the rules for the Gregorian calendar (leap years are those
3530  * divisible by 4 unless also divisible by 100, when they must be divisible
3531  * by 400 instead), we can simply calculate the number of days since some
3532  * arbitrary 'beginning of time' by futzing with the (adjusted) year number,
3533  * the days we derive from our month index, and adding in the day of the
3534  * month.  The value used here is not adjusted for the actual origin which
3535  * it normally would use (1 January A.D. 1), since we're not exposing it.
3536  * We're only building the value so we can turn around and get the
3537  * normalised values for the year, month, day-of-month, and day-of-year.
3538  *
3539  * For going backward, we need to bias the value we're using so that we find
3540  * the right year value.  (Basically, we don't want the contribution of
3541  * March 1st to the number to apply while deriving the year).  Having done
3542  * that, we 'count up' the contribution to the year number by accounting for
3543  * full quadracenturies (400-year periods) with their extra leap days, plus
3544  * the contribution from full centuries (to avoid counting in the lost leap
3545  * days), plus the contribution from full quad-years (to count in the normal
3546  * leap days), plus the leftover contribution from any non-leap years.
3547  * At this point, if we were working with an actual leap day, we'll have 0
3548  * days left over.  This is also true for March 1st, however.  So, we have
3549  * to special-case that result, and (earlier) keep track of the 'odd'
3550  * century and year contributions.  If we got 4 extra centuries in a qcent,
3551  * or 4 extra years in a qyear, then it's a leap day and we call it 29 Feb.
3552  * Otherwise, we add back in the earlier bias we removed (the 123 from
3553  * figuring in March 1st), find the month index (integer division by 30.6),
3554  * and the remainder is the day-of-month.  We then have to convert back to
3555  * 'real' months (including fixing January and February from being 14/15 in
3556  * the previous year to being in the proper year).  After that, to get
3557  * tm_yday, we work with the normalised year and get a new yearday value for
3558  * January 1st, which we subtract from the yearday value we had earlier,
3559  * representing the date we've re-built.  This is done from January 1
3560  * because tm_yday is 0-origin.
3561  *
3562  * Since POSIX time routines are only guaranteed to work for times since the
3563  * UNIX epoch (00:00:00 1 Jan 1970 UTC), the fact that this algorithm
3564  * applies Gregorian calendar rules even to dates before the 16th century
3565  * doesn't bother me.  Besides, you'd need cultural context for a given
3566  * date to know whether it was Julian or Gregorian calendar, and that's
3567  * outside the scope for this routine.  Since we convert back based on the
3568  * same rules we used to build the yearday, you'll only get strange results
3569  * for input which needed normalising, or for the 'odd' century years which
3570  * were leap years in the Julian calendar but not in the Gregorian one.
3571  * I can live with that.
3572  *
3573  * This algorithm also fails to handle years before A.D. 1 gracefully, but
3574  * that's still outside the scope for POSIX time manipulation, so I don't
3575  * care.
3576  */
3577
3578     year = 1900 + ptm->tm_year;
3579     month = ptm->tm_mon;
3580     mday = ptm->tm_mday;
3581     jday = 0;
3582     if (month >= 2)
3583         month+=2;
3584     else
3585         month+=14, year--;
3586     yearday = DAYS_PER_YEAR * year + year/4 - year/100 + year/400;
3587     yearday += month*MONTH_TO_DAYS + mday + jday;
3588     /*
3589      * Note that we don't know when leap-seconds were or will be,
3590      * so we have to trust the user if we get something which looks
3591      * like a sensible leap-second.  Wild values for seconds will
3592      * be rationalised, however.
3593      */
3594     if ((unsigned) ptm->tm_sec <= 60) {
3595         secs = 0;
3596     }
3597     else {
3598         secs = ptm->tm_sec;
3599         ptm->tm_sec = 0;
3600     }
3601     secs += 60 * ptm->tm_min;
3602     secs += SECS_PER_HOUR * ptm->tm_hour;
3603     if (secs < 0) {
3604         if (secs-(secs/SECS_PER_DAY*SECS_PER_DAY) < 0) {
3605             /* got negative remainder, but need positive time */
3606             /* back off an extra day to compensate */
3607             yearday += (secs/SECS_PER_DAY)-1;
3608             secs -= SECS_PER_DAY * (secs/SECS_PER_DAY - 1);
3609         }
3610         else {
3611             yearday += (secs/SECS_PER_DAY);
3612             secs -= SECS_PER_DAY * (secs/SECS_PER_DAY);
3613         }
3614     }
3615     else if (secs >= SECS_PER_DAY) {
3616         yearday += (secs/SECS_PER_DAY);
3617         secs %= SECS_PER_DAY;
3618     }
3619     ptm->tm_hour = secs/SECS_PER_HOUR;
3620     secs %= SECS_PER_HOUR;
3621     ptm->tm_min = secs/60;
3622     secs %= 60;
3623     ptm->tm_sec += secs;
3624     /* done with time of day effects */
3625     /*
3626      * The algorithm for yearday has (so far) left it high by 428.
3627      * To avoid mistaking a legitimate Feb 29 as Mar 1, we need to
3628      * bias it by 123 while trying to figure out what year it
3629      * really represents.  Even with this tweak, the reverse
3630      * translation fails for years before A.D. 0001.
3631      * It would still fail for Feb 29, but we catch that one below.
3632      */
3633     jday = yearday;     /* save for later fixup vis-a-vis Jan 1 */
3634     yearday -= YEAR_ADJUST;
3635     year = (yearday / DAYS_PER_QCENT) * 400;
3636     yearday %= DAYS_PER_QCENT;
3637     odd_cent = yearday / DAYS_PER_CENT;
3638     year += odd_cent * 100;
3639     yearday %= DAYS_PER_CENT;
3640     year += (yearday / DAYS_PER_QYEAR) * 4;
3641     yearday %= DAYS_PER_QYEAR;
3642     odd_year = yearday / DAYS_PER_YEAR;
3643     year += odd_year;
3644     yearday %= DAYS_PER_YEAR;
3645     if (!yearday && (odd_cent==4 || odd_year==4)) { /* catch Feb 29 */
3646         month = 1;
3647         yearday = 29;
3648     }
3649     else {
3650         yearday += YEAR_ADJUST; /* recover March 1st crock */
3651         month = yearday*DAYS_TO_MONTH;
3652         yearday -= month*MONTH_TO_DAYS;
3653         /* recover other leap-year adjustment */
3654         if (month > 13) {
3655             month-=14;
3656             year++;
3657         }
3658         else {
3659             month-=2;
3660         }
3661     }
3662     ptm->tm_year = year - 1900;
3663     if (yearday) {
3664       ptm->tm_mday = yearday;
3665       ptm->tm_mon = month;
3666     }
3667     else {
3668       ptm->tm_mday = 31;
3669       ptm->tm_mon = month - 1;
3670     }
3671     /* re-build yearday based on Jan 1 to get tm_yday */
3672     year--;
3673     yearday = year*DAYS_PER_YEAR + year/4 - year/100 + year/400;
3674     yearday += 14*MONTH_TO_DAYS + 1;
3675     ptm->tm_yday = jday - yearday;
3676     ptm->tm_wday = (jday + WEEKDAY_BIAS) % 7;
3677 }
3678
3679 char *
3680 Perl_my_strftime(pTHX_ const char *fmt, int sec, int min, int hour, int mday, int mon, int year, int wday, int yday, int isdst)
3681 {
3682 #ifdef HAS_STRFTIME
3683   char *buf;
3684   int buflen;
3685   struct tm mytm;
3686   int len;
3687
3688   PERL_ARGS_ASSERT_MY_STRFTIME;
3689
3690   init_tm(&mytm);       /* XXX workaround - see init_tm() above */
3691   mytm.tm_sec = sec;
3692   mytm.tm_min = min;
3693   mytm.tm_hour = hour;
3694   mytm.tm_mday = mday;
3695   mytm.tm_mon = mon;
3696   mytm.tm_year = year;
3697   mytm.tm_wday = wday;
3698   mytm.tm_yday = yday;
3699   mytm.tm_isdst = isdst;
3700   mini_mktime(&mytm);
3701   /* use libc to get the values for tm_gmtoff and tm_zone [perl #18238] */
3702 #if defined(HAS_MKTIME) && (defined(HAS_TM_TM_GMTOFF) || defined(HAS_TM_TM_ZONE))
3703   STMT_START {
3704     struct tm mytm2;
3705     mytm2 = mytm;
3706     mktime(&mytm2);
3707 #ifdef HAS_TM_TM_GMTOFF
3708     mytm.tm_gmtoff = mytm2.tm_gmtoff;
3709 #endif
3710 #ifdef HAS_TM_TM_ZONE
3711     mytm.tm_zone = mytm2.tm_zone;
3712 #endif
3713   } STMT_END;
3714 #endif
3715   buflen = 64;
3716   Newx(buf, buflen, char);
3717   len = strftime(buf, buflen, fmt, &mytm);
3718   /*
3719   ** The following is needed to handle to the situation where
3720   ** tmpbuf overflows.  Basically we want to allocate a buffer
3721   ** and try repeatedly.  The reason why it is so complicated
3722   ** is that getting a return value of 0 from strftime can indicate
3723   ** one of the following:
3724   ** 1. buffer overflowed,
3725   ** 2. illegal conversion specifier, or
3726   ** 3. the format string specifies nothing to be returned(not
3727   **      an error).  This could be because format is an empty string
3728   **    or it specifies %p that yields an empty string in some locale.
3729   ** If there is a better way to make it portable, go ahead by
3730   ** all means.
3731   */
3732   if ((len > 0 && len < buflen) || (len == 0 && *fmt == '\0'))
3733     return buf;
3734   else {
3735     /* Possibly buf overflowed - try again with a bigger buf */
3736     const int fmtlen = strlen(fmt);
3737     int bufsize = fmtlen + buflen;
3738
3739     Renew(buf, bufsize, char);
3740     while (buf) {
3741       buflen = strftime(buf, bufsize, fmt, &mytm);
3742       if (buflen > 0 && buflen < bufsize)
3743         break;
3744       /* heuristic to prevent out-of-memory errors */
3745       if (bufsize > 100*fmtlen) {
3746         Safefree(buf);
3747         buf = NULL;
3748         break;
3749       }
3750       bufsize *= 2;
3751       Renew(buf, bufsize, char);
3752     }
3753     return buf;
3754   }
3755 #else
3756   Perl_croak(aTHX_ "panic: no strftime");
3757   return NULL;
3758 #endif
3759 }
3760
3761
3762 #define SV_CWD_RETURN_UNDEF \
3763 sv_setsv(sv, &PL_sv_undef); \
3764 return FALSE
3765
3766 #define SV_CWD_ISDOT(dp) \
3767     (dp->d_name[0] == '.' && (dp->d_name[1] == '\0' || \
3768         (dp->d_name[1] == '.' && dp->d_name[2] == '\0')))
3769
3770 /*
3771 =head1 Miscellaneous Functions
3772
3773 =for apidoc getcwd_sv
3774
3775 Fill the sv with current working directory
3776
3777 =cut
3778 */
3779
3780 /* Originally written in Perl by John Bazik; rewritten in C by Ben Sugars.
3781  * rewritten again by dougm, optimized for use with xs TARG, and to prefer
3782  * getcwd(3) if available
3783  * Comments from the orignal:
3784  *     This is a faster version of getcwd.  It's also more dangerous
3785  *     because you might chdir out of a directory that you can't chdir
3786  *     back into. */
3787
3788 int
3789 Perl_getcwd_sv(pTHX_ SV *sv)
3790 {
3791 #ifndef PERL_MICRO
3792     dVAR;
3793 #ifndef INCOMPLETE_TAINTS
3794     SvTAINTED_on(sv);
3795 #endif
3796
3797     PERL_ARGS_ASSERT_GETCWD_SV;
3798
3799 #ifdef HAS_GETCWD
3800     {
3801         char buf[MAXPATHLEN];
3802
3803         /* Some getcwd()s automatically allocate a buffer of the given
3804          * size from the heap if they are given a NULL buffer pointer.
3805          * The problem is that this behaviour is not portable. */
3806         if (getcwd(buf, sizeof(buf) - 1)) {
3807             sv_setpv(sv, buf);
3808             return TRUE;
3809         }
3810         else {
3811             sv_setsv(sv, &PL_sv_undef);
3812             return FALSE;
3813         }
3814     }
3815
3816 #else
3817
3818     Stat_t statbuf;
3819     int orig_cdev, orig_cino, cdev, cino, odev, oino, tdev, tino;
3820     int pathlen=0;
3821     Direntry_t *dp;
3822
3823     SvUPGRADE(sv, SVt_PV);
3824
3825     if (PerlLIO_lstat(".", &statbuf) < 0) {
3826         SV_CWD_RETURN_UNDEF;
3827     }
3828
3829     orig_cdev = statbuf.st_dev;
3830     orig_cino = statbuf.st_ino;
3831     cdev = orig_cdev;
3832     cino = orig_cino;
3833
3834     for (;;) {
3835         DIR *dir;
3836         int namelen;
3837         odev = cdev;
3838         oino = cino;
3839
3840         if (PerlDir_chdir("..") < 0) {
3841             SV_CWD_RETURN_UNDEF;
3842         }
3843         if (PerlLIO_stat(".", &statbuf) < 0) {
3844             SV_CWD_RETURN_UNDEF;
3845         }
3846
3847         cdev = statbuf.st_dev;
3848         cino = statbuf.st_ino;
3849
3850         if (odev == cdev && oino == cino) {
3851             break;
3852         }
3853         if (!(dir = PerlDir_open("."))) {
3854             SV_CWD_RETURN_UNDEF;
3855         }
3856
3857         while ((dp = PerlDir_read(dir)) != NULL) {
3858 #ifdef DIRNAMLEN
3859             namelen = dp->d_namlen;
3860 #else
3861             namelen = strlen(dp->d_name);
3862 #endif
3863             /* skip . and .. */
3864             if (SV_CWD_ISDOT(dp)) {
3865                 continue;
3866             }
3867
3868             if (PerlLIO_lstat(dp->d_name, &statbuf) < 0) {
3869                 SV_CWD_RETURN_UNDEF;
3870             }
3871
3872             tdev = statbuf.st_dev;
3873             tino = statbuf.st_ino;
3874             if (tino == oino && tdev == odev) {
3875                 break;
3876             }
3877         }
3878
3879         if (!dp) {
3880             SV_CWD_RETURN_UNDEF;
3881         }
3882
3883         if (pathlen + namelen + 1 >= MAXPATHLEN) {
3884             SV_CWD_RETURN_UNDEF;
3885         }
3886
3887         SvGROW(sv, pathlen + namelen + 1);
3888
3889         if (pathlen) {
3890             /* shift down */
3891             Move(SvPVX_const(sv), SvPVX(sv) + namelen + 1, pathlen, char);
3892         }
3893
3894         /* prepend current directory to the front */
3895         *SvPVX(sv) = '/';
3896         Move(dp->d_name, SvPVX(sv)+1, namelen, char);
3897         pathlen += (namelen + 1);
3898
3899 #ifdef VOID_CLOSEDIR
3900         PerlDir_close(dir);
3901 #else
3902         if (PerlDir_close(dir) < 0) {
3903             SV_CWD_RETURN_UNDEF;
3904         }
3905 #endif
3906     }
3907
3908     if (pathlen) {
3909         SvCUR_set(sv, pathlen);
3910         *SvEND(sv) = '\0';
3911         SvPOK_only(sv);
3912
3913         if (PerlDir_chdir(SvPVX_const(sv)) < 0) {
3914             SV_CWD_RETURN_UNDEF;
3915         }
3916     }
3917     if (PerlLIO_stat(".", &statbuf) < 0) {
3918         SV_CWD_RETURN_UNDEF;
3919     }
3920
3921     cdev = statbuf.st_dev;
3922     cino = statbuf.st_ino;
3923
3924     if (cdev != orig_cdev || cino != orig_cino) {
3925         Perl_croak(aTHX_ "Unstable directory path, "
3926                    "current directory changed unexpectedly");
3927     }
3928
3929     return TRUE;
3930 #endif
3931
3932 #else
3933     return FALSE;
3934 #endif
3935 }
3936
3937 #define VERSION_MAX 0x7FFFFFFF
3938
3939 /*
3940 =for apidoc prescan_version
3941
3942 Validate that a given string can be parsed as a version object, but doesn't
3943 actually perform the parsing.  Can use either strict or lax validation rules.
3944 Can optionally set a number of hint variables to save the parsing code
3945 some time when tokenizing.
3946
3947 =cut
3948 */
3949 const char *
3950 Perl_prescan_version(pTHX_ const char *s, bool strict,
3951                      const char **errstr,
3952                      bool *sqv, int *ssaw_decimal, int *swidth, bool *salpha) {
3953     bool qv = (sqv ? *sqv : FALSE);
3954     int width = 3;
3955     int saw_decimal = 0;
3956     bool alpha = FALSE;
3957     const char *d = s;
3958
3959     PERL_ARGS_ASSERT_PRESCAN_VERSION;
3960
3961     if (qv && isDIGIT(*d))
3962         goto dotted_decimal_version;
3963
3964     if (*d == 'v') { /* explicit v-string */
3965         d++;
3966         if (isDIGIT(*d)) {
3967             qv = TRUE;
3968         }
3969         else { /* degenerate v-string */
3970             /* requires v1.2.3 */
3971             BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
3972         }
3973
3974 dotted_decimal_version:
3975         if (strict && d[0] == '0' && isDIGIT(d[1])) {
3976             /* no leading zeros allowed */
3977             BADVERSION(s,errstr,"Invalid version format (no leading zeros)");
3978         }
3979
3980         while (isDIGIT(*d))     /* integer part */
3981             d++;
3982
3983         if (*d == '.')
3984         {
3985             saw_decimal++;
3986             d++;                /* decimal point */
3987         }
3988         else
3989         {
3990             if (strict) {
3991                 /* require v1.2.3 */
3992                 BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
3993             }
3994             else {
3995                 goto version_prescan_finish;
3996             }
3997         }
3998
3999         {
4000             int i = 0;
4001             int j = 0;
4002             while (isDIGIT(*d)) {       /* just keep reading */
4003                 i++;
4004                 while (isDIGIT(*d)) {
4005                     d++; j++;
4006                     /* maximum 3 digits between decimal */
4007                     if (strict && j > 3) {
4008                         BADVERSION(s,errstr,"Invalid version format (maximum 3 digits between decimals)");
4009                     }
4010                 }
4011                 if (*d == '_') {
4012                     if (strict) {
4013                         BADVERSION(s,errstr,"Invalid version format (no underscores)");
4014                     }
4015                     if ( alpha ) {
4016                         BADVERSION(s,errstr,"Invalid version format (multiple underscores)");
4017                     }
4018                     d++;
4019                     alpha = TRUE;
4020                 }
4021                 else if (*d == '.') {
4022                     if (alpha) {
4023                         BADVERSION(s,errstr,"Invalid version format (underscores before decimal)");
4024                     }
4025                     saw_decimal++;
4026                     d++;
4027                 }
4028                 else if (!isDIGIT(*d)) {
4029                     break;
4030                 }
4031                 j = 0;
4032             }
4033
4034             if (strict && i < 2) {
4035                 /* requires v1.2.3 */
4036                 BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
4037             }
4038         }
4039     }                                   /* end if dotted-decimal */
4040     else
4041     {                                   /* decimal versions */
4042         int j = 0;                      /* may need this later */
4043         /* special strict case for leading '.' or '0' */
4044         if (strict) {
4045             if (*d == '.') {
4046                 BADVERSION(s,errstr,"Invalid version format (0 before decimal required)");
4047             }
4048             if (*d == '0' && isDIGIT(d[1])) {
4049                 BADVERSION(s,errstr,"Invalid version format (no leading zeros)");
4050             }
4051         }
4052
4053         /* and we never support negative versions */
4054         if ( *d == '-') {
4055             BADVERSION(s,errstr,"Invalid version format (negative version number)");
4056         }
4057
4058         /* consume all of the integer part */
4059         while (isDIGIT(*d))
4060             d++;
4061
4062         /* look for a fractional part */
4063         if (*d == '.') {
4064             /* we found it, so consume it */
4065             saw_decimal++;
4066             d++;
4067         }
4068         else if (!*d || *d == ';' || isSPACE(*d) || *d == '{' || *d == '}') {
4069             if ( d == s ) {
4070                 /* found nothing */
4071                 BADVERSION(s,errstr,"Invalid version format (version required)");
4072             }
4073             /* found just an integer */
4074             goto version_prescan_finish;
4075         }
4076         else if ( d == s ) {
4077             /* didn't find either integer or period */
4078             BADVERSION(s,errstr,"Invalid version format (non-numeric data)");
4079         }
4080         else if (*d == '_') {
4081             /* underscore can't come after integer part */
4082             if (strict) {
4083                 BADVERSION(s,errstr,"Invalid version format (no underscores)");
4084             }
4085             else if (isDIGIT(d[1])) {
4086                 BADVERSION(s,errstr,"Invalid version format (alpha without decimal)");
4087             }
4088             else {
4089                 BADVERSION(s,errstr,"Invalid version format (misplaced underscore)");
4090             }
4091         }
4092         else {
4093             /* anything else after integer part is just invalid data */
4094             BADVERSION(s,errstr,"Invalid version format (non-numeric data)");
4095         }
4096
4097         /* scan the fractional part after the decimal point*/
4098
4099         if (!isDIGIT(*d) && (strict || ! (!*d || *d == ';' || isSPACE(*d) || *d == '{' || *d == '}') )) {
4100                 /* strict or lax-but-not-the-end */
4101                 BADVERSION(s,errstr,"Invalid version format (fractional part required)");
4102         }
4103
4104         while (isDIGIT(*d)) {
4105             d++; j++;
4106             if (*d == '.' && isDIGIT(d[-1])) {
4107                 if (alpha) {
4108                     BADVERSION(s,errstr,"Invalid version format (underscores before decimal)");
4109                 }
4110                 if (strict) {
4111                     BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions must begin with 'v')");
4112                 }
4113                 d = (char *)s;          /* start all over again */
4114                 qv = TRUE;
4115                 goto dotted_decimal_version;
4116             }
4117             if (*d == '_') {
4118                 if (strict) {
4119                     BADVERSION(s,errstr,"Invalid version format (no underscores)");
4120                 }
4121                 if ( alpha ) {
4122                     BADVERSION(s,errstr,"Invalid version format (multiple underscores)");
4123                 }
4124                 if ( ! isDIGIT(d[1]) ) {
4125                     BADVERSION(s,errstr,"Invalid version format (misplaced underscore)");
4126                 }
4127                 width = j;
4128                 d++;
4129                 alpha = TRUE;
4130             }
4131         }
4132     }
4133
4134 version_prescan_finish:
4135     while (isSPACE(*d))
4136         d++;
4137
4138     if (!isDIGIT(*d) && (! (!*d || *d == ';' || *d == '{' || *d == '}') )) {
4139         /* trailing non-numeric data */
4140         BADVERSION(s,errstr,"Invalid version format (non-numeric data)");
4141     }
4142
4143     if (sqv)
4144         *sqv = qv;
4145     if (swidth)
4146         *swidth = width;
4147     if (ssaw_decimal)
4148         *ssaw_decimal = saw_decimal;
4149     if (salpha)
4150         *salpha = alpha;
4151     return d;
4152 }
4153
4154 /*
4155 =for apidoc scan_version
4156
4157 Returns a pointer to the next character after the parsed
4158 version string, as well as upgrading the passed in SV to
4159 an RV.
4160
4161 Function must be called with an already existing SV like
4162
4163     sv = newSV(0);
4164     s = scan_version(s, SV *sv, bool qv);
4165
4166 Performs some preprocessing to the string to ensure that
4167 it has the correct characteristics of a version.  Flags the
4168 object if it contains an underscore (which denotes this
4169 is an alpha version).  The boolean qv denotes that the version
4170 should be interpreted as if it had multiple decimals, even if
4171 it doesn't.
4172
4173 =cut
4174 */
4175
4176 const char *
4177 Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
4178 {
4179     const char *start = s;
4180     const char *pos;
4181     const char *last;
4182     const char *errstr = NULL;
4183     int saw_decimal = 0;
4184     int width = 3;
4185     bool alpha = FALSE;
4186     bool vinf = FALSE;
4187     AV * av;
4188     SV * hv;
4189
4190     PERL_ARGS_ASSERT_SCAN_VERSION;
4191
4192     while (isSPACE(*s)) /* leading whitespace is OK */
4193         s++;
4194
4195     last = prescan_version(s, FALSE, &errstr, &qv, &saw_decimal, &width, &alpha);
4196     if (errstr) {
4197         /* "undef" is a special case and not an error */
4198         if ( ! ( *s == 'u' && strEQ(s,"undef")) ) {
4199             Safefree(start);
4200             Perl_croak(aTHX_ "%s", errstr);
4201         }
4202     }
4203
4204     start = s;
4205     if (*s == 'v')
4206         s++;
4207     pos = s;
4208
4209     /* Now that we are through the prescan, start creating the object */
4210     av = newAV();
4211     hv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */
4212     (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
4213
4214 #ifndef NODEFAULT_SHAREKEYS
4215     HvSHAREKEYS_on(hv);         /* key-sharing on by default */
4216 #endif
4217
4218     if ( qv )
4219         (void)hv_stores(MUTABLE_HV(hv), "qv", newSViv(qv));
4220     if ( alpha )
4221         (void)hv_stores(MUTABLE_HV(hv), "alpha", newSViv(alpha));
4222     if ( !qv && width < 3 )
4223         (void)hv_stores(MUTABLE_HV(hv), "width", newSViv(width));
4224
4225     while (isDIGIT(*pos))
4226         pos++;
4227     if (!isALPHA(*pos)) {
4228         I32 rev;
4229
4230         for (;;) {
4231             rev = 0;
4232             {
4233                 /* this is atoi() that delimits on underscores */
4234                 const char *end = pos;
4235                 I32 mult = 1;
4236                 I32 orev;
4237
4238                 /* the following if() will only be true after the decimal
4239                  * point of a version originally created with a bare
4240                  * floating point number, i.e. not quoted in any way
4241                  */
4242                 if ( !qv && s > start && saw_decimal == 1 ) {
4243                     mult *= 100;
4244                     while ( s < end ) {
4245                         orev = rev;
4246                         rev += (*s - '0') * mult;
4247                         mult /= 10;
4248                         if (   (PERL_ABS(orev) > PERL_ABS(rev))
4249                             || (PERL_ABS(rev) > VERSION_MAX )) {
4250                             Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4251                                            "Integer overflow in version %d",VERSION_MAX);
4252                             s = end - 1;
4253                             rev = VERSION_MAX;
4254                             vinf = 1;
4255                         }
4256                         s++;
4257                         if ( *s == '_' )
4258                             s++;
4259                     }
4260                 }
4261                 else {
4262                     while (--end >= s) {
4263                         orev = rev;
4264                         rev += (*end - '0') * mult;
4265                         mult *= 10;
4266                         if (   (PERL_ABS(orev) > PERL_ABS(rev))
4267                             || (PERL_ABS(rev) > VERSION_MAX )) {
4268                             Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4269                                            "Integer overflow in version");
4270                             end = s - 1;
4271                             rev = VERSION_MAX;
4272                             vinf = 1;
4273                         }
4274                     }
4275                 }
4276             }
4277
4278             /* Append revision */
4279             av_push(av, newSViv(rev));
4280             if ( vinf ) {
4281                 s = last;
4282                 break;
4283             }
4284             else if ( *pos == '.' )
4285                 s = ++pos;
4286             else if ( *pos == '_' && isDIGIT(pos[1]) )
4287                 s = ++pos;
4288             else if ( *pos == ',' && isDIGIT(pos[1]) )
4289                 s = ++pos;
4290             else if ( isDIGIT(*pos) )
4291                 s = pos;
4292             else {
4293                 s = pos;
4294                 break;
4295             }
4296             if ( qv ) {
4297                 while ( isDIGIT(*pos) )
4298                     pos++;
4299             }
4300             else {
4301                 int digits = 0;
4302                 while ( ( isDIGIT(*pos) || *pos == '_' ) && digits < 3 ) {
4303                     if ( *pos != '_' )
4304                         digits++;
4305                     pos++;
4306                 }
4307             }
4308         }
4309     }
4310     if ( qv ) { /* quoted versions always get at least three terms*/
4311         SSize_t len = av_len(av);
4312         /* This for loop appears to trigger a compiler bug on OS X, as it
4313            loops infinitely. Yes, len is negative. No, it makes no sense.
4314            Compiler in question is:
4315            gcc version 3.3 20030304 (Apple Computer, Inc. build 1640)
4316            for ( len = 2 - len; len > 0; len-- )
4317            av_push(MUTABLE_AV(sv), newSViv(0));
4318         */
4319         len = 2 - len;
4320         while (len-- > 0)
4321             av_push(av, newSViv(0));
4322     }
4323
4324     /* need to save off the current version string for later */
4325     if ( vinf ) {
4326         SV * orig = newSVpvn("v.Inf", sizeof("v.Inf")-1);
4327         (void)hv_stores(MUTABLE_HV(hv), "original", orig);
4328         (void)hv_stores(MUTABLE_HV(hv), "vinf", newSViv(1));
4329     }
4330     else if ( s > start ) {
4331         SV * orig = newSVpvn(start,s-start);
4332         if ( qv && saw_decimal == 1 && *start != 'v' ) {
4333             /* need to insert a v to be consistent */
4334             sv_insert(orig, 0, 0, "v", 1);
4335         }
4336         (void)hv_stores(MUTABLE_HV(hv), "original", orig);
4337     }
4338     else {
4339         (void)hv_stores(MUTABLE_HV(hv), "original", newSVpvs("0"));
4340         av_push(av, newSViv(0));
4341     }
4342
4343     /* And finally, store the AV in the hash */
4344     (void)hv_stores(MUTABLE_HV(hv), "version", newRV_noinc(MUTABLE_SV(av)));
4345
4346     /* fix RT#19517 - special case 'undef' as string */
4347     if ( *s == 'u' && strEQ(s,"undef") ) {
4348         s += 5;
4349     }
4350
4351     return s;
4352 }
4353
4354 /*
4355 =for apidoc new_version
4356
4357 Returns a new version object based on the passed in SV:
4358
4359     SV *sv = new_version(SV *ver);
4360
4361 Does not alter the passed in ver SV.  See "upg_version" if you
4362 want to upgrade the SV.
4363
4364 =cut
4365 */
4366
4367 SV *
4368 Perl_new_version(pTHX_ SV *ver)
4369 {
4370     dVAR;
4371     SV * const rv = newSV(0);
4372     PERL_ARGS_ASSERT_NEW_VERSION;
4373     if ( sv_isobject(ver) && sv_derived_from(ver, "version") )
4374          /* can just copy directly */
4375     {
4376         SSize_t key;
4377         AV * const av = newAV();
4378         AV *sav;
4379         /* This will get reblessed later if a derived class*/
4380         SV * const hv = newSVrv(rv, "version");
4381         (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
4382 #ifndef NODEFAULT_SHAREKEYS
4383         HvSHAREKEYS_on(hv);         /* key-sharing on by default */
4384 #endif
4385
4386         if ( SvROK(ver) )
4387             ver = SvRV(ver);
4388
4389         /* Begin copying all of the elements */
4390         if ( hv_exists(MUTABLE_HV(ver), "qv", 2) )
4391             (void)hv_stores(MUTABLE_HV(hv), "qv", newSViv(1));
4392
4393         if ( hv_exists(MUTABLE_HV(ver), "alpha", 5) )
4394             (void)hv_stores(MUTABLE_HV(hv), "alpha", newSViv(1));
4395
4396         if ( hv_exists(MUTABLE_HV(ver), "width", 5 ) )
4397         {
4398             const I32 width = SvIV(*hv_fetchs(MUTABLE_HV(ver), "width", FALSE));
4399             (void)hv_stores(MUTABLE_HV(hv), "width", newSViv(width));
4400         }
4401
4402         if ( hv_exists(MUTABLE_HV(ver), "original", 8 ) )
4403         {
4404             SV * pv = *hv_fetchs(MUTABLE_HV(ver), "original", FALSE);
4405             (void)hv_stores(MUTABLE_HV(hv), "original", newSVsv(pv));
4406         }
4407
4408         sav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(ver), "version", FALSE)));
4409         /* This will get reblessed later if a derived class*/
4410         for ( key = 0; key <= av_len(sav); key++ )
4411         {
4412             const I32 rev = SvIV(*av_fetch(sav, key, FALSE));
4413             av_push(av, newSViv(rev));
4414         }
4415
4416         (void)hv_stores(MUTABLE_HV(hv), "version", newRV_noinc(MUTABLE_SV(av)));
4417         return rv;
4418     }
4419 #ifdef SvVOK
4420     {
4421         const MAGIC* const mg = SvVSTRING_mg(ver);
4422         if ( mg ) { /* already a v-string */
4423             const STRLEN len = mg->mg_len;
4424             char * const version = savepvn( (const char*)mg->mg_ptr, len);
4425             sv_setpvn(rv,version,len);
4426             /* this is for consistency with the pure Perl class */
4427             if ( isDIGIT(*version) )
4428                 sv_insert(rv, 0, 0, "v", 1);
4429             Safefree(version);
4430         }
4431         else {
4432 #endif
4433         sv_setsv(rv,ver); /* make a duplicate */
4434 #ifdef SvVOK
4435         }
4436     }
4437 #endif
4438     return upg_version(rv, FALSE);
4439 }
4440
4441 /*
4442 =for apidoc upg_version
4443
4444 In-place upgrade of the supplied SV to a version object.
4445
4446     SV *sv = upg_version(SV *sv, bool qv);
4447
4448 Returns a pointer to the upgraded SV.  Set the boolean qv if you want
4449 to force this SV to be interpreted as an "extended" version.
4450
4451 =cut
4452 */
4453
4454 SV *
4455 Perl_upg_version(pTHX_ SV *ver, bool qv)
4456 {
4457     const char *version, *s;
4458 #ifdef SvVOK
4459     const MAGIC *mg;
4460 #endif
4461
4462     PERL_ARGS_ASSERT_UPG_VERSION;
4463
4464     if ( SvNOK(ver) && !( SvPOK(ver) && sv_len(ver) == 3 ) )
4465     {
4466         STRLEN len;
4467
4468         /* may get too much accuracy */
4469         char tbuf[64];
4470         SV *sv = SvNVX(ver) > 10e50 ? newSV(64) : 0;
4471         char *buf;
4472 #ifdef USE_LOCALE_NUMERIC
4473         char *loc = NULL;
4474         if (! PL_numeric_standard) {
4475             loc = savepv(setlocale(LC_NUMERIC, NULL));
4476             setlocale(LC_NUMERIC, "C");
4477         }
4478 #endif
4479         if (sv) {
4480             Perl_sv_setpvf(aTHX_ sv, "%.9"NVff, SvNVX(ver));
4481             buf = SvPV(sv, len);
4482         }
4483         else {
4484             len = my_snprintf(tbuf, sizeof(tbuf), "%.9"NVff, SvNVX(ver));
4485             buf = tbuf;
4486         }
4487 #ifdef USE_LOCALE_NUMERIC
4488         if (loc) {
4489             setlocale(LC_NUMERIC, loc);
4490             Safefree(loc);
4491         }
4492 #endif
4493         while (buf[len-1] == '0' && len > 0) len--;
4494         if ( buf[len-1] == '.' ) len--; /* eat the trailing decimal */
4495         version = savepvn(buf, len);
4496         SvREFCNT_dec(sv);
4497     }
4498 #ifdef SvVOK
4499     else if ( (mg = SvVSTRING_mg(ver)) ) { /* already a v-string */
4500         version = savepvn( (const char*)mg->mg_ptr,mg->mg_len );
4501         qv = TRUE;
4502     }
4503 #endif
4504     else /* must be a string or something like a string */
4505     {
4506         STRLEN len;
4507         version = savepv(SvPV(ver,len));
4508 #ifndef SvVOK
4509 #  if PERL_VERSION > 5
4510         /* This will only be executed for 5.6.0 - 5.8.0 inclusive */
4511         if ( len >= 3 && !instr(version,".") && !instr(version,"_")) {
4512             /* may be a v-string */
4513             char *testv = (char *)version;
4514             STRLEN tlen = len;
4515             for (tlen=0; tlen < len; tlen++, testv++) {
4516                 /* if one of the characters is non-text assume v-string */
4517                 if (testv[0] < ' ') {
4518                     SV * const nsv = sv_newmortal();
4519                     const char *nver;
4520                     const char *pos;
4521                     int saw_decimal = 0;
4522                     sv_setpvf(nsv,"v%vd",ver);
4523                     pos = nver = savepv(SvPV_nolen(nsv));
4524
4525                     /* scan the resulting formatted string */
4526                     pos++; /* skip the leading 'v' */
4527                     while ( *pos == '.' || isDIGIT(*pos) ) {
4528                         if ( *pos == '.' )
4529                             saw_decimal++ ;
4530                         pos++;
4531                     }
4532
4533                     /* is definitely a v-string */
4534                     if ( saw_decimal >= 2 ) {
4535                         Safefree(version);
4536                         version = nver;
4537                     }
4538                     break;
4539                 }
4540             }
4541         }
4542 #  endif
4543 #endif
4544     }
4545
4546     s = scan_version(version, ver, qv);
4547     if ( *s != '\0' )
4548         Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
4549                        "Version string '%s' contains invalid data; "
4550                        "ignoring: '%s'", version, s);
4551     Safefree(version);
4552     return ver;
4553 }
4554
4555 /*
4556 =for apidoc vverify
4557
4558 Validates that the SV contains valid internal structure for a version object.
4559 It may be passed either the version object (RV) or the hash itself (HV).  If
4560 the structure is valid, it returns the HV.  If the structure is invalid,
4561 it returns NULL.
4562
4563     SV *hv = vverify(sv);
4564
4565 Note that it only confirms the bare minimum structure (so as not to get
4566 confused by derived classes which may contain additional hash entries):
4567
4568 =over 4
4569
4570 =item * The SV is an HV or a reference to an HV
4571
4572 =item * The hash contains a "version" key
4573
4574 =item * The "version" key has a reference to an AV as its value
4575
4576 =back
4577
4578 =cut
4579 */
4580
4581 SV *
4582 Perl_vverify(pTHX_ SV *vs)
4583 {
4584     SV *sv;
4585
4586     PERL_ARGS_ASSERT_VVERIFY;
4587
4588     if ( SvROK(vs) )
4589         vs = SvRV(vs);
4590
4591     /* see if the appropriate elements exist */
4592     if ( SvTYPE(vs) == SVt_PVHV
4593          && hv_exists(MUTABLE_HV(vs), "version", 7)
4594          && (sv = SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE)))
4595          && SvTYPE(sv) == SVt_PVAV )
4596         return vs;
4597     else
4598         return NULL;
4599 }
4600
4601 /*
4602 =for apidoc vnumify
4603
4604 Accepts a version object and returns the normalized floating
4605 point representation.  Call like:
4606
4607     sv = vnumify(rv);
4608
4609 NOTE: you can pass either the object directly or the SV
4610 contained within the RV.
4611
4612 The SV returned has a refcount of 1.
4613
4614 =cut
4615 */
4616
4617 SV *
4618 Perl_vnumify(pTHX_ SV *vs)
4619 {
4620     SSize_t i, len;
4621     I32 digit;
4622     int width;
4623     bool alpha = FALSE;
4624     SV *sv;
4625     AV *av;
4626
4627     PERL_ARGS_ASSERT_VNUMIFY;
4628
4629     /* extract the HV from the object */
4630     vs = vverify(vs);
4631     if ( ! vs )
4632         Perl_croak(aTHX_ "Invalid version object");
4633
4634     /* see if various flags exist */
4635     if ( hv_exists(MUTABLE_HV(vs), "alpha", 5 ) )
4636         alpha = TRUE;
4637     if ( hv_exists(MUTABLE_HV(vs), "width", 5 ) )
4638         width = SvIV(*hv_fetchs(MUTABLE_HV(vs), "width", FALSE));
4639     else
4640         width = 3;
4641
4642
4643     /* attempt to retrieve the version array */
4644     if ( !(av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE))) ) ) {
4645         return newSVpvs("0");
4646     }
4647
4648     len = av_len(av);
4649     if ( len == -1 )
4650     {
4651         return newSVpvs("0");
4652     }
4653
4654     digit = SvIV(*av_fetch(av, 0, 0));
4655     sv = Perl_newSVpvf(aTHX_ "%d.", (int)PERL_ABS(digit));
4656     for ( i = 1 ; i < len ; i++ )
4657     {
4658         digit = SvIV(*av_fetch(av, i, 0));
4659         if ( width < 3 ) {
4660             const int denom = (width == 2 ? 10 : 100);
4661             const div_t term = div((int)PERL_ABS(digit),denom);
4662             Perl_sv_catpvf(aTHX_ sv, "%0*d_%d", width, term.quot, term.rem);
4663         }
4664         else {
4665             Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit);
4666         }
4667     }
4668
4669     if ( len > 0 )
4670     {
4671         digit = SvIV(*av_fetch(av, len, 0));
4672         if ( alpha && width == 3 ) /* alpha version */
4673             sv_catpvs(sv,"_");
4674         Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit);
4675     }
4676     else /* len == 0 */
4677     {
4678         sv_catpvs(sv, "000");
4679     }
4680     return sv;
4681 }
4682
4683 /*
4684 =for apidoc vnormal
4685
4686 Accepts a version object and returns the normalized string
4687 representation.  Call like:
4688
4689     sv = vnormal(rv);
4690
4691 NOTE: you can pass either the object directly or the SV
4692 contained within the RV.
4693
4694 The SV returned has a refcount of 1.
4695
4696 =cut
4697 */
4698
4699 SV *
4700 Perl_vnormal(pTHX_ SV *vs)
4701 {
4702     I32 i, len, digit;
4703     bool alpha = FALSE;
4704     SV *sv;
4705     AV *av;
4706
4707     PERL_ARGS_ASSERT_VNORMAL;
4708
4709     /* extract the HV from the object */
4710     vs = vverify(vs);
4711     if ( ! vs )
4712         Perl_croak(aTHX_ "Invalid version object");
4713
4714     if ( hv_exists(MUTABLE_HV(vs), "alpha", 5 ) )
4715         alpha = TRUE;
4716     av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE)));
4717
4718     len = av_len(av);
4719     if ( len == -1 )
4720     {
4721         return newSVpvs("");
4722     }
4723     digit = SvIV(*av_fetch(av, 0, 0));
4724     sv = Perl_newSVpvf(aTHX_ "v%"IVdf, (IV)digit);
4725     for ( i = 1 ; i < len ; i++ ) {
4726         digit = SvIV(*av_fetch(av, i, 0));
4727         Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
4728     }
4729
4730     if ( len > 0 )
4731     {
4732         /* handle last digit specially */
4733         digit = SvIV(*av_fetch(av, len, 0));
4734         if ( alpha )
4735             Perl_sv_catpvf(aTHX_ sv, "_%"IVdf, (IV)digit);
4736         else
4737             Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
4738     }
4739
4740     if ( len <= 2 ) { /* short version, must be at least three */
4741         for ( len = 2 - len; len != 0; len-- )
4742             sv_catpvs(sv,".0");
4743     }
4744     return sv;
4745 }
4746
4747 /*
4748 =for apidoc vstringify
4749
4750 In order to maintain maximum compatibility with earlier versions
4751 of Perl, this function will return either the floating point
4752 notation or the multiple dotted notation, depending on whether
4753 the original version contained 1 or more dots, respectively.
4754
4755 The SV returned has a refcount of 1.
4756
4757 =cut
4758 */
4759
4760 SV *
4761 Perl_vstringify(pTHX_ SV *vs)
4762 {
4763     PERL_ARGS_ASSERT_VSTRINGIFY;
4764
4765     /* extract the HV from the object */
4766     vs = vverify(vs);
4767     if ( ! vs )
4768         Perl_croak(aTHX_ "Invalid version object");
4769
4770     if (hv_exists(MUTABLE_HV(vs), "original",  sizeof("original") - 1)) {
4771         SV *pv;
4772         pv = *hv_fetchs(MUTABLE_HV(vs), "original", FALSE);
4773         if ( SvPOK(pv) )
4774             return newSVsv(pv);
4775         else
4776             return &PL_sv_undef;
4777     }
4778     else {
4779         if ( hv_exists(MUTABLE_HV(vs), "qv", 2) )
4780             return vnormal(vs);
4781         else
4782             return vnumify(vs);
4783     }
4784 }
4785
4786 /*
4787 =for apidoc vcmp
4788
4789 Version object aware cmp.  Both operands must already have been
4790 converted into version objects.
4791
4792 =cut
4793 */
4794
4795 int
4796 Perl_vcmp(pTHX_ SV *lhv, SV *rhv)
4797 {
4798     SSize_t i,l,m,r;
4799     I32 retval;
4800     bool lalpha = FALSE;
4801     bool ralpha = FALSE;
4802     I32 left = 0;
4803     I32 right = 0;
4804     AV *lav, *rav;
4805
4806     PERL_ARGS_ASSERT_VCMP;
4807
4808     /* extract the HVs from the objects */
4809     lhv = vverify(lhv);
4810     rhv = vverify(rhv);
4811     if ( ! ( lhv && rhv ) )
4812         Perl_croak(aTHX_ "Invalid version object");
4813
4814     /* get the left hand term */
4815     lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(lhv), "version", FALSE)));
4816     if ( hv_exists(MUTABLE_HV(lhv), "alpha", 5 ) )
4817         lalpha = TRUE;
4818
4819     /* and the right hand term */
4820     rav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(rhv), "version", FALSE)));
4821     if ( hv_exists(MUTABLE_HV(rhv), "alpha", 5 ) )
4822         ralpha = TRUE;
4823
4824     l = av_len(lav);
4825     r = av_len(rav);
4826     m = l < r ? l : r;
4827     retval = 0;
4828     i = 0;
4829     while ( i <= m && retval == 0 )
4830     {
4831         left  = SvIV(*av_fetch(lav,i,0));
4832         right = SvIV(*av_fetch(rav,i,0));
4833         if ( left < right  )
4834             retval = -1;
4835         if ( left > right )
4836             retval = +1;
4837         i++;
4838     }
4839
4840     /* tiebreaker for alpha with identical terms */
4841     if ( retval == 0 && l == r && left == right && ( lalpha || ralpha ) )
4842     {
4843         if ( lalpha && !ralpha )
4844         {
4845             retval = -1;
4846         }
4847         else if ( ralpha && !lalpha)
4848         {
4849             retval = +1;
4850         }
4851     }
4852
4853     if ( l != r && retval == 0 ) /* possible match except for trailing 0's */
4854     {
4855         if ( l < r )
4856         {
4857             while ( i <= r && retval == 0 )
4858             {
4859                 if ( SvIV(*av_fetch(rav,i,0)) != 0 )
4860                     retval = -1; /* not a match after all */
4861                 i++;
4862             }
4863         }
4864         else
4865         {
4866             while ( i <= l && retval == 0 )
4867             {
4868                 if ( SvIV(*av_fetch(lav,i,0)) != 0 )
4869                     retval = +1; /* not a match after all */
4870                 i++;
4871             }
4872         }
4873     }
4874     return retval;
4875 }
4876
4877 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET) && defined(SOCK_DGRAM) && defined(HAS_SELECT)
4878 #   define EMULATE_SOCKETPAIR_UDP
4879 #endif
4880
4881 #ifdef EMULATE_SOCKETPAIR_UDP
4882 static int
4883 S_socketpair_udp (int fd[2]) {
4884     dTHX;
4885     /* Fake a datagram socketpair using UDP to localhost.  */
4886     int sockets[2] = {-1, -1};
4887     struct sockaddr_in addresses[2];
4888     int i;
4889     Sock_size_t size = sizeof(struct sockaddr_in);
4890     unsigned short port;
4891     int got;
4892
4893     memset(&addresses, 0, sizeof(addresses));
4894     i = 1;
4895     do {
4896         sockets[i] = PerlSock_socket(AF_INET, SOCK_DGRAM, PF_INET);
4897         if (sockets[i] == -1)
4898             goto tidy_up_and_fail;
4899
4900         addresses[i].sin_family = AF_INET;
4901         addresses[i].sin_addr.s_addr = htonl(INADDR_LOOPBACK);
4902         addresses[i].sin_port = 0;      /* kernel choses port.  */
4903         if (PerlSock_bind(sockets[i], (struct sockaddr *) &addresses[i],
4904                 sizeof(struct sockaddr_in)) == -1)
4905             goto tidy_up_and_fail;
4906     } while (i--);
4907
4908     /* Now have 2 UDP sockets. Find out which port each is connected to, and
4909        for each connect the other socket to it.  */
4910     i = 1;
4911     do {
4912         if (PerlSock_getsockname(sockets[i], (struct sockaddr *) &addresses[i],
4913                 &size) == -1)
4914             goto tidy_up_and_fail;
4915         if (size != sizeof(struct sockaddr_in))
4916             goto abort_tidy_up_and_fail;
4917         /* !1 is 0, !0 is 1 */
4918         if (PerlSock_connect(sockets[!i], (struct sockaddr *) &addresses[i],
4919                 sizeof(struct sockaddr_in)) == -1)
4920             goto tidy_up_and_fail;
4921     } while (i--);
4922
4923     /* Now we have 2 sockets connected to each other. I don't trust some other
4924        process not to have already sent a packet to us (by random) so send
4925        a packet from each to the other.  */
4926     i = 1;
4927     do {
4928         /* I'm going to send my own port number.  As a short.
4929            (Who knows if someone somewhere has sin_port as a bitfield and needs
4930            this routine. (I'm assuming crays have socketpair)) */
4931         port = addresses[i].sin_port;
4932         got = PerlLIO_write(sockets[i], &port, sizeof(port));
4933         if (got != sizeof(port)) {
4934             if (got == -1)
4935                 goto tidy_up_and_fail;
4936             goto abort_tidy_up_and_fail;
4937         }
4938     } while (i--);
4939
4940     /* Packets sent. I don't trust them to have arrived though.
4941        (As I understand it Solaris TCP stack is multithreaded. Non-blocking
4942        connect to localhost will use a second kernel thread. In 2.6 the
4943        first thread running the connect() returns before the second completes,
4944        so EINPROGRESS> In 2.7 the improved stack is faster and connect()
4945        returns 0. Poor programs have tripped up. One poor program's authors'
4946        had a 50-1 reverse stock split. Not sure how connected these were.)
4947        So I don't trust someone not to have an unpredictable UDP stack.
4948     */
4949
4950     {
4951         struct timeval waitfor = {0, 100000}; /* You have 0.1 seconds */
4952         int max = sockets[1] > sockets[0] ? sockets[1] : sockets[0];
4953         fd_set rset;
4954
4955         FD_ZERO(&rset);
4956         FD_SET((unsigned int)sockets[0], &rset);
4957         FD_SET((unsigned int)sockets[1], &rset);
4958
4959         got = PerlSock_select(max + 1, &rset, NULL, NULL, &waitfor);
4960         if (got != 2 || !FD_ISSET(sockets[0], &rset)
4961                 || !FD_ISSET(sockets[1], &rset)) {
4962             /* I hope this is portable and appropriate.  */
4963             if (got == -1)
4964                 goto tidy_up_and_fail;
4965             goto abort_tidy_up_and_fail;
4966         }
4967     }
4968
4969     /* And the paranoia department even now doesn't trust it to have arrive
4970        (hence MSG_DONTWAIT). Or that what arrives was sent by us.  */
4971     {
4972         struct sockaddr_in readfrom;
4973         unsigned short buffer[2];
4974
4975         i = 1;
4976         do {
4977 #ifdef MSG_DONTWAIT
4978             got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
4979                     sizeof(buffer), MSG_DONTWAIT,
4980                     (struct sockaddr *) &readfrom, &size);
4981 #else
4982             got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
4983                     sizeof(buffer), 0,
4984                     (struct sockaddr *) &readfrom, &size);
4985 #endif
4986
4987             if (got == -1)
4988                 goto tidy_up_and_fail;
4989             if (got != sizeof(port)
4990                     || size != sizeof(struct sockaddr_in)
4991                     /* Check other socket sent us its port.  */
4992                     || buffer[0] != (unsigned short) addresses[!i].sin_port
4993                     /* Check kernel says we got the datagram from that socket */
4994                     || readfrom.sin_family != addresses[!i].sin_family
4995                     || readfrom.sin_addr.s_addr != addresses[!i].sin_addr.s_addr
4996                     || readfrom.sin_port != addresses[!i].sin_port)
4997                 goto abort_tidy_up_and_fail;
4998         } while (i--);
4999     }
5000     /* My caller (my_socketpair) has validated that this is non-NULL  */
5001     fd[0] = sockets[0];
5002     fd[1] = sockets[1];
5003     /* I hereby declare this connection open.  May God bless all who cross
5004        her.  */
5005     return 0;
5006
5007   abort_tidy_up_and_fail:
5008     errno = ECONNABORTED;
5009   tidy_up_and_fail:
5010     {
5011         dSAVE_ERRNO;
5012         if (sockets[0] != -1)
5013             PerlLIO_close(sockets[0]);
5014         if (sockets[1] != -1)
5015             PerlLIO_close(sockets[1]);
5016         RESTORE_ERRNO;
5017         return -1;
5018     }
5019 }
5020 #endif /*  EMULATE_SOCKETPAIR_UDP */
5021
5022 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET)
5023 int
5024 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
5025     /* Stevens says that family must be AF_LOCAL, protocol 0.
5026        I'm going to enforce that, then ignore it, and use TCP (or UDP).  */
5027     dTHXa(NULL);
5028     int listener = -1;
5029     int connector = -1;
5030     int acceptor = -1;
5031     struct sockaddr_in listen_addr;
5032     struct sockaddr_in connect_addr;
5033     Sock_size_t size;
5034
5035     if (protocol
5036 #ifdef AF_UNIX
5037         || family != AF_UNIX
5038 #endif
5039     ) {
5040         errno = EAFNOSUPPORT;
5041         return -1;
5042     }
5043     if (!fd) {
5044         errno = EINVAL;
5045         return -1;
5046     }
5047
5048 #ifdef EMULATE_SOCKETPAIR_UDP
5049     if (type == SOCK_DGRAM)
5050         return S_socketpair_udp(fd);
5051 #endif
5052
5053     aTHXa(PERL_GET_THX);
5054     listener = PerlSock_socket(AF_INET, type, 0);
5055     if (listener == -1)
5056         return -1;
5057     memset(&listen_addr, 0, sizeof(listen_addr));
5058     listen_addr.sin_family = AF_INET;
5059     listen_addr.sin_addr.s_addr = htonl(INADDR_LOOPBACK);
5060     listen_addr.sin_port = 0;   /* kernel choses port.  */
5061     if (PerlSock_bind(listener, (struct sockaddr *) &listen_addr,
5062             sizeof(listen_addr)) == -1)
5063         goto tidy_up_and_fail;
5064     if (PerlSock_listen(listener, 1) == -1)
5065         goto tidy_up_and_fail;
5066
5067     connector = PerlSock_socket(AF_INET, type, 0);
5068     if (connector == -1)
5069         goto tidy_up_and_fail;
5070     /* We want to find out the port number to connect to.  */
5071     size = sizeof(connect_addr);
5072     if (PerlSock_getsockname(listener, (struct sockaddr *) &connect_addr,
5073             &size) == -1)
5074         goto tidy_up_and_fail;
5075     if (size != sizeof(connect_addr))
5076         goto abort_tidy_up_and_fail;
5077     if (PerlSock_connect(connector, (struct sockaddr *) &connect_addr,
5078             sizeof(connect_addr)) == -1)
5079         goto tidy_up_and_fail;
5080
5081     size = sizeof(listen_addr);
5082     acceptor = PerlSock_accept(listener, (struct sockaddr *) &listen_addr,
5083             &size);
5084     if (acceptor == -1)
5085         goto tidy_up_and_fail;
5086     if (size != sizeof(listen_addr))
5087         goto abort_tidy_up_and_fail;
5088     PerlLIO_close(listener);
5089     /* Now check we are talking to ourself by matching port and host on the
5090        two sockets.  */
5091     if (PerlSock_getsockname(connector, (struct sockaddr *) &connect_addr,
5092             &size) == -1)
5093         goto tidy_up_and_fail;
5094     if (size != sizeof(connect_addr)
5095             || listen_addr.sin_family != connect_addr.sin_family
5096             || listen_addr.sin_addr.s_addr != connect_addr.sin_addr.s_addr
5097             || listen_addr.sin_port != connect_addr.sin_port) {
5098         goto abort_tidy_up_and_fail;
5099     }
5100     fd[0] = connector;
5101     fd[1] = acceptor;
5102     return 0;
5103
5104   abort_tidy_up_and_fail:
5105 #ifdef ECONNABORTED
5106   errno = ECONNABORTED; /* This would be the standard thing to do. */
5107 #else
5108 #  ifdef ECONNREFUSED
5109   errno = ECONNREFUSED; /* E.g. Symbian does not have ECONNABORTED. */
5110 #  else
5111   errno = ETIMEDOUT;    /* Desperation time. */
5112 #  endif
5113 #endif
5114   tidy_up_and_fail:
5115     {
5116         dSAVE_ERRNO;
5117         if (listener != -1)
5118             PerlLIO_close(listener);
5119         if (connector != -1)
5120             PerlLIO_close(connector);
5121         if (acceptor != -1)
5122             PerlLIO_close(acceptor);
5123         RESTORE_ERRNO;
5124         return -1;
5125     }
5126 }
5127 #else
5128 /* In any case have a stub so that there's code corresponding
5129  * to the my_socketpair in embed.fnc. */
5130 int
5131 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
5132 #ifdef HAS_SOCKETPAIR
5133     return socketpair(family, type, protocol, fd);
5134 #else
5135     return -1;
5136 #endif
5137 }
5138 #endif
5139
5140 /*
5141
5142 =for apidoc sv_nosharing
5143
5144 Dummy routine which "shares" an SV when there is no sharing module present.
5145 Or "locks" it. Or "unlocks" it. In other words, ignores its single SV argument.
5146 Exists to avoid test for a NULL function pointer and because it could
5147 potentially warn under some level of strict-ness.
5148
5149 =cut
5150 */
5151
5152 void
5153 Perl_sv_nosharing(pTHX_ SV *sv)
5154 {
5155     PERL_UNUSED_CONTEXT;
5156     PERL_UNUSED_ARG(sv);
5157 }
5158
5159 /*
5160
5161 =for apidoc sv_destroyable
5162
5163 Dummy routine which reports that object can be destroyed when there is no
5164 sharing module present.  It ignores its single SV argument, and returns
5165 'true'.  Exists to avoid test for a NULL function pointer and because it
5166 could potentially warn under some level of strict-ness.
5167
5168 =cut
5169 */
5170
5171 bool
5172 Perl_sv_destroyable(pTHX_ SV *sv)
5173 {
5174     PERL_UNUSED_CONTEXT;
5175     PERL_UNUSED_ARG(sv);
5176     return TRUE;
5177 }
5178
5179 U32
5180 Perl_parse_unicode_opts(pTHX_ const char **popt)
5181 {
5182   const char *p = *popt;
5183   U32 opt = 0;
5184
5185   PERL_ARGS_ASSERT_PARSE_UNICODE_OPTS;
5186
5187   if (*p) {
5188        if (isDIGIT(*p)) {
5189             opt = (U32) atoi(p);
5190             while (isDIGIT(*p))
5191                 p++;
5192             if (*p && *p != '\n' && *p != '\r') {
5193              if(isSPACE(*p)) goto the_end_of_the_opts_parser;
5194              else
5195                  Perl_croak(aTHX_ "Unknown Unicode option letter '%c'", *p);
5196             }
5197        }
5198        else {
5199             for (; *p; p++) {
5200                  switch (*p) {
5201                  case PERL_UNICODE_STDIN:
5202                       opt |= PERL_UNICODE_STDIN_FLAG;   break;
5203                  case PERL_UNICODE_STDOUT:
5204                       opt |= PERL_UNICODE_STDOUT_FLAG;  break;
5205                  case PERL_UNICODE_STDERR:
5206                       opt |= PERL_UNICODE_STDERR_FLAG;  break;
5207                  case PERL_UNICODE_STD:
5208                       opt |= PERL_UNICODE_STD_FLAG;     break;
5209                  case PERL_UNICODE_IN:
5210                       opt |= PERL_UNICODE_IN_FLAG;      break;
5211                  case PERL_UNICODE_OUT:
5212                       opt |= PERL_UNICODE_OUT_FLAG;     break;
5213                  case PERL_UNICODE_INOUT:
5214                       opt |= PERL_UNICODE_INOUT_FLAG;   break;
5215                  case PERL_UNICODE_LOCALE:
5216                       opt |= PERL_UNICODE_LOCALE_FLAG;  break;
5217                  case PERL_UNICODE_ARGV:
5218                       opt |= PERL_UNICODE_ARGV_FLAG;    break;
5219                  case PERL_UNICODE_UTF8CACHEASSERT:
5220                       opt |= PERL_UNICODE_UTF8CACHEASSERT_FLAG; break;
5221                  default:
5222                       if (*p != '\n' && *p != '\r') {
5223                         if(isSPACE(*p)) goto the_end_of_the_opts_parser;
5224                         else
5225                           Perl_croak(aTHX_
5226                                      "Unknown Unicode option letter '%c'", *p);
5227                       }
5228                  }
5229             }
5230        }
5231   }
5232   else
5233        opt = PERL_UNICODE_DEFAULT_FLAGS;
5234
5235   the_end_of_the_opts_parser:
5236
5237   if (opt & ~PERL_UNICODE_ALL_FLAGS)
5238        Perl_croak(aTHX_ "Unknown Unicode option value %"UVuf,
5239                   (UV) (opt & ~PERL_UNICODE_ALL_FLAGS));
5240
5241   *popt = p;
5242
5243   return opt;
5244 }
5245
5246 #ifdef VMS
5247 #  include <starlet.h>
5248 #endif
5249
5250 U32
5251 Perl_seed(pTHX)
5252 {
5253     dVAR;
5254     /*
5255      * This is really just a quick hack which grabs various garbage
5256      * values.  It really should be a real hash algorithm which
5257      * spreads the effect of every input bit onto every output bit,
5258      * if someone who knows about such things would bother to write it.
5259      * Might be a good idea to add that function to CORE as well.
5260      * No numbers below come from careful analysis or anything here,
5261      * except they are primes and SEED_C1 > 1E6 to get a full-width
5262      * value from (tv_sec * SEED_C1 + tv_usec).  The multipliers should
5263      * probably be bigger too.
5264      */
5265 #if RANDBITS > 16
5266 #  define SEED_C1       1000003
5267 #define   SEED_C4       73819
5268 #else
5269 #  define SEED_C1       25747
5270 #define   SEED_C4       20639
5271 #endif
5272 #define   SEED_C2       3
5273 #define   SEED_C3       269
5274 #define   SEED_C5       26107
5275
5276 #ifndef PERL_NO_DEV_RANDOM
5277     int fd;
5278 #endif
5279     U32 u;
5280 #ifdef VMS
5281     /* when[] = (low 32 bits, high 32 bits) of time since epoch
5282      * in 100-ns units, typically incremented ever 10 ms.        */
5283     unsigned int when[2];
5284 #else
5285 #  ifdef HAS_GETTIMEOFDAY
5286     struct timeval when;
5287 #  else
5288     Time_t when;
5289 #  endif
5290 #endif
5291
5292 /* This test is an escape hatch, this symbol isn't set by Configure. */
5293 #ifndef PERL_NO_DEV_RANDOM
5294 #ifndef PERL_RANDOM_DEVICE
5295    /* /dev/random isn't used by default because reads from it will block
5296     * if there isn't enough entropy available.  You can compile with
5297     * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
5298     * is enough real entropy to fill the seed. */
5299 #  define PERL_RANDOM_DEVICE "/dev/urandom"
5300 #endif
5301     fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
5302     if (fd != -1) {
5303         if (PerlLIO_read(fd, (void*)&u, sizeof u) != sizeof u)
5304             u = 0;
5305         PerlLIO_close(fd);
5306         if (u)
5307             return u;
5308     }
5309 #endif
5310
5311 #ifdef VMS
5312     _ckvmssts(sys$gettim(when));
5313     u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
5314 #else
5315 #  ifdef HAS_GETTIMEOFDAY
5316     PerlProc_gettimeofday(&when,NULL);
5317     u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
5318 #  else
5319     (void)time(&when);
5320     u = (U32)SEED_C1 * when;
5321 #  endif
5322 #endif
5323     u += SEED_C3 * (U32)PerlProc_getpid();
5324     u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
5325 #ifndef PLAN9           /* XXX Plan9 assembler chokes on this; fix needed  */
5326     u += SEED_C5 * (U32)PTR2UV(&when);
5327 #endif
5328     return u;
5329 }
5330
5331 void
5332 Perl_get_hash_seed(pTHX_ unsigned char * const seed_buffer)
5333 {
5334     dVAR;
5335     const char *env_pv;
5336     unsigned long i;
5337
5338     PERL_ARGS_ASSERT_GET_HASH_SEED;
5339
5340     env_pv= PerlEnv_getenv("PERL_HASH_SEED");
5341
5342     if ( env_pv )
5343 #ifndef USE_HASH_SEED_EXPLICIT
5344     {
5345         /* ignore leading spaces */
5346         while (isSPACE(*env_pv))
5347             env_pv++;
5348 #ifdef USE_PERL_PERTURB_KEYS
5349         /* if they set it to "0" we disable key traversal randomization completely */
5350         if (strEQ(env_pv,"0")) {
5351             PL_hash_rand_bits_enabled= 0;
5352         } else {
5353             /* otherwise switch to deterministic mode */
5354             PL_hash_rand_bits_enabled= 2;
5355         }
5356 #endif
5357         /* ignore a leading 0x... if it is there */
5358         if (env_pv[0] == '0' && env_pv[1] == 'x')
5359             env_pv += 2;
5360
5361         for( i = 0; isXDIGIT(*env_pv) && i < PERL_HASH_SEED_BYTES; i++ ) {
5362             seed_buffer[i] = READ_XDIGIT(env_pv) << 4;
5363             if ( isXDIGIT(*env_pv)) {
5364                 seed_buffer[i] |= READ_XDIGIT(env_pv);
5365             }
5366         }
5367         while (isSPACE(*env_pv))
5368             env_pv++;
5369
5370         if (*env_pv && !isXDIGIT(*env_pv)) {
5371             Perl_warn(aTHX_ "perl: warning: Non hex character in '$ENV{PERL_HASH_SEED}', seed only partially set\n");
5372         }
5373         /* should we check for unparsed crap? */
5374         /* should we warn about unused hex? */
5375         /* should we warn about insufficient hex? */
5376     }
5377     else
5378 #endif
5379     {
5380         (void)seedDrand01((Rand_seed_t)seed());
5381
5382         for( i = 0; i < PERL_HASH_SEED_BYTES; i++ ) {
5383             seed_buffer[i] = (unsigned char)(Drand01() * (U8_MAX+1));
5384         }
5385     }
5386 #ifdef USE_PERL_PERTURB_KEYS
5387     {   /* initialize PL_hash_rand_bits from the hash seed.
5388          * This value is highly volatile, it is updated every
5389          * hash insert, and is used as part of hash bucket chain
5390          * randomization and hash iterator randomization. */
5391         PL_hash_rand_bits= 0xbe49d17f; /* I just picked a number */
5392         for( i = 0; i < sizeof(UV) ; i++ ) {
5393             PL_hash_rand_bits += seed_buffer[i % PERL_HASH_SEED_BYTES];
5394             PL_hash_rand_bits = ROTL_UV(PL_hash_rand_bits,8);
5395         }
5396     }
5397     env_pv= PerlEnv_getenv("PERL_PERTURB_KEYS");
5398     if (env_pv) {
5399         if (strEQ(env_pv,"0") || strEQ(env_pv,"NO")) {
5400             PL_hash_rand_bits_enabled= 0;
5401         } else if (strEQ(env_pv,"1") || strEQ(env_pv,"RANDOM")) {
5402             PL_hash_rand_bits_enabled= 1;
5403         } else if (strEQ(env_pv,"2") || strEQ(env_pv,"DETERMINISTIC")) {
5404             PL_hash_rand_bits_enabled= 2;
5405         } else {
5406             Perl_warn(aTHX_ "perl: warning: strange setting in '$ENV{PERL_PERTURB_KEYS}': '%s'\n", env_pv);
5407         }
5408     }
5409 #endif
5410 }
5411
5412 #ifdef PERL_GLOBAL_STRUCT
5413
5414 #define PERL_GLOBAL_STRUCT_INIT
5415 #include "opcode.h" /* the ppaddr and check */
5416
5417 struct perl_vars *
5418 Perl_init_global_struct(pTHX)
5419 {
5420     struct perl_vars *plvarsp = NULL;
5421 # ifdef PERL_GLOBAL_STRUCT
5422     const IV nppaddr = sizeof(Gppaddr)/sizeof(Perl_ppaddr_t);
5423     const IV ncheck  = sizeof(Gcheck) /sizeof(Perl_check_t);
5424 #  ifdef PERL_GLOBAL_STRUCT_PRIVATE
5425     /* PerlMem_malloc() because can't use even safesysmalloc() this early. */
5426     plvarsp = (struct perl_vars*)PerlMem_malloc(sizeof(struct perl_vars));
5427     if (!plvarsp)
5428         exit(1);
5429 #  else
5430     plvarsp = PL_VarsPtr;
5431 #  endif /* PERL_GLOBAL_STRUCT_PRIVATE */
5432 #  undef PERLVAR
5433 #  undef PERLVARA
5434 #  undef PERLVARI
5435 #  undef PERLVARIC
5436 #  define PERLVAR(prefix,var,type) /**/
5437 #  define PERLVARA(prefix,var,n,type) /**/
5438 #  define PERLVARI(prefix,var,type,init) plvarsp->prefix##var = init;
5439 #  define PERLVARIC(prefix,var,type,init) plvarsp->prefix##var = init;
5440 #  include "perlvars.h"
5441 #  undef PERLVAR
5442 #  undef PERLVARA
5443 #  undef PERLVARI
5444 #  undef PERLVARIC
5445 #  ifdef PERL_GLOBAL_STRUCT
5446     plvarsp->Gppaddr =
5447         (Perl_ppaddr_t*)
5448         PerlMem_malloc(nppaddr * sizeof(Perl_ppaddr_t));
5449     if (!plvarsp->Gppaddr)
5450         exit(1);
5451     plvarsp->Gcheck  =
5452         (Perl_check_t*)
5453         PerlMem_malloc(ncheck  * sizeof(Perl_check_t));
5454     if (!plvarsp->Gcheck)
5455         exit(1);
5456     Copy(Gppaddr, plvarsp->Gppaddr, nppaddr, Perl_ppaddr_t);
5457     Copy(Gcheck,  plvarsp->Gcheck,  ncheck,  Perl_check_t);
5458 #  endif
5459 #  ifdef PERL_SET_VARS
5460     PERL_SET_VARS(plvarsp);
5461 #  endif
5462 #  ifdef PERL_GLOBAL_STRUCT_PRIVATE
5463     plvarsp->Gsv_placeholder.sv_flags = 0;
5464     memset(plvarsp->Ghash_seed, 0, sizeof(plvarsp->Ghash_seed));
5465 #  endif
5466 # undef PERL_GLOBAL_STRUCT_INIT
5467 # endif
5468     return plvarsp;
5469 }
5470
5471 #endif /* PERL_GLOBAL_STRUCT */
5472
5473 #ifdef PERL_GLOBAL_STRUCT
5474
5475 void
5476 Perl_free_global_struct(pTHX_ struct perl_vars *plvarsp)
5477 {
5478     PERL_ARGS_ASSERT_FREE_GLOBAL_STRUCT;
5479 # ifdef PERL_GLOBAL_STRUCT
5480 #  ifdef PERL_UNSET_VARS
5481     PERL_UNSET_VARS(plvarsp);
5482 #  endif
5483     free(plvarsp->Gppaddr);
5484     free(plvarsp->Gcheck);
5485 #  ifdef PERL_GLOBAL_STRUCT_PRIVATE
5486     free(plvarsp);
5487 #  endif
5488 # endif
5489 }
5490
5491 #endif /* PERL_GLOBAL_STRUCT */
5492
5493 #ifdef PERL_MEM_LOG
5494
5495 /* -DPERL_MEM_LOG: the Perl_mem_log_..() is compiled, including the
5496  * the default implementation, unless -DPERL_MEM_LOG_NOIMPL is also
5497  * given, and you supply your own implementation.
5498  *
5499  * The default implementation reads a single env var, PERL_MEM_LOG,
5500  * expecting one or more of the following:
5501  *
5502  *    \d+ - fd          fd to write to          : must be 1st (atoi)
5503  *    'm' - memlog      was PERL_MEM_LOG=1
5504  *    's' - svlog       was PERL_SV_LOG=1
5505  *    't' - timestamp   was PERL_MEM_LOG_TIMESTAMP=1
5506  *
5507  * This makes the logger controllable enough that it can reasonably be
5508  * added to the system perl.
5509  */
5510
5511 /* -DPERL_MEM_LOG_SPRINTF_BUF_SIZE=X: size of a (stack-allocated) buffer
5512  * the Perl_mem_log_...() will use (either via sprintf or snprintf).
5513  */
5514 #define PERL_MEM_LOG_SPRINTF_BUF_SIZE 128
5515
5516 /* -DPERL_MEM_LOG_FD=N: the file descriptor the Perl_mem_log_...()
5517  * writes to.  In the default logger, this is settable at runtime.
5518  */
5519 #ifndef PERL_MEM_LOG_FD
5520 #  define PERL_MEM_LOG_FD 2 /* If STDERR is too boring for you. */
5521 #endif
5522
5523 #ifndef PERL_MEM_LOG_NOIMPL
5524
5525 # ifdef DEBUG_LEAKING_SCALARS
5526 #   define SV_LOG_SERIAL_FMT        " [%lu]"
5527 #   define _SV_LOG_SERIAL_ARG(sv)   , (unsigned long) (sv)->sv_debug_serial
5528 # else
5529 #   define SV_LOG_SERIAL_FMT
5530 #   define _SV_LOG_SERIAL_ARG(sv)
5531 # endif
5532
5533 static void
5534 S_mem_log_common(enum mem_log_type mlt, const UV n,
5535                  const UV typesize, const char *type_name, const SV *sv,
5536                  Malloc_t oldalloc, Malloc_t newalloc,
5537                  const char *filename, const int linenumber,
5538                  const char *funcname)
5539 {
5540     const char *pmlenv;
5541
5542     PERL_ARGS_ASSERT_MEM_LOG_COMMON;
5543
5544     pmlenv = PerlEnv_getenv("PERL_MEM_LOG");
5545     if (!pmlenv)
5546         return;
5547     if (mlt < MLT_NEW_SV ? strchr(pmlenv,'m') : strchr(pmlenv,'s'))
5548     {
5549         /* We can't use SVs or PerlIO for obvious reasons,
5550          * so we'll use stdio and low-level IO instead. */
5551         char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE];
5552
5553 #   ifdef HAS_GETTIMEOFDAY
5554 #     define MEM_LOG_TIME_FMT   "%10d.%06d: "
5555 #     define MEM_LOG_TIME_ARG   (int)tv.tv_sec, (int)tv.tv_usec
5556         struct timeval tv;
5557         gettimeofday(&tv, 0);
5558 #   else
5559 #     define MEM_LOG_TIME_FMT   "%10d: "
5560 #     define MEM_LOG_TIME_ARG   (int)when
5561         Time_t when;
5562         (void)time(&when);
5563 #   endif
5564         /* If there are other OS specific ways of hires time than
5565          * gettimeofday() (see ext/Time-HiRes), the easiest way is
5566          * probably that they would be used to fill in the struct
5567          * timeval. */
5568         {
5569             STRLEN len;
5570             int fd = atoi(pmlenv);
5571             if (!fd)
5572                 fd = PERL_MEM_LOG_FD;
5573
5574             if (strchr(pmlenv, 't')) {
5575                 len = my_snprintf(buf, sizeof(buf),
5576                                 MEM_LOG_TIME_FMT, MEM_LOG_TIME_ARG);
5577                 PerlLIO_write(fd, buf, len);
5578             }
5579             switch (mlt) {
5580             case MLT_ALLOC:
5581                 len = my_snprintf(buf, sizeof(buf),
5582                         "alloc: %s:%d:%s: %"IVdf" %"UVuf
5583                         " %s = %"IVdf": %"UVxf"\n",
5584                         filename, linenumber, funcname, n, typesize,
5585                         type_name, n * typesize, PTR2UV(newalloc));
5586                 break;
5587             case MLT_REALLOC:
5588                 len = my_snprintf(buf, sizeof(buf),
5589                         "realloc: %s:%d:%s: %"IVdf" %"UVuf
5590                         " %s = %"IVdf": %"UVxf" -> %"UVxf"\n",
5591                         filename, linenumber, funcname, n, typesize,
5592                         type_name, n * typesize, PTR2UV(oldalloc),
5593                         PTR2UV(newalloc));
5594                 break;
5595             case MLT_FREE:
5596                 len = my_snprintf(buf, sizeof(buf),
5597                         "free: %s:%d:%s: %"UVxf"\n",
5598                         filename, linenumber, funcname,
5599                         PTR2UV(oldalloc));
5600                 break;
5601             case MLT_NEW_SV:
5602             case MLT_DEL_SV:
5603                 len = my_snprintf(buf, sizeof(buf),
5604                         "%s_SV: %s:%d:%s: %"UVxf SV_LOG_SERIAL_FMT "\n",
5605                         mlt == MLT_NEW_SV ? "new" : "del",
5606                         filename, linenumber, funcname,
5607                         PTR2UV(sv) _SV_LOG_SERIAL_ARG(sv));
5608                 break;
5609             default:
5610                 len = 0;
5611             }
5612             PerlLIO_write(fd, buf, len);
5613         }
5614     }
5615 }
5616 #endif /* !PERL_MEM_LOG_NOIMPL */
5617
5618 #ifndef PERL_MEM_LOG_NOIMPL
5619 # define \
5620     mem_log_common_if(alty, num, tysz, tynm, sv, oal, nal, flnm, ln, fnnm) \
5621     mem_log_common   (alty, num, tysz, tynm, sv, oal, nal, flnm, ln, fnnm)
5622 #else
5623 /* this is suboptimal, but bug compatible.  User is providing their
5624    own implementation, but is getting these functions anyway, and they
5625    do nothing. But _NOIMPL users should be able to cope or fix */
5626 # define \
5627     mem_log_common_if(alty, num, tysz, tynm, u, oal, nal, flnm, ln, fnnm) \
5628     /* mem_log_common_if_PERL_MEM_LOG_NOIMPL */
5629 #endif
5630
5631 Malloc_t
5632 Perl_mem_log_alloc(const UV n, const UV typesize, const char *type_name,
5633                    Malloc_t newalloc,
5634                    const char *filename, const int linenumber,
5635                    const char *funcname)
5636 {
5637     mem_log_common_if(MLT_ALLOC, n, typesize, type_name,
5638                       NULL, NULL, newalloc,
5639                       filename, linenumber, funcname);
5640     return newalloc;
5641 }
5642
5643 Malloc_t
5644 Perl_mem_log_realloc(const UV n, const UV typesize, const char *type_name,
5645                      Malloc_t oldalloc, Malloc_t newalloc,
5646                      const char *filename, const int linenumber,
5647                      const char *funcname)
5648 {
5649     mem_log_common_if(MLT_REALLOC, n, typesize, type_name,
5650                       NULL, oldalloc, newalloc,
5651                       filename, linenumber, funcname);
5652     return newalloc;
5653 }
5654
5655 Malloc_t
5656 Perl_mem_log_free(Malloc_t oldalloc,
5657                   const char *filename, const int linenumber,
5658                   const char *funcname)
5659 {
5660     mem_log_common_if(MLT_FREE, 0, 0, "", NULL, oldalloc, NULL,
5661                       filename, linenumber, funcname);
5662     return oldalloc;
5663 }
5664
5665 void
5666 Perl_mem_log_new_sv(const SV *sv,
5667                     const char *filename, const int linenumber,
5668                     const char *funcname)
5669 {
5670     mem_log_common_if(MLT_NEW_SV, 0, 0, "", sv, NULL, NULL,
5671                       filename, linenumber, funcname);
5672 }
5673
5674 void
5675 Perl_mem_log_del_sv(const SV *sv,
5676                     const char *filename, const int linenumber,
5677                     const char *funcname)
5678 {
5679     mem_log_common_if(MLT_DEL_SV, 0, 0, "", sv, NULL, NULL,
5680                       filename, linenumber, funcname);
5681 }
5682
5683 #endif /* PERL_MEM_LOG */
5684
5685 /*
5686 =for apidoc my_sprintf
5687
5688 The C library C<sprintf>, wrapped if necessary, to ensure that it will return
5689 the length of the string written to the buffer. Only rare pre-ANSI systems
5690 need the wrapper function - usually this is a direct call to C<sprintf>.
5691
5692 =cut
5693 */
5694 #ifndef SPRINTF_RETURNS_STRLEN
5695 int
5696 Perl_my_sprintf(char *buffer, const char* pat, ...)
5697 {
5698     va_list args;
5699     PERL_ARGS_ASSERT_MY_SPRINTF;
5700     va_start(args, pat);
5701     vsprintf(buffer, pat, args);
5702     va_end(args);
5703     return strlen(buffer);
5704 }
5705 #endif
5706
5707 /*
5708 =for apidoc my_snprintf
5709
5710 The C library C<snprintf> functionality, if available and
5711 standards-compliant (uses C<vsnprintf>, actually).  However, if the
5712 C<vsnprintf> is not available, will unfortunately use the unsafe
5713 C<vsprintf> which can overrun the buffer (there is an overrun check,
5714 but that may be too late).  Consider using C<sv_vcatpvf> instead, or
5715 getting C<vsnprintf>.
5716
5717 =cut
5718 */
5719 int
5720 Perl_my_snprintf(char *buffer, const Size_t len, const char *format, ...)
5721 {
5722     int retval;
5723     va_list ap;
5724     PERL_ARGS_ASSERT_MY_SNPRINTF;
5725     va_start(ap, format);
5726 #ifdef HAS_VSNPRINTF
5727     retval = vsnprintf(buffer, len, format, ap);
5728 #else
5729     retval = vsprintf(buffer, format, ap);
5730 #endif
5731     va_end(ap);
5732     /* vsprintf() shows failure with < 0 */
5733     if (retval < 0
5734 #ifdef HAS_VSNPRINTF
5735     /* vsnprintf() shows failure with >= len */
5736         ||
5737         (len > 0 && (Size_t)retval >= len)
5738 #endif
5739     )
5740         Perl_croak_nocontext("panic: my_snprintf buffer overflow");
5741     return retval;
5742 }
5743
5744 /*
5745 =for apidoc my_vsnprintf
5746
5747 The C library C<vsnprintf> if available and standards-compliant.
5748 However, if if the C<vsnprintf> is not available, will unfortunately
5749 use the unsafe C<vsprintf> which can overrun the buffer (there is an
5750 overrun check, but that may be too late).  Consider using
5751 C<sv_vcatpvf> instead, or getting C<vsnprintf>.
5752
5753 =cut
5754 */
5755 int
5756 Perl_my_vsnprintf(char *buffer, const Size_t len, const char *format, va_list ap)
5757 {
5758     int retval;
5759 #ifdef NEED_VA_COPY
5760     va_list apc;
5761
5762     PERL_ARGS_ASSERT_MY_VSNPRINTF;
5763
5764     Perl_va_copy(ap, apc);
5765 # ifdef HAS_VSNPRINTF
5766     retval = vsnprintf(buffer, len, format, apc);
5767 # else
5768     retval = vsprintf(buffer, format, apc);
5769 # endif
5770 #else
5771 # ifdef HAS_VSNPRINTF
5772     retval = vsnprintf(buffer, len, format, ap);
5773 # else
5774     retval = vsprintf(buffer, format, ap);
5775 # endif
5776 #endif /* #ifdef NEED_VA_COPY */
5777     /* vsprintf() shows failure with < 0 */
5778     if (retval < 0
5779 #ifdef HAS_VSNPRINTF
5780     /* vsnprintf() shows failure with >= len */
5781         ||
5782         (len > 0 && (Size_t)retval >= len)
5783 #endif
5784     )
5785         Perl_croak_nocontext("panic: my_vsnprintf buffer overflow");
5786     return retval;
5787 }
5788
5789 void
5790 Perl_my_clearenv(pTHX)
5791 {
5792     dVAR;
5793 #if ! defined(PERL_MICRO)
5794 #  if defined(PERL_IMPLICIT_SYS) || defined(WIN32)
5795     PerlEnv_clearenv();
5796 #  else /* ! (PERL_IMPLICIT_SYS || WIN32) */
5797 #    if defined(USE_ENVIRON_ARRAY)
5798 #      if defined(USE_ITHREADS)
5799     /* only the parent thread can clobber the process environment */
5800     if (PL_curinterp == aTHX)
5801 #      endif /* USE_ITHREADS */
5802     {
5803 #      if ! defined(PERL_USE_SAFE_PUTENV)
5804     if ( !PL_use_safe_putenv) {
5805       I32 i;
5806       if (environ == PL_origenviron)
5807         environ = (char**)safesysmalloc(sizeof(char*));
5808       else
5809         for (i = 0; environ[i]; i++)
5810           (void)safesysfree(environ[i]);
5811     }
5812     environ[0] = NULL;
5813 #      else /* PERL_USE_SAFE_PUTENV */
5814 #        if defined(HAS_CLEARENV)
5815     (void)clearenv();
5816 #        elif defined(HAS_UNSETENV)
5817     int bsiz = 80; /* Most envvar names will be shorter than this. */
5818     char *buf = (char*)safesysmalloc(bsiz);
5819     while (*environ != NULL) {
5820       char *e = strchr(*environ, '=');
5821       int l = e ? e - *environ : (int)strlen(*environ);
5822       if (bsiz < l + 1) {
5823         (void)safesysfree(buf);
5824         bsiz = l + 1; /* + 1 for the \0. */
5825         buf = (char*)safesysmalloc(bsiz);
5826       }
5827       memcpy(buf, *environ, l);
5828       buf[l] = '\0';
5829       (void)unsetenv(buf);
5830     }
5831     (void)safesysfree(buf);
5832 #        else /* ! HAS_CLEARENV && ! HAS_UNSETENV */
5833     /* Just null environ and accept the leakage. */
5834     *environ = NULL;
5835 #        endif /* HAS_CLEARENV || HAS_UNSETENV */
5836 #      endif /* ! PERL_USE_SAFE_PUTENV */
5837     }
5838 #    endif /* USE_ENVIRON_ARRAY */
5839 #  endif /* PERL_IMPLICIT_SYS || WIN32 */
5840 #endif /* PERL_MICRO */
5841 }
5842
5843 #ifdef PERL_IMPLICIT_CONTEXT
5844
5845 /* Implements the MY_CXT_INIT macro. The first time a module is loaded,
5846 the global PL_my_cxt_index is incremented, and that value is assigned to
5847 that module's static my_cxt_index (who's address is passed as an arg).
5848 Then, for each interpreter this function is called for, it makes sure a
5849 void* slot is available to hang the static data off, by allocating or
5850 extending the interpreter's PL_my_cxt_list array */
5851
5852 #ifndef PERL_GLOBAL_STRUCT_PRIVATE
5853 void *
5854 Perl_my_cxt_init(pTHX_ int *index, size_t size)
5855 {
5856     dVAR;
5857     void *p;
5858     PERL_ARGS_ASSERT_MY_CXT_INIT;
5859     if (*index == -1) {
5860         /* this module hasn't been allocated an index yet */
5861 #if defined(USE_ITHREADS)
5862         MUTEX_LOCK(&PL_my_ctx_mutex);
5863 #endif
5864         *index = PL_my_cxt_index++;
5865 #if defined(USE_ITHREADS)
5866         MUTEX_UNLOCK(&PL_my_ctx_mutex);
5867 #endif
5868     }
5869
5870     /* make sure the array is big enough */
5871     if (PL_my_cxt_size <= *index) {
5872         if (PL_my_cxt_size) {
5873             while (PL_my_cxt_size <= *index)
5874                 PL_my_cxt_size *= 2;
5875             Renew(PL_my_cxt_list, PL_my_cxt_size, void *);
5876         }
5877         else {
5878             PL_my_cxt_size = 16;
5879             Newx(PL_my_cxt_list, PL_my_cxt_size, void *);
5880         }
5881     }
5882     /* newSV() allocates one more than needed */
5883     p = (void*)SvPVX(newSV(size-1));
5884     PL_my_cxt_list[*index] = p;
5885     Zero(p, size, char);
5886     return p;
5887 }
5888
5889 #else /* #ifndef PERL_GLOBAL_STRUCT_PRIVATE */
5890
5891 int
5892 Perl_my_cxt_index(pTHX_ const char *my_cxt_key)
5893 {
5894     dVAR;
5895     int index;
5896
5897     PERL_ARGS_ASSERT_MY_CXT_INDEX;
5898
5899     for (index = 0; index < PL_my_cxt_index; index++) {
5900         const char *key = PL_my_cxt_keys[index];
5901         /* try direct pointer compare first - there are chances to success,
5902          * and it's much faster.
5903          */
5904         if ((key == my_cxt_key) || strEQ(key, my_cxt_key))
5905             return index;
5906     }
5907     return -1;
5908 }
5909
5910 void *
5911 Perl_my_cxt_init(pTHX_ const char *my_cxt_key, size_t size)
5912 {
5913     dVAR;
5914     void *p;
5915     int index;
5916
5917     PERL_ARGS_ASSERT_MY_CXT_INIT;
5918
5919     index = Perl_my_cxt_index(aTHX_ my_cxt_key);
5920     if (index == -1) {
5921         /* this module hasn't been allocated an index yet */
5922 #if defined(USE_ITHREADS)
5923         MUTEX_LOCK(&PL_my_ctx_mutex);
5924 #endif
5925         index = PL_my_cxt_index++;
5926 #if defined(USE_ITHREADS)
5927         MUTEX_UNLOCK(&PL_my_ctx_mutex);
5928 #endif
5929     }
5930
5931     /* make sure the array is big enough */
5932     if (PL_my_cxt_size <= index) {
5933         int old_size = PL_my_cxt_size;
5934         int i;
5935         if (PL_my_cxt_size) {
5936             while (PL_my_cxt_size <= index)
5937                 PL_my_cxt_size *= 2;
5938             Renew(PL_my_cxt_list, PL_my_cxt_size, void *);
5939             Renew(PL_my_cxt_keys, PL_my_cxt_size, const char *);
5940         }
5941         else {
5942             PL_my_cxt_size = 16;
5943             Newx(PL_my_cxt_list, PL_my_cxt_size, void *);
5944             Newx(PL_my_cxt_keys, PL_my_cxt_size, const char *);
5945         }
5946         for (i = old_size; i < PL_my_cxt_size; i++) {
5947             PL_my_cxt_keys[i] = 0;
5948             PL_my_cxt_list[i] = 0;
5949         }
5950     }
5951     PL_my_cxt_keys[index] = my_cxt_key;
5952     /* newSV() allocates one more than needed */
5953     p = (void*)SvPVX(newSV(size-1));
5954     PL_my_cxt_list[index] = p;
5955     Zero(p, size, char);
5956     return p;
5957 }
5958 #endif /* #ifndef PERL_GLOBAL_STRUCT_PRIVATE */
5959 #endif /* PERL_IMPLICIT_CONTEXT */
5960
5961 void
5962 Perl_xs_version_bootcheck(pTHX_ U32 items, U32 ax, const char *xs_p,
5963                           STRLEN xs_len)
5964 {
5965     SV *sv;
5966     const char *vn = NULL;
5967     SV *const module = PL_stack_base[ax];
5968
5969     PERL_ARGS_ASSERT_XS_VERSION_BOOTCHECK;
5970
5971     if (items >= 2)      /* version supplied as bootstrap arg */
5972         sv = PL_stack_base[ax + 1];
5973     else {
5974         /* XXX GV_ADDWARN */
5975         vn = "XS_VERSION";
5976         sv = get_sv(Perl_form(aTHX_ "%"SVf"::%s", module, vn), 0);
5977         if (!sv || !SvOK(sv)) {
5978             vn = "VERSION";
5979             sv = get_sv(Perl_form(aTHX_ "%"SVf"::%s", module, vn), 0);
5980         }
5981     }
5982     if (sv) {
5983         SV *xssv = Perl_newSVpvn_flags(aTHX_ xs_p, xs_len, SVs_TEMP);
5984         SV *pmsv = sv_isobject(sv) && sv_derived_from(sv, "version")
5985             ? sv : sv_2mortal(new_version(sv));
5986         xssv = upg_version(xssv, 0);
5987         if ( vcmp(pmsv,xssv) ) {
5988             SV *string = vstringify(xssv);
5989             SV *xpt = Perl_newSVpvf(aTHX_ "%"SVf" object version %"SVf
5990                                     " does not match ", module, string);
5991
5992             SvREFCNT_dec(string);
5993             string = vstringify(pmsv);
5994
5995             if (vn) {
5996                 Perl_sv_catpvf(aTHX_ xpt, "$%"SVf"::%s %"SVf, module, vn,
5997                                string);
5998             } else {
5999                 Perl_sv_catpvf(aTHX_ xpt, "bootstrap parameter %"SVf, string);
6000             }
6001             SvREFCNT_dec(string);
6002
6003             Perl_sv_2mortal(aTHX_ xpt);
6004             Perl_croak_sv(aTHX_ xpt);
6005         }
6006     }
6007 }
6008
6009 void
6010 Perl_xs_apiversion_bootcheck(pTHX_ SV *module, const char *api_p,
6011                              STRLEN api_len)
6012 {
6013     SV *xpt = NULL;
6014     SV *compver = Perl_newSVpvn_flags(aTHX_ api_p, api_len, SVs_TEMP);
6015     SV *runver;
6016
6017     PERL_ARGS_ASSERT_XS_APIVERSION_BOOTCHECK;
6018
6019     /* This might croak  */
6020     compver = upg_version(compver, 0);
6021     /* This should never croak */
6022     runver = new_version(PL_apiversion);
6023     if (vcmp(compver, runver)) {
6024         SV *compver_string = vstringify(compver);
6025         SV *runver_string = vstringify(runver);
6026         xpt = Perl_newSVpvf(aTHX_ "Perl API version %"SVf
6027                             " of %"SVf" does not match %"SVf,
6028                             compver_string, module, runver_string);
6029         Perl_sv_2mortal(aTHX_ xpt);
6030
6031         SvREFCNT_dec(compver_string);
6032         SvREFCNT_dec(runver_string);
6033     }
6034     SvREFCNT_dec(runver);
6035     if (xpt)
6036         Perl_croak_sv(aTHX_ xpt);
6037 }
6038
6039 /*
6040 =for apidoc my_strlcat
6041
6042 The C library C<strlcat> if available, or a Perl implementation of it.
6043 This operates on C NUL-terminated strings.
6044
6045 C<my_strlcat()> appends string C<src> to the end of C<dst>.  It will append at
6046 most S<C<size - strlen(dst) - 1>> characters.  It will then NUL-terminate,
6047 unless C<size> is 0 or the original C<dst> string was longer than C<size> (in
6048 practice this should not happen as it means that either C<size> is incorrect or
6049 that C<dst> is not a proper NUL-terminated string).
6050
6051 Note that C<size> is the full size of the destination buffer and
6052 the result is guaranteed to be NUL-terminated if there is room.  Note that room
6053 for the NUL should be included in C<size>.
6054
6055 =cut
6056
6057 Description stolen from http://www.openbsd.org/cgi-bin/man.cgi?query=strlcat
6058 */
6059 #ifndef HAS_STRLCAT
6060 Size_t
6061 Perl_my_strlcat(char *dst, const char *src, Size_t size)
6062 {
6063     Size_t used, length, copy;
6064
6065     used = strlen(dst);
6066     length = strlen(src);
6067     if (size > 0 && used < size - 1) {
6068         copy = (length >= size - used) ? size - used - 1 : length;
6069         memcpy(dst + used, src, copy);
6070         dst[used + copy] = '\0';
6071     }
6072     return used + length;
6073 }
6074 #endif
6075
6076
6077 /*
6078 =for apidoc my_strlcpy
6079
6080 The C library C<strlcpy> if available, or a Perl implementation of it.
6081 This operates on C NUL-terminated strings.
6082
6083 C<my_strlcpy()> copies up to S<C<size - 1>> characters from the string C<src>
6084 to C<dst>, NUL-terminating the result if C<size> is not 0.
6085
6086 =cut
6087
6088 Description stolen from http://www.openbsd.org/cgi-bin/man.cgi?query=strlcpy
6089 */
6090 #ifndef HAS_STRLCPY
6091 Size_t
6092 Perl_my_strlcpy(char *dst, const char *src, Size_t size)
6093 {
6094     Size_t length, copy;
6095
6096     length = strlen(src);
6097     if (size > 0) {
6098         copy = (length >= size) ? size - 1 : length;
6099         memcpy(dst, src, copy);
6100         dst[copy] = '\0';
6101     }
6102     return length;
6103 }
6104 #endif
6105
6106 #if defined(_MSC_VER) && (_MSC_VER >= 1300) && (_MSC_VER < 1400) && (WINVER < 0x0500)
6107 /* VC7 or 7.1, building with pre-VC7 runtime libraries. */
6108 long _ftol( double ); /* Defined by VC6 C libs. */
6109 long _ftol2( double dblSource ) { return _ftol( dblSource ); }
6110 #endif
6111
6112 PERL_STATIC_INLINE bool
6113 S_gv_has_usable_name(pTHX_ GV *gv)
6114 {
6115     GV **gvp;
6116     return GvSTASH(gv)
6117         && HvENAME(GvSTASH(gv))
6118         && (gvp = (GV **)hv_fetch(
6119                         GvSTASH(gv), GvNAME(gv),
6120                         GvNAMEUTF8(gv) ? -GvNAMELEN(gv) : GvNAMELEN(gv), 0
6121            ))
6122         && *gvp == gv;
6123 }
6124
6125 void
6126 Perl_get_db_sub(pTHX_ SV **svp, CV *cv)
6127 {
6128     dVAR;
6129     SV * const dbsv = GvSVn(PL_DBsub);
6130     const bool save_taint = TAINT_get;
6131
6132     /* When we are called from pp_goto (svp is null),
6133      * we do not care about using dbsv to call CV;
6134      * it's for informational purposes only.
6135      */
6136
6137     PERL_ARGS_ASSERT_GET_DB_SUB;
6138
6139     TAINT_set(FALSE);
6140     save_item(dbsv);
6141     if (!PERLDB_SUB_NN) {
6142         GV *gv = CvGV(cv);
6143
6144         if (!svp) {
6145             gv_efullname3(dbsv, gv, NULL);
6146         }
6147         else if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
6148              || strEQ(GvNAME(gv), "END")
6149              || ( /* Could be imported, and old sub redefined. */
6150                  (GvCV(gv) != cv || !S_gv_has_usable_name(aTHX_ gv))
6151                  &&
6152                  !( (SvTYPE(*svp) == SVt_PVGV)
6153                     && (GvCV((const GV *)*svp) == cv)
6154                     /* Use GV from the stack as a fallback. */
6155                     && S_gv_has_usable_name(aTHX_ gv = (GV *)*svp)
6156                   )
6157                 )
6158         ) {
6159             /* GV is potentially non-unique, or contain different CV. */
6160             SV * const tmp = newRV(MUTABLE_SV(cv));
6161             sv_setsv(dbsv, tmp);
6162             SvREFCNT_dec(tmp);
6163         }
6164         else {
6165             sv_sethek(dbsv, HvENAME_HEK(GvSTASH(gv)));
6166             sv_catpvs(dbsv, "::");
6167             sv_catpvn_flags(
6168               dbsv, GvNAME(gv), GvNAMELEN(gv),
6169               GvNAMEUTF8(gv) ? SV_CATUTF8 : SV_CATBYTES
6170             );
6171         }
6172     }
6173     else {
6174         const int type = SvTYPE(dbsv);
6175         if (type < SVt_PVIV && type != SVt_IV)
6176             sv_upgrade(dbsv, SVt_PVIV);
6177         (void)SvIOK_on(dbsv);
6178         SvIV_set(dbsv, PTR2IV(cv));     /* Do it the quickest way  */
6179     }
6180     TAINT_IF(save_taint);
6181 #ifdef NO_TAINT_SUPPORT
6182     PERL_UNUSED_VAR(save_taint);
6183 #endif
6184 }
6185
6186 int
6187 Perl_my_dirfd(pTHX_ DIR * dir) {
6188
6189     /* Most dirfd implementations have problems when passed NULL. */
6190     if(!dir)
6191         return -1;
6192 #ifdef HAS_DIRFD
6193     return dirfd(dir);
6194 #elif defined(HAS_DIR_DD_FD)
6195     return dir->dd_fd;
6196 #else
6197     Perl_die(aTHX_ PL_no_func, "dirfd");
6198     assert(0); /* NOT REACHED */
6199     return 0;
6200 #endif
6201 }
6202
6203 REGEXP *
6204 Perl_get_re_arg(pTHX_ SV *sv) {
6205
6206     if (sv) {
6207         if (SvMAGICAL(sv))
6208             mg_get(sv);
6209         if (SvROK(sv))
6210             sv = MUTABLE_SV(SvRV(sv));
6211         if (SvTYPE(sv) == SVt_REGEXP)
6212             return (REGEXP*) sv;
6213     }
6214
6215     return NULL;
6216 }
6217
6218 /*
6219  * This code is derived from drand48() implementation from FreeBSD,
6220  * found in lib/libc/gen/_rand48.c.
6221  *
6222  * The U64 implementation is original, based on the POSIX
6223  * specification for drand48().
6224  */
6225
6226 /*
6227 * Copyright (c) 1993 Martin Birgmeier
6228 * All rights reserved.
6229 *
6230 * You may redistribute unmodified or modified versions of this source
6231 * code provided that the above copyright notice and this and the
6232 * following conditions are retained.
6233 *
6234 * This software is provided ``as is'', and comes with no warranties
6235 * of any kind. I shall in no event be liable for anything that happens
6236 * to anyone/anything when using this software.
6237 */
6238
6239 #define FREEBSD_DRAND48_SEED_0   (0x330e)
6240
6241 #ifdef PERL_DRAND48_QUAD
6242
6243 #define DRAND48_MULT 0x5deece66d
6244 #define DRAND48_ADD  0xb
6245 #define DRAND48_MASK 0xffffffffffff
6246
6247 #else
6248
6249 #define FREEBSD_DRAND48_SEED_1   (0xabcd)
6250 #define FREEBSD_DRAND48_SEED_2   (0x1234)
6251 #define FREEBSD_DRAND48_MULT_0   (0xe66d)
6252 #define FREEBSD_DRAND48_MULT_1   (0xdeec)
6253 #define FREEBSD_DRAND48_MULT_2   (0x0005)
6254 #define FREEBSD_DRAND48_ADD      (0x000b)
6255
6256 const unsigned short _rand48_mult[3] = {
6257                 FREEBSD_DRAND48_MULT_0,
6258                 FREEBSD_DRAND48_MULT_1,
6259                 FREEBSD_DRAND48_MULT_2
6260 };
6261 const unsigned short _rand48_add = FREEBSD_DRAND48_ADD;
6262
6263 #endif
6264
6265 void
6266 Perl_drand48_init_r(perl_drand48_t *random_state, U32 seed)
6267 {
6268     PERL_ARGS_ASSERT_DRAND48_INIT_R;
6269
6270 #ifdef PERL_DRAND48_QUAD
6271     *random_state = FREEBSD_DRAND48_SEED_0 + ((U64TYPE)seed << 16);
6272 #else
6273     random_state->seed[0] = FREEBSD_DRAND48_SEED_0;
6274     random_state->seed[1] = (U16) seed;
6275     random_state->seed[2] = (U16) (seed >> 16);
6276 #endif
6277 }
6278
6279 double
6280 Perl_drand48_r(perl_drand48_t *random_state)
6281 {
6282     PERL_ARGS_ASSERT_DRAND48_R;
6283
6284 #ifdef PERL_DRAND48_QUAD
6285     *random_state = (*random_state * DRAND48_MULT + DRAND48_ADD)
6286         & DRAND48_MASK;
6287
6288     return ldexp(*random_state, -48);
6289 #else
6290     {
6291     U32 accu;
6292     U16 temp[2];
6293
6294     accu = (U32) _rand48_mult[0] * (U32) random_state->seed[0]
6295          + (U32) _rand48_add;
6296     temp[0] = (U16) accu;        /* lower 16 bits */
6297     accu >>= sizeof(U16) * 8;
6298     accu += (U32) _rand48_mult[0] * (U32) random_state->seed[1]
6299           + (U32) _rand48_mult[1] * (U32) random_state->seed[0];
6300     temp[1] = (U16) accu;        /* middle 16 bits */
6301     accu >>= sizeof(U16) * 8;
6302     accu += _rand48_mult[0] * random_state->seed[2]
6303           + _rand48_mult[1] * random_state->seed[1]
6304           + _rand48_mult[2] * random_state->seed[0];
6305     random_state->seed[0] = temp[0];
6306     random_state->seed[1] = temp[1];
6307     random_state->seed[2] = (U16) accu;
6308
6309     return ldexp((double) random_state->seed[0], -48) +
6310            ldexp((double) random_state->seed[1], -32) +
6311            ldexp((double) random_state->seed[2], -16);
6312     }
6313 #endif
6314 }
6315
6316
6317 /*
6318  * Local variables:
6319  * c-indentation-style: bsd
6320  * c-basic-offset: 4
6321  * indent-tabs-mode: nil
6322  * End:
6323  *
6324  * ex: set ts=8 sts=4 sw=4 et:
6325  */