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