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