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