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