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 char *
3939 Perl_grok_bslash_o(pTHX_ const char *s, UV *uv, STRLEN *len, const bool output_warning)
3940 {
3941
3942 /*  Documentation to be supplied when interface nailed down finally
3943  *  This returns NULL on success, otherwise a pointer to an internal constant
3944  *  error message.  On input:
3945  *      s   points to a string that begins with o, and the previous character was
3946  *          a backslash.
3947  *      uv  points to a UV that will hold the output value
3948  *      len will point to the next character in the string past the end of this
3949  *          construct
3950  *      output_warning says whether to output any warning messages, or suppress
3951  *          them
3952  */
3953     const char* e;
3954     STRLEN numbers_len;
3955     I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
3956                 | PERL_SCAN_DISALLOW_PREFIX
3957                 /* XXX Until the message is improved in grok_oct, handle errors
3958                  * ourselves */
3959                 | PERL_SCAN_SILENT_ILLDIGIT;
3960
3961     PERL_ARGS_ASSERT_GROK_BSLASH_O;
3962
3963
3964     assert(*s == 'o');
3965     s++;
3966
3967     if (*s != '{') {
3968         *len = 1;       /* Move past the o */
3969         return "Missing braces on \\o{}";
3970     }
3971
3972     e = strchr(s, '}');
3973     if (!e) {
3974         *len = 2;       /* Move past the o{ */
3975         return "Missing right brace on \\o{";
3976     }
3977
3978     /* Return past the '}' no matter what is inside the braces */
3979     *len = e - s + 2;   /* 2 = 1 for the o + 1 for the '}' */
3980
3981     s++;    /* Point to first digit */
3982
3983     numbers_len = e - s;
3984     if (numbers_len == 0) {
3985         return "Number with no digits";
3986     }
3987
3988     *uv = NATIVE_TO_UNI(grok_oct(s, &numbers_len, &flags, NULL));
3989     /* Note that if has non-octal, will ignore everything starting with that up
3990      * to the '}' */
3991
3992     if (output_warning && numbers_len != (STRLEN) (e - s)) {
3993         Perl_ck_warner(aTHX_ packWARN(WARN_DIGIT),
3994         /* diag_listed_as: Non-octal character '%c'.  Resolved as "%s" */
3995                        "Non-octal character '%c'.  Resolved as \"\\o{%.*s}\"",
3996                        *(s + numbers_len),
3997                        (int) numbers_len,
3998                        s);
3999     }
4000
4001     return NULL;
4002 }
4003
4004 /* To workaround core dumps from the uninitialised tm_zone we get the
4005  * system to give us a reasonable struct to copy.  This fix means that
4006  * strftime uses the tm_zone and tm_gmtoff values returned by
4007  * localtime(time()). That should give the desired result most of the
4008  * time. But probably not always!
4009  *
4010  * This does not address tzname aspects of NETaa14816.
4011  *
4012  */
4013
4014 #ifdef HAS_GNULIBC
4015 # ifndef STRUCT_TM_HASZONE
4016 #    define STRUCT_TM_HASZONE
4017 # endif
4018 #endif
4019
4020 #ifdef STRUCT_TM_HASZONE /* Backward compat */
4021 # ifndef HAS_TM_TM_ZONE
4022 #    define HAS_TM_TM_ZONE
4023 # endif
4024 #endif
4025
4026 void
4027 Perl_init_tm(pTHX_ struct tm *ptm)      /* see mktime, strftime and asctime */
4028 {
4029 #ifdef HAS_TM_TM_ZONE
4030     Time_t now;
4031     const struct tm* my_tm;
4032     PERL_ARGS_ASSERT_INIT_TM;
4033     (void)time(&now);
4034     my_tm = localtime(&now);
4035     if (my_tm)
4036         Copy(my_tm, ptm, 1, struct tm);
4037 #else
4038     PERL_ARGS_ASSERT_INIT_TM;
4039     PERL_UNUSED_ARG(ptm);
4040 #endif
4041 }
4042
4043 /*
4044  * mini_mktime - normalise struct tm values without the localtime()
4045  * semantics (and overhead) of mktime().
4046  */
4047 void
4048 Perl_mini_mktime(pTHX_ struct tm *ptm)
4049 {
4050     int yearday;
4051     int secs;
4052     int month, mday, year, jday;
4053     int odd_cent, odd_year;
4054     PERL_UNUSED_CONTEXT;
4055
4056     PERL_ARGS_ASSERT_MINI_MKTIME;
4057
4058 #define DAYS_PER_YEAR   365
4059 #define DAYS_PER_QYEAR  (4*DAYS_PER_YEAR+1)
4060 #define DAYS_PER_CENT   (25*DAYS_PER_QYEAR-1)
4061 #define DAYS_PER_QCENT  (4*DAYS_PER_CENT+1)
4062 #define SECS_PER_HOUR   (60*60)
4063 #define SECS_PER_DAY    (24*SECS_PER_HOUR)
4064 /* parentheses deliberately absent on these two, otherwise they don't work */
4065 #define MONTH_TO_DAYS   153/5
4066 #define DAYS_TO_MONTH   5/153
4067 /* offset to bias by March (month 4) 1st between month/mday & year finding */
4068 #define YEAR_ADJUST     (4*MONTH_TO_DAYS+1)
4069 /* as used here, the algorithm leaves Sunday as day 1 unless we adjust it */
4070 #define WEEKDAY_BIAS    6       /* (1+6)%7 makes Sunday 0 again */
4071
4072 /*
4073  * Year/day algorithm notes:
4074  *
4075  * With a suitable offset for numeric value of the month, one can find
4076  * an offset into the year by considering months to have 30.6 (153/5) days,
4077  * using integer arithmetic (i.e., with truncation).  To avoid too much
4078  * messing about with leap days, we consider January and February to be
4079  * the 13th and 14th month of the previous year.  After that transformation,
4080  * we need the month index we use to be high by 1 from 'normal human' usage,
4081  * so the month index values we use run from 4 through 15.
4082  *
4083  * Given that, and the rules for the Gregorian calendar (leap years are those
4084  * divisible by 4 unless also divisible by 100, when they must be divisible
4085  * by 400 instead), we can simply calculate the number of days since some
4086  * arbitrary 'beginning of time' by futzing with the (adjusted) year number,
4087  * the days we derive from our month index, and adding in the day of the
4088  * month.  The value used here is not adjusted for the actual origin which
4089  * it normally would use (1 January A.D. 1), since we're not exposing it.
4090  * We're only building the value so we can turn around and get the
4091  * normalised values for the year, month, day-of-month, and day-of-year.
4092  *
4093  * For going backward, we need to bias the value we're using so that we find
4094  * the right year value.  (Basically, we don't want the contribution of
4095  * March 1st to the number to apply while deriving the year).  Having done
4096  * that, we 'count up' the contribution to the year number by accounting for
4097  * full quadracenturies (400-year periods) with their extra leap days, plus
4098  * the contribution from full centuries (to avoid counting in the lost leap
4099  * days), plus the contribution from full quad-years (to count in the normal
4100  * leap days), plus the leftover contribution from any non-leap years.
4101  * At this point, if we were working with an actual leap day, we'll have 0
4102  * days left over.  This is also true for March 1st, however.  So, we have
4103  * to special-case that result, and (earlier) keep track of the 'odd'
4104  * century and year contributions.  If we got 4 extra centuries in a qcent,
4105  * or 4 extra years in a qyear, then it's a leap day and we call it 29 Feb.
4106  * Otherwise, we add back in the earlier bias we removed (the 123 from
4107  * figuring in March 1st), find the month index (integer division by 30.6),
4108  * and the remainder is the day-of-month.  We then have to convert back to
4109  * 'real' months (including fixing January and February from being 14/15 in
4110  * the previous year to being in the proper year).  After that, to get
4111  * tm_yday, we work with the normalised year and get a new yearday value for
4112  * January 1st, which we subtract from the yearday value we had earlier,
4113  * representing the date we've re-built.  This is done from January 1
4114  * because tm_yday is 0-origin.
4115  *
4116  * Since POSIX time routines are only guaranteed to work for times since the
4117  * UNIX epoch (00:00:00 1 Jan 1970 UTC), the fact that this algorithm
4118  * applies Gregorian calendar rules even to dates before the 16th century
4119  * doesn't bother me.  Besides, you'd need cultural context for a given
4120  * date to know whether it was Julian or Gregorian calendar, and that's
4121  * outside the scope for this routine.  Since we convert back based on the
4122  * same rules we used to build the yearday, you'll only get strange results
4123  * for input which needed normalising, or for the 'odd' century years which
4124  * were leap years in the Julian calander but not in the Gregorian one.
4125  * I can live with that.
4126  *
4127  * This algorithm also fails to handle years before A.D. 1 gracefully, but
4128  * that's still outside the scope for POSIX time manipulation, so I don't
4129  * care.
4130  */
4131
4132     year = 1900 + ptm->tm_year;
4133     month = ptm->tm_mon;
4134     mday = ptm->tm_mday;
4135     /* allow given yday with no month & mday to dominate the result */
4136     if (ptm->tm_yday >= 0 && mday <= 0 && month <= 0) {
4137         month = 0;
4138         mday = 0;
4139         jday = 1 + ptm->tm_yday;
4140     }
4141     else {
4142         jday = 0;
4143     }
4144     if (month >= 2)
4145         month+=2;
4146     else
4147         month+=14, year--;
4148     yearday = DAYS_PER_YEAR * year + year/4 - year/100 + year/400;
4149     yearday += month*MONTH_TO_DAYS + mday + jday;
4150     /*
4151      * Note that we don't know when leap-seconds were or will be,
4152      * so we have to trust the user if we get something which looks
4153      * like a sensible leap-second.  Wild values for seconds will
4154      * be rationalised, however.
4155      */
4156     if ((unsigned) ptm->tm_sec <= 60) {
4157         secs = 0;
4158     }
4159     else {
4160         secs = ptm->tm_sec;
4161         ptm->tm_sec = 0;
4162     }
4163     secs += 60 * ptm->tm_min;
4164     secs += SECS_PER_HOUR * ptm->tm_hour;
4165     if (secs < 0) {
4166         if (secs-(secs/SECS_PER_DAY*SECS_PER_DAY) < 0) {
4167             /* got negative remainder, but need positive time */
4168             /* back off an extra day to compensate */
4169             yearday += (secs/SECS_PER_DAY)-1;
4170             secs -= SECS_PER_DAY * (secs/SECS_PER_DAY - 1);
4171         }
4172         else {
4173             yearday += (secs/SECS_PER_DAY);
4174             secs -= SECS_PER_DAY * (secs/SECS_PER_DAY);
4175         }
4176     }
4177     else if (secs >= SECS_PER_DAY) {
4178         yearday += (secs/SECS_PER_DAY);
4179         secs %= SECS_PER_DAY;
4180     }
4181     ptm->tm_hour = secs/SECS_PER_HOUR;
4182     secs %= SECS_PER_HOUR;
4183     ptm->tm_min = secs/60;
4184     secs %= 60;
4185     ptm->tm_sec += secs;
4186     /* done with time of day effects */
4187     /*
4188      * The algorithm for yearday has (so far) left it high by 428.
4189      * To avoid mistaking a legitimate Feb 29 as Mar 1, we need to
4190      * bias it by 123 while trying to figure out what year it
4191      * really represents.  Even with this tweak, the reverse
4192      * translation fails for years before A.D. 0001.
4193      * It would still fail for Feb 29, but we catch that one below.
4194      */
4195     jday = yearday;     /* save for later fixup vis-a-vis Jan 1 */
4196     yearday -= YEAR_ADJUST;
4197     year = (yearday / DAYS_PER_QCENT) * 400;
4198     yearday %= DAYS_PER_QCENT;
4199     odd_cent = yearday / DAYS_PER_CENT;
4200     year += odd_cent * 100;
4201     yearday %= DAYS_PER_CENT;
4202     year += (yearday / DAYS_PER_QYEAR) * 4;
4203     yearday %= DAYS_PER_QYEAR;
4204     odd_year = yearday / DAYS_PER_YEAR;
4205     year += odd_year;
4206     yearday %= DAYS_PER_YEAR;
4207     if (!yearday && (odd_cent==4 || odd_year==4)) { /* catch Feb 29 */
4208         month = 1;
4209         yearday = 29;
4210     }
4211     else {
4212         yearday += YEAR_ADJUST; /* recover March 1st crock */
4213         month = yearday*DAYS_TO_MONTH;
4214         yearday -= month*MONTH_TO_DAYS;
4215         /* recover other leap-year adjustment */
4216         if (month > 13) {
4217             month-=14;
4218             year++;
4219         }
4220         else {
4221             month-=2;
4222         }
4223     }
4224     ptm->tm_year = year - 1900;
4225     if (yearday) {
4226       ptm->tm_mday = yearday;
4227       ptm->tm_mon = month;
4228     }
4229     else {
4230       ptm->tm_mday = 31;
4231       ptm->tm_mon = month - 1;
4232     }
4233     /* re-build yearday based on Jan 1 to get tm_yday */
4234     year--;
4235     yearday = year*DAYS_PER_YEAR + year/4 - year/100 + year/400;
4236     yearday += 14*MONTH_TO_DAYS + 1;
4237     ptm->tm_yday = jday - yearday;
4238     /* fix tm_wday if not overridden by caller */
4239     if ((unsigned)ptm->tm_wday > 6)
4240         ptm->tm_wday = (jday + WEEKDAY_BIAS) % 7;
4241 }
4242
4243 char *
4244 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)
4245 {
4246 #ifdef HAS_STRFTIME
4247   char *buf;
4248   int buflen;
4249   struct tm mytm;
4250   int len;
4251
4252   PERL_ARGS_ASSERT_MY_STRFTIME;
4253
4254   init_tm(&mytm);       /* XXX workaround - see init_tm() above */
4255   mytm.tm_sec = sec;
4256   mytm.tm_min = min;
4257   mytm.tm_hour = hour;
4258   mytm.tm_mday = mday;
4259   mytm.tm_mon = mon;
4260   mytm.tm_year = year;
4261   mytm.tm_wday = wday;
4262   mytm.tm_yday = yday;
4263   mytm.tm_isdst = isdst;
4264   mini_mktime(&mytm);
4265   /* use libc to get the values for tm_gmtoff and tm_zone [perl #18238] */
4266 #if defined(HAS_MKTIME) && (defined(HAS_TM_TM_GMTOFF) || defined(HAS_TM_TM_ZONE))
4267   STMT_START {
4268     struct tm mytm2;
4269     mytm2 = mytm;
4270     mktime(&mytm2);
4271 #ifdef HAS_TM_TM_GMTOFF
4272     mytm.tm_gmtoff = mytm2.tm_gmtoff;
4273 #endif
4274 #ifdef HAS_TM_TM_ZONE
4275     mytm.tm_zone = mytm2.tm_zone;
4276 #endif
4277   } STMT_END;
4278 #endif
4279   buflen = 64;
4280   Newx(buf, buflen, char);
4281   len = strftime(buf, buflen, fmt, &mytm);
4282   /*
4283   ** The following is needed to handle to the situation where
4284   ** tmpbuf overflows.  Basically we want to allocate a buffer
4285   ** and try repeatedly.  The reason why it is so complicated
4286   ** is that getting a return value of 0 from strftime can indicate
4287   ** one of the following:
4288   ** 1. buffer overflowed,
4289   ** 2. illegal conversion specifier, or
4290   ** 3. the format string specifies nothing to be returned(not
4291   **      an error).  This could be because format is an empty string
4292   **    or it specifies %p that yields an empty string in some locale.
4293   ** If there is a better way to make it portable, go ahead by
4294   ** all means.
4295   */
4296   if ((len > 0 && len < buflen) || (len == 0 && *fmt == '\0'))
4297     return buf;
4298   else {
4299     /* Possibly buf overflowed - try again with a bigger buf */
4300     const int fmtlen = strlen(fmt);
4301     int bufsize = fmtlen + buflen;
4302
4303     Renew(buf, bufsize, char);
4304     while (buf) {
4305       buflen = strftime(buf, bufsize, fmt, &mytm);
4306       if (buflen > 0 && buflen < bufsize)
4307         break;
4308       /* heuristic to prevent out-of-memory errors */
4309       if (bufsize > 100*fmtlen) {
4310         Safefree(buf);
4311         buf = NULL;
4312         break;
4313       }
4314       bufsize *= 2;
4315       Renew(buf, bufsize, char);
4316     }
4317     return buf;
4318   }
4319 #else
4320   Perl_croak(aTHX_ "panic: no strftime");
4321   return NULL;
4322 #endif
4323 }
4324
4325
4326 #define SV_CWD_RETURN_UNDEF \
4327 sv_setsv(sv, &PL_sv_undef); \
4328 return FALSE
4329
4330 #define SV_CWD_ISDOT(dp) \
4331     (dp->d_name[0] == '.' && (dp->d_name[1] == '\0' || \
4332         (dp->d_name[1] == '.' && dp->d_name[2] == '\0')))
4333
4334 /*
4335 =head1 Miscellaneous Functions
4336
4337 =for apidoc getcwd_sv
4338
4339 Fill the sv with current working directory
4340
4341 =cut
4342 */
4343
4344 /* Originally written in Perl by John Bazik; rewritten in C by Ben Sugars.
4345  * rewritten again by dougm, optimized for use with xs TARG, and to prefer
4346  * getcwd(3) if available
4347  * Comments from the orignal:
4348  *     This is a faster version of getcwd.  It's also more dangerous
4349  *     because you might chdir out of a directory that you can't chdir
4350  *     back into. */
4351
4352 int
4353 Perl_getcwd_sv(pTHX_ register SV *sv)
4354 {
4355 #ifndef PERL_MICRO
4356     dVAR;
4357 #ifndef INCOMPLETE_TAINTS
4358     SvTAINTED_on(sv);
4359 #endif
4360
4361     PERL_ARGS_ASSERT_GETCWD_SV;
4362
4363 #ifdef HAS_GETCWD
4364     {
4365         char buf[MAXPATHLEN];
4366
4367         /* Some getcwd()s automatically allocate a buffer of the given
4368          * size from the heap if they are given a NULL buffer pointer.
4369          * The problem is that this behaviour is not portable. */
4370         if (getcwd(buf, sizeof(buf) - 1)) {
4371             sv_setpv(sv, buf);
4372             return TRUE;
4373         }
4374         else {
4375             sv_setsv(sv, &PL_sv_undef);
4376             return FALSE;
4377         }
4378     }
4379
4380 #else
4381
4382     Stat_t statbuf;
4383     int orig_cdev, orig_cino, cdev, cino, odev, oino, tdev, tino;
4384     int pathlen=0;
4385     Direntry_t *dp;
4386
4387     SvUPGRADE(sv, SVt_PV);
4388
4389     if (PerlLIO_lstat(".", &statbuf) < 0) {
4390         SV_CWD_RETURN_UNDEF;
4391     }
4392
4393     orig_cdev = statbuf.st_dev;
4394     orig_cino = statbuf.st_ino;
4395     cdev = orig_cdev;
4396     cino = orig_cino;
4397
4398     for (;;) {
4399         DIR *dir;
4400         int namelen;
4401         odev = cdev;
4402         oino = cino;
4403
4404         if (PerlDir_chdir("..") < 0) {
4405             SV_CWD_RETURN_UNDEF;
4406         }
4407         if (PerlLIO_stat(".", &statbuf) < 0) {
4408             SV_CWD_RETURN_UNDEF;
4409         }
4410
4411         cdev = statbuf.st_dev;
4412         cino = statbuf.st_ino;
4413
4414         if (odev == cdev && oino == cino) {
4415             break;
4416         }
4417         if (!(dir = PerlDir_open("."))) {
4418             SV_CWD_RETURN_UNDEF;
4419         }
4420
4421         while ((dp = PerlDir_read(dir)) != NULL) {
4422 #ifdef DIRNAMLEN
4423             namelen = dp->d_namlen;
4424 #else
4425             namelen = strlen(dp->d_name);
4426 #endif
4427             /* skip . and .. */
4428             if (SV_CWD_ISDOT(dp)) {
4429                 continue;
4430             }
4431
4432             if (PerlLIO_lstat(dp->d_name, &statbuf) < 0) {
4433                 SV_CWD_RETURN_UNDEF;
4434             }
4435
4436             tdev = statbuf.st_dev;
4437             tino = statbuf.st_ino;
4438             if (tino == oino && tdev == odev) {
4439                 break;
4440             }
4441         }
4442
4443         if (!dp) {
4444             SV_CWD_RETURN_UNDEF;
4445         }
4446
4447         if (pathlen + namelen + 1 >= MAXPATHLEN) {
4448             SV_CWD_RETURN_UNDEF;
4449         }
4450
4451         SvGROW(sv, pathlen + namelen + 1);
4452
4453         if (pathlen) {
4454             /* shift down */
4455             Move(SvPVX_const(sv), SvPVX(sv) + namelen + 1, pathlen, char);
4456         }
4457
4458         /* prepend current directory to the front */
4459         *SvPVX(sv) = '/';
4460         Move(dp->d_name, SvPVX(sv)+1, namelen, char);
4461         pathlen += (namelen + 1);
4462
4463 #ifdef VOID_CLOSEDIR
4464         PerlDir_close(dir);
4465 #else
4466         if (PerlDir_close(dir) < 0) {
4467             SV_CWD_RETURN_UNDEF;
4468         }
4469 #endif
4470     }
4471
4472     if (pathlen) {
4473         SvCUR_set(sv, pathlen);
4474         *SvEND(sv) = '\0';
4475         SvPOK_only(sv);
4476
4477         if (PerlDir_chdir(SvPVX_const(sv)) < 0) {
4478             SV_CWD_RETURN_UNDEF;
4479         }
4480     }
4481     if (PerlLIO_stat(".", &statbuf) < 0) {
4482         SV_CWD_RETURN_UNDEF;
4483     }
4484
4485     cdev = statbuf.st_dev;
4486     cino = statbuf.st_ino;
4487
4488     if (cdev != orig_cdev || cino != orig_cino) {
4489         Perl_croak(aTHX_ "Unstable directory path, "
4490                    "current directory changed unexpectedly");
4491     }
4492
4493     return TRUE;
4494 #endif
4495
4496 #else
4497     return FALSE;
4498 #endif
4499 }
4500
4501 #define VERSION_MAX 0x7FFFFFFF
4502
4503 /*
4504 =for apidoc prescan_version
4505
4506 =cut
4507 */
4508 const char *
4509 Perl_prescan_version(pTHX_ const char *s, bool strict,
4510                      const char **errstr,
4511                      bool *sqv, int *ssaw_decimal, int *swidth, bool *salpha) {
4512     bool qv = (sqv ? *sqv : FALSE);
4513     int width = 3;
4514     int saw_decimal = 0;
4515     bool alpha = FALSE;
4516     const char *d = s;
4517
4518     PERL_ARGS_ASSERT_PRESCAN_VERSION;
4519
4520     if (qv && isDIGIT(*d))
4521         goto dotted_decimal_version;
4522
4523     if (*d == 'v') { /* explicit v-string */
4524         d++;
4525         if (isDIGIT(*d)) {
4526             qv = TRUE;
4527         }
4528         else { /* degenerate v-string */
4529             /* requires v1.2.3 */
4530             BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
4531         }
4532
4533 dotted_decimal_version:
4534         if (strict && d[0] == '0' && isDIGIT(d[1])) {
4535             /* no leading zeros allowed */
4536             BADVERSION(s,errstr,"Invalid version format (no leading zeros)");
4537         }
4538
4539         while (isDIGIT(*d))     /* integer part */
4540             d++;
4541
4542         if (*d == '.')
4543         {
4544             saw_decimal++;
4545             d++;                /* decimal point */
4546         }
4547         else
4548         {
4549             if (strict) {
4550                 /* require v1.2.3 */
4551                 BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
4552             }
4553             else {
4554                 goto version_prescan_finish;
4555             }
4556         }
4557
4558         {
4559             int i = 0;
4560             int j = 0;
4561             while (isDIGIT(*d)) {       /* just keep reading */
4562                 i++;
4563                 while (isDIGIT(*d)) {
4564                     d++; j++;
4565                     /* maximum 3 digits between decimal */
4566                     if (strict && j > 3) {
4567                         BADVERSION(s,errstr,"Invalid version format (maximum 3 digits between decimals)");
4568                     }
4569                 }
4570                 if (*d == '_') {
4571                     if (strict) {
4572                         BADVERSION(s,errstr,"Invalid version format (no underscores)");
4573                     }
4574                     if ( alpha ) {
4575                         BADVERSION(s,errstr,"Invalid version format (multiple underscores)");
4576                     }
4577                     d++;
4578                     alpha = TRUE;
4579                 }
4580                 else if (*d == '.') {
4581                     if (alpha) {
4582                         BADVERSION(s,errstr,"Invalid version format (underscores before decimal)");
4583                     }
4584                     saw_decimal++;
4585                     d++;
4586                 }
4587                 else if (!isDIGIT(*d)) {
4588                     break;
4589                 }
4590                 j = 0;
4591             }
4592
4593             if (strict && i < 2) {
4594                 /* requires v1.2.3 */
4595                 BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
4596             }
4597         }
4598     }                                   /* end if dotted-decimal */
4599     else
4600     {                                   /* decimal versions */
4601         /* special strict case for leading '.' or '0' */
4602         if (strict) {
4603             if (*d == '.') {
4604                 BADVERSION(s,errstr,"Invalid version format (0 before decimal required)");
4605             }
4606             if (*d == '0' && isDIGIT(d[1])) {
4607                 BADVERSION(s,errstr,"Invalid version format (no leading zeros)");
4608             }
4609         }
4610
4611         /* consume all of the integer part */
4612         while (isDIGIT(*d))
4613             d++;
4614
4615         /* look for a fractional part */
4616         if (*d == '.') {
4617             /* we found it, so consume it */
4618             saw_decimal++;
4619             d++;
4620         }
4621         else if (!*d || *d == ';' || isSPACE(*d) || *d == '{' || *d == '}') {
4622             if ( d == s ) {
4623                 /* found nothing */
4624                 BADVERSION(s,errstr,"Invalid version format (version required)");
4625             }
4626             /* found just an integer */
4627             goto version_prescan_finish;
4628         }
4629         else if ( d == s ) {
4630             /* didn't find either integer or period */
4631             BADVERSION(s,errstr,"Invalid version format (non-numeric data)");
4632         }
4633         else if (*d == '_') {
4634             /* underscore can't come after integer part */
4635             if (strict) {
4636                 BADVERSION(s,errstr,"Invalid version format (no underscores)");
4637             }
4638             else if (isDIGIT(d[1])) {
4639                 BADVERSION(s,errstr,"Invalid version format (alpha without decimal)");
4640             }
4641             else {
4642                 BADVERSION(s,errstr,"Invalid version format (misplaced underscore)");
4643             }
4644         }
4645         else {
4646             /* anything else after integer part is just invalid data */
4647             BADVERSION(s,errstr,"Invalid version format (non-numeric data)");
4648         }
4649
4650         /* scan the fractional part after the decimal point*/
4651
4652         if (!isDIGIT(*d) && (strict || ! (!*d || *d == ';' || isSPACE(*d) || *d == '{' || *d == '}') )) {
4653                 /* strict or lax-but-not-the-end */
4654                 BADVERSION(s,errstr,"Invalid version format (fractional part required)");
4655         }
4656
4657         while (isDIGIT(*d)) {
4658             d++;
4659             if (*d == '.' && isDIGIT(d[-1])) {
4660                 if (alpha) {
4661                     BADVERSION(s,errstr,"Invalid version format (underscores before decimal)");
4662                 }
4663                 if (strict) {
4664                     BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions must begin with 'v')");
4665                 }
4666                 d = (char *)s;          /* start all over again */
4667                 qv = TRUE;
4668                 goto dotted_decimal_version;
4669             }
4670             if (*d == '_') {
4671                 if (strict) {
4672                     BADVERSION(s,errstr,"Invalid version format (no underscores)");
4673                 }
4674                 if ( alpha ) {
4675                     BADVERSION(s,errstr,"Invalid version format (multiple underscores)");
4676                 }
4677                 if ( ! isDIGIT(d[1]) ) {
4678                     BADVERSION(s,errstr,"Invalid version format (misplaced underscore)");
4679                 }
4680                 d++;
4681                 alpha = TRUE;
4682             }
4683         }
4684     }
4685
4686 version_prescan_finish:
4687     while (isSPACE(*d))
4688         d++;
4689
4690     if (!isDIGIT(*d) && (! (!*d || *d == ';' || *d == '{' || *d == '}') )) {
4691         /* trailing non-numeric data */
4692         BADVERSION(s,errstr,"Invalid version format (non-numeric data)");
4693     }
4694
4695     if (sqv)
4696         *sqv = qv;
4697     if (swidth)
4698         *swidth = width;
4699     if (ssaw_decimal)
4700         *ssaw_decimal = saw_decimal;
4701     if (salpha)
4702         *salpha = alpha;
4703     return d;
4704 }
4705
4706 /*
4707 =for apidoc scan_version
4708
4709 Returns a pointer to the next character after the parsed
4710 version string, as well as upgrading the passed in SV to
4711 an RV.
4712
4713 Function must be called with an already existing SV like
4714
4715     sv = newSV(0);
4716     s = scan_version(s, SV *sv, bool qv);
4717
4718 Performs some preprocessing to the string to ensure that
4719 it has the correct characteristics of a version.  Flags the
4720 object if it contains an underscore (which denotes this
4721 is an alpha version).  The boolean qv denotes that the version
4722 should be interpreted as if it had multiple decimals, even if
4723 it doesn't.
4724
4725 =cut
4726 */
4727
4728 const char *
4729 Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
4730 {
4731     const char *start;
4732     const char *pos;
4733     const char *last;
4734     const char *errstr = NULL;
4735     int saw_decimal = 0;
4736     int width = 3;
4737     bool alpha = FALSE;
4738     bool vinf = FALSE;
4739     AV * const av = newAV();
4740     SV * const hv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */
4741
4742     PERL_ARGS_ASSERT_SCAN_VERSION;
4743
4744     (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
4745
4746 #ifndef NODEFAULT_SHAREKEYS
4747     HvSHAREKEYS_on(hv);         /* key-sharing on by default */
4748 #endif
4749
4750     while (isSPACE(*s)) /* leading whitespace is OK */
4751         s++;
4752
4753     last = prescan_version(s, FALSE, &errstr, &qv, &saw_decimal, &width, &alpha);
4754     if (errstr) {
4755         /* "undef" is a special case and not an error */
4756         if ( ! ( *s == 'u' && strEQ(s,"undef")) ) {
4757             Perl_croak(aTHX_ "%s", errstr);
4758         }
4759     }
4760
4761     start = s;
4762     if (*s == 'v')
4763         s++;
4764     pos = s;
4765
4766     if ( qv )
4767         (void)hv_stores(MUTABLE_HV(hv), "qv", newSViv(qv));
4768     if ( alpha )
4769         (void)hv_stores(MUTABLE_HV(hv), "alpha", newSViv(alpha));
4770     if ( !qv && width < 3 )
4771         (void)hv_stores(MUTABLE_HV(hv), "width", newSViv(width));
4772
4773     while (isDIGIT(*pos))
4774         pos++;
4775     if (!isALPHA(*pos)) {
4776         I32 rev;
4777
4778         for (;;) {
4779             rev = 0;
4780             {
4781                 /* this is atoi() that delimits on underscores */
4782                 const char *end = pos;
4783                 I32 mult = 1;
4784                 I32 orev;
4785
4786                 /* the following if() will only be true after the decimal
4787                  * point of a version originally created with a bare
4788                  * floating point number, i.e. not quoted in any way
4789                  */
4790                 if ( !qv && s > start && saw_decimal == 1 ) {
4791                     mult *= 100;
4792                     while ( s < end ) {
4793                         orev = rev;
4794                         rev += (*s - '0') * mult;
4795                         mult /= 10;
4796                         if (   (PERL_ABS(orev) > PERL_ABS(rev))
4797                             || (PERL_ABS(rev) > VERSION_MAX )) {
4798                             Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4799                                            "Integer overflow in version %d",VERSION_MAX);
4800                             s = end - 1;
4801                             rev = VERSION_MAX;
4802                             vinf = 1;
4803                         }
4804                         s++;
4805                         if ( *s == '_' )
4806                             s++;
4807                     }
4808                 }
4809                 else {
4810                     while (--end >= s) {
4811                         orev = rev;
4812                         rev += (*end - '0') * mult;
4813                         mult *= 10;
4814                         if (   (PERL_ABS(orev) > PERL_ABS(rev))
4815                             || (PERL_ABS(rev) > VERSION_MAX )) {
4816                             Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4817                                            "Integer overflow in version");
4818                             end = s - 1;
4819                             rev = VERSION_MAX;
4820                             vinf = 1;
4821                         }
4822                     }
4823                 }
4824             }
4825
4826             /* Append revision */
4827             av_push(av, newSViv(rev));
4828             if ( vinf ) {
4829                 s = last;
4830                 break;
4831             }
4832             else if ( *pos == '.' )
4833                 s = ++pos;
4834             else if ( *pos == '_' && isDIGIT(pos[1]) )
4835                 s = ++pos;
4836             else if ( *pos == ',' && isDIGIT(pos[1]) )
4837                 s = ++pos;
4838             else if ( isDIGIT(*pos) )
4839                 s = pos;
4840             else {
4841                 s = pos;
4842                 break;
4843             }
4844             if ( qv ) {
4845                 while ( isDIGIT(*pos) )
4846                     pos++;
4847             }
4848             else {
4849                 int digits = 0;
4850                 while ( ( isDIGIT(*pos) || *pos == '_' ) && digits < 3 ) {
4851                     if ( *pos != '_' )
4852                         digits++;
4853                     pos++;
4854                 }
4855             }
4856         }
4857     }
4858     if ( qv ) { /* quoted versions always get at least three terms*/
4859         I32 len = av_len(av);
4860         /* This for loop appears to trigger a compiler bug on OS X, as it
4861            loops infinitely. Yes, len is negative. No, it makes no sense.
4862            Compiler in question is:
4863            gcc version 3.3 20030304 (Apple Computer, Inc. build 1640)
4864            for ( len = 2 - len; len > 0; len-- )
4865            av_push(MUTABLE_AV(sv), newSViv(0));
4866         */
4867         len = 2 - len;
4868         while (len-- > 0)
4869             av_push(av, newSViv(0));
4870     }
4871
4872     /* need to save off the current version string for later */
4873     if ( vinf ) {
4874         SV * orig = newSVpvn("v.Inf", sizeof("v.Inf")-1);
4875         (void)hv_stores(MUTABLE_HV(hv), "original", orig);
4876         (void)hv_stores(MUTABLE_HV(hv), "vinf", newSViv(1));
4877     }
4878     else if ( s > start ) {
4879         SV * orig = newSVpvn(start,s-start);
4880         if ( qv && saw_decimal == 1 && *start != 'v' ) {
4881             /* need to insert a v to be consistent */
4882             sv_insert(orig, 0, 0, "v", 1);
4883         }
4884         (void)hv_stores(MUTABLE_HV(hv), "original", orig);
4885     }
4886     else {
4887         (void)hv_stores(MUTABLE_HV(hv), "original", newSVpvs("0"));
4888         av_push(av, newSViv(0));
4889     }
4890
4891     /* And finally, store the AV in the hash */
4892     (void)hv_stores(MUTABLE_HV(hv), "version", newRV_noinc(MUTABLE_SV(av)));
4893
4894     /* fix RT#19517 - special case 'undef' as string */
4895     if ( *s == 'u' && strEQ(s,"undef") ) {
4896         s += 5;
4897     }
4898
4899     return s;
4900 }
4901
4902 /*
4903 =for apidoc new_version
4904
4905 Returns a new version object based on the passed in SV:
4906
4907     SV *sv = new_version(SV *ver);
4908
4909 Does not alter the passed in ver SV.  See "upg_version" if you
4910 want to upgrade the SV.
4911
4912 =cut
4913 */
4914
4915 SV *
4916 Perl_new_version(pTHX_ SV *ver)
4917 {
4918     dVAR;
4919     SV * const rv = newSV(0);
4920     PERL_ARGS_ASSERT_NEW_VERSION;
4921     if ( sv_derived_from(ver,"version") ) /* can just copy directly */
4922     {
4923         I32 key;
4924         AV * const av = newAV();
4925         AV *sav;
4926         /* This will get reblessed later if a derived class*/
4927         SV * const hv = newSVrv(rv, "version");
4928         (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
4929 #ifndef NODEFAULT_SHAREKEYS
4930         HvSHAREKEYS_on(hv);         /* key-sharing on by default */
4931 #endif
4932
4933         if ( SvROK(ver) )
4934             ver = SvRV(ver);
4935
4936         /* Begin copying all of the elements */
4937         if ( hv_exists(MUTABLE_HV(ver), "qv", 2) )
4938             (void)hv_stores(MUTABLE_HV(hv), "qv", newSViv(1));
4939
4940         if ( hv_exists(MUTABLE_HV(ver), "alpha", 5) )
4941             (void)hv_stores(MUTABLE_HV(hv), "alpha", newSViv(1));
4942
4943         if ( hv_exists(MUTABLE_HV(ver), "width", 5 ) )
4944         {
4945             const I32 width = SvIV(*hv_fetchs(MUTABLE_HV(ver), "width", FALSE));
4946             (void)hv_stores(MUTABLE_HV(hv), "width", newSViv(width));
4947         }
4948
4949         if ( hv_exists(MUTABLE_HV(ver), "original", 8 ) )
4950         {
4951             SV * pv = *hv_fetchs(MUTABLE_HV(ver), "original", FALSE);
4952             (void)hv_stores(MUTABLE_HV(hv), "original", newSVsv(pv));
4953         }
4954
4955         sav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(ver), "version", FALSE)));
4956         /* This will get reblessed later if a derived class*/
4957         for ( key = 0; key <= av_len(sav); key++ )
4958         {
4959             const I32 rev = SvIV(*av_fetch(sav, key, FALSE));
4960             av_push(av, newSViv(rev));
4961         }
4962
4963         (void)hv_stores(MUTABLE_HV(hv), "version", newRV_noinc(MUTABLE_SV(av)));
4964         return rv;
4965     }
4966 #ifdef SvVOK
4967     {
4968         const MAGIC* const mg = SvVSTRING_mg(ver);
4969         if ( mg ) { /* already a v-string */
4970             const STRLEN len = mg->mg_len;
4971             char * const version = savepvn( (const char*)mg->mg_ptr, len);
4972             sv_setpvn(rv,version,len);
4973             /* this is for consistency with the pure Perl class */
4974             if ( isDIGIT(*version) )
4975                 sv_insert(rv, 0, 0, "v", 1);
4976             Safefree(version);
4977         }
4978         else {
4979 #endif
4980         sv_setsv(rv,ver); /* make a duplicate */
4981 #ifdef SvVOK
4982         }
4983     }
4984 #endif
4985     return upg_version(rv, FALSE);
4986 }
4987
4988 /*
4989 =for apidoc upg_version
4990
4991 In-place upgrade of the supplied SV to a version object.
4992
4993     SV *sv = upg_version(SV *sv, bool qv);
4994
4995 Returns a pointer to the upgraded SV.  Set the boolean qv if you want
4996 to force this SV to be interpreted as an "extended" version.
4997
4998 =cut
4999 */
5000
5001 SV *
5002 Perl_upg_version(pTHX_ SV *ver, bool qv)
5003 {
5004     const char *version, *s;
5005 #ifdef SvVOK
5006     const MAGIC *mg;
5007 #endif
5008
5009     PERL_ARGS_ASSERT_UPG_VERSION;
5010
5011     if ( SvNOK(ver) && !( SvPOK(ver) && sv_len(ver) == 3 ) )
5012     {
5013         /* may get too much accuracy */
5014         char tbuf[64];
5015 #ifdef USE_LOCALE_NUMERIC
5016         char *loc = setlocale(LC_NUMERIC, "C");
5017 #endif
5018         STRLEN len = my_snprintf(tbuf, sizeof(tbuf), "%.9"NVff, SvNVX(ver));
5019 #ifdef USE_LOCALE_NUMERIC
5020         setlocale(LC_NUMERIC, loc);
5021 #endif
5022         while (tbuf[len-1] == '0' && len > 0) len--;
5023         if ( tbuf[len-1] == '.' ) len--; /* eat the trailing decimal */
5024         version = savepvn(tbuf, len);
5025     }
5026 #ifdef SvVOK
5027     else if ( (mg = SvVSTRING_mg(ver)) ) { /* already a v-string */
5028         version = savepvn( (const char*)mg->mg_ptr,mg->mg_len );
5029         qv = TRUE;
5030     }
5031 #endif
5032     else /* must be a string or something like a string */
5033     {
5034         STRLEN len;
5035         version = savepv(SvPV(ver,len));
5036 #ifndef SvVOK
5037 #  if PERL_VERSION > 5
5038         /* This will only be executed for 5.6.0 - 5.8.0 inclusive */
5039         if ( len >= 3 && !instr(version,".") && !instr(version,"_")
5040             && !(*version == 'u' && strEQ(version, "undef"))
5041             && (*version < '0' || *version > '9') ) {
5042             /* may be a v-string */
5043             SV * const nsv = sv_newmortal();
5044             const char *nver;
5045             const char *pos;
5046             int saw_decimal = 0;
5047             sv_setpvf(nsv,"v%vd",ver);
5048             pos = nver = savepv(SvPV_nolen(nsv));
5049
5050             /* scan the resulting formatted string */
5051             pos++; /* skip the leading 'v' */
5052             while ( *pos == '.' || isDIGIT(*pos) ) {
5053                 if ( *pos == '.' )
5054                     saw_decimal++ ;
5055                 pos++;
5056             }
5057
5058             /* is definitely a v-string */
5059             if ( saw_decimal >= 2 ) {
5060                 Safefree(version);
5061                 version = nver;
5062             }
5063         }
5064 #  endif
5065 #endif
5066     }
5067
5068     s = scan_version(version, ver, qv);
5069     if ( *s != '\0' )
5070         Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
5071                        "Version string '%s' contains invalid data; "
5072                        "ignoring: '%s'", version, s);
5073     Safefree(version);
5074     return ver;
5075 }
5076
5077 /*
5078 =for apidoc vverify
5079
5080 Validates that the SV contains a valid version object.
5081
5082     bool vverify(SV *vobj);
5083
5084 Note that it only confirms the bare minimum structure (so as not to get
5085 confused by derived classes which may contain additional hash entries):
5086
5087 =over 4
5088
5089 =item * The SV contains a [reference to a] hash
5090
5091 =item * The hash contains a "version" key
5092
5093 =item * The "version" key has [a reference to] an AV as its value
5094
5095 =back
5096
5097 =cut
5098 */
5099
5100 bool
5101 Perl_vverify(pTHX_ SV *vs)
5102 {
5103     SV *sv;
5104
5105     PERL_ARGS_ASSERT_VVERIFY;
5106
5107     if ( SvROK(vs) )
5108         vs = SvRV(vs);
5109
5110     /* see if the appropriate elements exist */
5111     if ( SvTYPE(vs) == SVt_PVHV
5112          && hv_exists(MUTABLE_HV(vs), "version", 7)
5113          && (sv = SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE)))
5114          && SvTYPE(sv) == SVt_PVAV )
5115         return TRUE;
5116     else
5117         return FALSE;
5118 }
5119
5120 /*
5121 =for apidoc vnumify
5122
5123 Accepts a version object and returns the normalized floating
5124 point representation.  Call like:
5125
5126     sv = vnumify(rv);
5127
5128 NOTE: you can pass either the object directly or the SV
5129 contained within the RV.
5130
5131 =cut
5132 */
5133
5134 SV *
5135 Perl_vnumify(pTHX_ SV *vs)
5136 {
5137     I32 i, len, digit;
5138     int width;
5139     bool alpha = FALSE;
5140     SV *sv;
5141     AV *av;
5142
5143     PERL_ARGS_ASSERT_VNUMIFY;
5144
5145     if ( SvROK(vs) )
5146         vs = SvRV(vs);
5147
5148     if ( !vverify(vs) )
5149         Perl_croak(aTHX_ "Invalid version object");
5150
5151     /* see if various flags exist */
5152     if ( hv_exists(MUTABLE_HV(vs), "alpha", 5 ) )
5153         alpha = TRUE;
5154     if ( hv_exists(MUTABLE_HV(vs), "width", 5 ) )
5155         width = SvIV(*hv_fetchs(MUTABLE_HV(vs), "width", FALSE));
5156     else
5157         width = 3;
5158
5159
5160     /* attempt to retrieve the version array */
5161     if ( !(av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE))) ) ) {
5162         return newSVpvs("0");
5163     }
5164
5165     len = av_len(av);
5166     if ( len == -1 )
5167     {
5168         return newSVpvs("0");
5169     }
5170
5171     digit = SvIV(*av_fetch(av, 0, 0));
5172     sv = Perl_newSVpvf(aTHX_ "%d.", (int)PERL_ABS(digit));
5173     for ( i = 1 ; i < len ; i++ )
5174     {
5175         digit = SvIV(*av_fetch(av, i, 0));
5176         if ( width < 3 ) {
5177             const int denom = (width == 2 ? 10 : 100);
5178             const div_t term = div((int)PERL_ABS(digit),denom);
5179             Perl_sv_catpvf(aTHX_ sv, "%0*d_%d", width, term.quot, term.rem);
5180         }
5181         else {
5182             Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit);
5183         }
5184     }
5185
5186     if ( len > 0 )
5187     {
5188         digit = SvIV(*av_fetch(av, len, 0));
5189         if ( alpha && width == 3 ) /* alpha version */
5190             sv_catpvs(sv,"_");
5191         Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit);
5192     }
5193     else /* len == 0 */
5194     {
5195         sv_catpvs(sv, "000");
5196     }
5197     return sv;
5198 }
5199
5200 /*
5201 =for apidoc vnormal
5202
5203 Accepts a version object and returns the normalized string
5204 representation.  Call like:
5205
5206     sv = vnormal(rv);
5207
5208 NOTE: you can pass either the object directly or the SV
5209 contained within the RV.
5210
5211 =cut
5212 */
5213
5214 SV *
5215 Perl_vnormal(pTHX_ SV *vs)
5216 {
5217     I32 i, len, digit;
5218     bool alpha = FALSE;
5219     SV *sv;
5220     AV *av;
5221
5222     PERL_ARGS_ASSERT_VNORMAL;
5223
5224     if ( SvROK(vs) )
5225         vs = SvRV(vs);
5226
5227     if ( !vverify(vs) )
5228         Perl_croak(aTHX_ "Invalid version object");
5229
5230     if ( hv_exists(MUTABLE_HV(vs), "alpha", 5 ) )
5231         alpha = TRUE;
5232     av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE)));
5233
5234     len = av_len(av);
5235     if ( len == -1 )
5236     {
5237         return newSVpvs("");
5238     }
5239     digit = SvIV(*av_fetch(av, 0, 0));
5240     sv = Perl_newSVpvf(aTHX_ "v%"IVdf, (IV)digit);
5241     for ( i = 1 ; i < len ; i++ ) {
5242         digit = SvIV(*av_fetch(av, i, 0));
5243         Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
5244     }
5245
5246     if ( len > 0 )
5247     {
5248         /* handle last digit specially */
5249         digit = SvIV(*av_fetch(av, len, 0));
5250         if ( alpha )
5251             Perl_sv_catpvf(aTHX_ sv, "_%"IVdf, (IV)digit);
5252         else
5253             Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
5254     }
5255
5256     if ( len <= 2 ) { /* short version, must be at least three */
5257         for ( len = 2 - len; len != 0; len-- )
5258             sv_catpvs(sv,".0");
5259     }
5260     return sv;
5261 }
5262
5263 /*
5264 =for apidoc vstringify
5265
5266 In order to maintain maximum compatibility with earlier versions
5267 of Perl, this function will return either the floating point
5268 notation or the multiple dotted notation, depending on whether
5269 the original version contained 1 or more dots, respectively
5270
5271 =cut
5272 */
5273
5274 SV *
5275 Perl_vstringify(pTHX_ SV *vs)
5276 {
5277     PERL_ARGS_ASSERT_VSTRINGIFY;
5278
5279     if ( SvROK(vs) )
5280         vs = SvRV(vs);
5281
5282     if ( !vverify(vs) )
5283         Perl_croak(aTHX_ "Invalid version object");
5284
5285     if (hv_exists(MUTABLE_HV(vs), "original",  sizeof("original") - 1)) {
5286         SV *pv;
5287         pv = *hv_fetchs(MUTABLE_HV(vs), "original", FALSE);
5288         if ( SvPOK(pv) )
5289             return newSVsv(pv);
5290         else
5291             return &PL_sv_undef;
5292     }
5293     else {
5294         if ( hv_exists(MUTABLE_HV(vs), "qv", 2) )
5295             return vnormal(vs);
5296         else
5297             return vnumify(vs);
5298     }
5299 }
5300
5301 /*
5302 =for apidoc vcmp
5303
5304 Version object aware cmp.  Both operands must already have been
5305 converted into version objects.
5306
5307 =cut
5308 */
5309
5310 int
5311 Perl_vcmp(pTHX_ SV *lhv, SV *rhv)
5312 {
5313     I32 i,l,m,r,retval;
5314     bool lalpha = FALSE;
5315     bool ralpha = FALSE;
5316     I32 left = 0;
5317     I32 right = 0;
5318     AV *lav, *rav;
5319
5320     PERL_ARGS_ASSERT_VCMP;
5321
5322     if ( SvROK(lhv) )
5323         lhv = SvRV(lhv);
5324     if ( SvROK(rhv) )
5325         rhv = SvRV(rhv);
5326
5327     if ( !vverify(lhv) )
5328         Perl_croak(aTHX_ "Invalid version object");
5329
5330     if ( !vverify(rhv) )
5331         Perl_croak(aTHX_ "Invalid version object");
5332
5333     /* get the left hand term */
5334     lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(lhv), "version", FALSE)));
5335     if ( hv_exists(MUTABLE_HV(lhv), "alpha", 5 ) )
5336         lalpha = TRUE;
5337
5338     /* and the right hand term */
5339     rav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(rhv), "version", FALSE)));
5340     if ( hv_exists(MUTABLE_HV(rhv), "alpha", 5 ) )
5341         ralpha = TRUE;
5342
5343     l = av_len(lav);
5344     r = av_len(rav);
5345     m = l < r ? l : r;
5346     retval = 0;
5347     i = 0;
5348     while ( i <= m && retval == 0 )
5349     {
5350         left  = SvIV(*av_fetch(lav,i,0));
5351         right = SvIV(*av_fetch(rav,i,0));
5352         if ( left < right  )
5353             retval = -1;
5354         if ( left > right )
5355             retval = +1;
5356         i++;
5357     }
5358
5359     /* tiebreaker for alpha with identical terms */
5360     if ( retval == 0 && l == r && left == right && ( lalpha || ralpha ) )
5361     {
5362         if ( lalpha && !ralpha )
5363         {
5364             retval = -1;
5365         }
5366         else if ( ralpha && !lalpha)
5367         {
5368             retval = +1;
5369         }
5370     }
5371
5372     if ( l != r && retval == 0 ) /* possible match except for trailing 0's */
5373     {
5374         if ( l < r )
5375         {
5376             while ( i <= r && retval == 0 )
5377             {
5378                 if ( SvIV(*av_fetch(rav,i,0)) != 0 )
5379                     retval = -1; /* not a match after all */
5380                 i++;
5381             }
5382         }
5383         else
5384         {
5385             while ( i <= l && retval == 0 )
5386             {
5387                 if ( SvIV(*av_fetch(lav,i,0)) != 0 )
5388                     retval = +1; /* not a match after all */
5389                 i++;
5390             }
5391         }
5392     }
5393     return retval;
5394 }
5395
5396 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET) && defined(SOCK_DGRAM) && defined(HAS_SELECT)
5397 #   define EMULATE_SOCKETPAIR_UDP
5398 #endif
5399
5400 #ifdef EMULATE_SOCKETPAIR_UDP
5401 static int
5402 S_socketpair_udp (int fd[2]) {
5403     dTHX;
5404     /* Fake a datagram socketpair using UDP to localhost.  */
5405     int sockets[2] = {-1, -1};
5406     struct sockaddr_in addresses[2];
5407     int i;
5408     Sock_size_t size = sizeof(struct sockaddr_in);
5409     unsigned short port;
5410     int got;
5411
5412     memset(&addresses, 0, sizeof(addresses));
5413     i = 1;
5414     do {
5415         sockets[i] = PerlSock_socket(AF_INET, SOCK_DGRAM, PF_INET);
5416         if (sockets[i] == -1)
5417             goto tidy_up_and_fail;
5418
5419         addresses[i].sin_family = AF_INET;
5420         addresses[i].sin_addr.s_addr = htonl(INADDR_LOOPBACK);
5421         addresses[i].sin_port = 0;      /* kernel choses port.  */
5422         if (PerlSock_bind(sockets[i], (struct sockaddr *) &addresses[i],
5423                 sizeof(struct sockaddr_in)) == -1)
5424             goto tidy_up_and_fail;
5425     } while (i--);
5426
5427     /* Now have 2 UDP sockets. Find out which port each is connected to, and
5428        for each connect the other socket to it.  */
5429     i = 1;
5430     do {
5431         if (PerlSock_getsockname(sockets[i], (struct sockaddr *) &addresses[i],
5432                 &size) == -1)
5433             goto tidy_up_and_fail;
5434         if (size != sizeof(struct sockaddr_in))
5435             goto abort_tidy_up_and_fail;
5436         /* !1 is 0, !0 is 1 */
5437         if (PerlSock_connect(sockets[!i], (struct sockaddr *) &addresses[i],
5438                 sizeof(struct sockaddr_in)) == -1)
5439             goto tidy_up_and_fail;
5440     } while (i--);
5441
5442     /* Now we have 2 sockets connected to each other. I don't trust some other
5443        process not to have already sent a packet to us (by random) so send
5444        a packet from each to the other.  */
5445     i = 1;
5446     do {
5447         /* I'm going to send my own port number.  As a short.
5448            (Who knows if someone somewhere has sin_port as a bitfield and needs
5449            this routine. (I'm assuming crays have socketpair)) */
5450         port = addresses[i].sin_port;
5451         got = PerlLIO_write(sockets[i], &port, sizeof(port));
5452         if (got != sizeof(port)) {
5453             if (got == -1)
5454                 goto tidy_up_and_fail;
5455             goto abort_tidy_up_and_fail;
5456         }
5457     } while (i--);
5458
5459     /* Packets sent. I don't trust them to have arrived though.
5460        (As I understand it Solaris TCP stack is multithreaded. Non-blocking
5461        connect to localhost will use a second kernel thread. In 2.6 the
5462        first thread running the connect() returns before the second completes,
5463        so EINPROGRESS> In 2.7 the improved stack is faster and connect()
5464        returns 0. Poor programs have tripped up. One poor program's authors'
5465        had a 50-1 reverse stock split. Not sure how connected these were.)
5466        So I don't trust someone not to have an unpredictable UDP stack.
5467     */
5468
5469     {
5470         struct timeval waitfor = {0, 100000}; /* You have 0.1 seconds */
5471         int max = sockets[1] > sockets[0] ? sockets[1] : sockets[0];
5472         fd_set rset;
5473
5474         FD_ZERO(&rset);
5475         FD_SET((unsigned int)sockets[0], &rset);
5476         FD_SET((unsigned int)sockets[1], &rset);
5477
5478         got = PerlSock_select(max + 1, &rset, NULL, NULL, &waitfor);
5479         if (got != 2 || !FD_ISSET(sockets[0], &rset)
5480                 || !FD_ISSET(sockets[1], &rset)) {
5481             /* I hope this is portable and appropriate.  */
5482             if (got == -1)
5483                 goto tidy_up_and_fail;
5484             goto abort_tidy_up_and_fail;
5485         }
5486     }
5487
5488     /* And the paranoia department even now doesn't trust it to have arrive
5489        (hence MSG_DONTWAIT). Or that what arrives was sent by us.  */
5490     {
5491         struct sockaddr_in readfrom;
5492         unsigned short buffer[2];
5493
5494         i = 1;
5495         do {
5496 #ifdef MSG_DONTWAIT
5497             got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
5498                     sizeof(buffer), MSG_DONTWAIT,
5499                     (struct sockaddr *) &readfrom, &size);
5500 #else
5501             got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
5502                     sizeof(buffer), 0,
5503                     (struct sockaddr *) &readfrom, &size);
5504 #endif
5505
5506             if (got == -1)
5507                 goto tidy_up_and_fail;
5508             if (got != sizeof(port)
5509                     || size != sizeof(struct sockaddr_in)
5510                     /* Check other socket sent us its port.  */
5511                     || buffer[0] != (unsigned short) addresses[!i].sin_port
5512                     /* Check kernel says we got the datagram from that socket */
5513                     || readfrom.sin_family != addresses[!i].sin_family
5514                     || readfrom.sin_addr.s_addr != addresses[!i].sin_addr.s_addr
5515                     || readfrom.sin_port != addresses[!i].sin_port)
5516                 goto abort_tidy_up_and_fail;
5517         } while (i--);
5518     }
5519     /* My caller (my_socketpair) has validated that this is non-NULL  */
5520     fd[0] = sockets[0];
5521     fd[1] = sockets[1];
5522     /* I hereby declare this connection open.  May God bless all who cross
5523        her.  */
5524     return 0;
5525
5526   abort_tidy_up_and_fail:
5527     errno = ECONNABORTED;
5528   tidy_up_and_fail:
5529     {
5530         dSAVE_ERRNO;
5531         if (sockets[0] != -1)
5532             PerlLIO_close(sockets[0]);
5533         if (sockets[1] != -1)
5534             PerlLIO_close(sockets[1]);
5535         RESTORE_ERRNO;
5536         return -1;
5537     }
5538 }
5539 #endif /*  EMULATE_SOCKETPAIR_UDP */
5540
5541 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET)
5542 int
5543 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
5544     /* Stevens says that family must be AF_LOCAL, protocol 0.
5545        I'm going to enforce that, then ignore it, and use TCP (or UDP).  */
5546     dTHX;
5547     int listener = -1;
5548     int connector = -1;
5549     int acceptor = -1;
5550     struct sockaddr_in listen_addr;
5551     struct sockaddr_in connect_addr;
5552     Sock_size_t size;
5553
5554     if (protocol
5555 #ifdef AF_UNIX
5556         || family != AF_UNIX
5557 #endif
5558     ) {
5559         errno = EAFNOSUPPORT;
5560         return -1;
5561     }
5562     if (!fd) {
5563         errno = EINVAL;
5564         return -1;
5565     }
5566
5567 #ifdef EMULATE_SOCKETPAIR_UDP
5568     if (type == SOCK_DGRAM)
5569         return S_socketpair_udp(fd);
5570 #endif
5571
5572     listener = PerlSock_socket(AF_INET, type, 0);
5573     if (listener == -1)
5574         return -1;
5575     memset(&listen_addr, 0, sizeof(listen_addr));
5576     listen_addr.sin_family = AF_INET;
5577     listen_addr.sin_addr.s_addr = htonl(INADDR_LOOPBACK);
5578     listen_addr.sin_port = 0;   /* kernel choses port.  */
5579     if (PerlSock_bind(listener, (struct sockaddr *) &listen_addr,
5580             sizeof(listen_addr)) == -1)
5581         goto tidy_up_and_fail;
5582     if (PerlSock_listen(listener, 1) == -1)
5583         goto tidy_up_and_fail;
5584
5585     connector = PerlSock_socket(AF_INET, type, 0);
5586     if (connector == -1)
5587         goto tidy_up_and_fail;
5588     /* We want to find out the port number to connect to.  */
5589     size = sizeof(connect_addr);
5590     if (PerlSock_getsockname(listener, (struct sockaddr *) &connect_addr,
5591             &size) == -1)
5592         goto tidy_up_and_fail;
5593     if (size != sizeof(connect_addr))
5594         goto abort_tidy_up_and_fail;
5595     if (PerlSock_connect(connector, (struct sockaddr *) &connect_addr,
5596             sizeof(connect_addr)) == -1)
5597         goto tidy_up_and_fail;
5598
5599     size = sizeof(listen_addr);
5600     acceptor = PerlSock_accept(listener, (struct sockaddr *) &listen_addr,
5601             &size);
5602     if (acceptor == -1)
5603         goto tidy_up_and_fail;
5604     if (size != sizeof(listen_addr))
5605         goto abort_tidy_up_and_fail;
5606     PerlLIO_close(listener);
5607     /* Now check we are talking to ourself by matching port and host on the
5608        two sockets.  */
5609     if (PerlSock_getsockname(connector, (struct sockaddr *) &connect_addr,
5610             &size) == -1)
5611         goto tidy_up_and_fail;
5612     if (size != sizeof(connect_addr)
5613             || listen_addr.sin_family != connect_addr.sin_family
5614             || listen_addr.sin_addr.s_addr != connect_addr.sin_addr.s_addr
5615             || listen_addr.sin_port != connect_addr.sin_port) {
5616         goto abort_tidy_up_and_fail;
5617     }
5618     fd[0] = connector;
5619     fd[1] = acceptor;
5620     return 0;
5621
5622   abort_tidy_up_and_fail:
5623 #ifdef ECONNABORTED
5624   errno = ECONNABORTED; /* This would be the standard thing to do. */
5625 #else
5626 #  ifdef ECONNREFUSED
5627   errno = ECONNREFUSED; /* E.g. Symbian does not have ECONNABORTED. */
5628 #  else
5629   errno = ETIMEDOUT;    /* Desperation time. */
5630 #  endif
5631 #endif
5632   tidy_up_and_fail:
5633     {
5634         dSAVE_ERRNO;
5635         if (listener != -1)
5636             PerlLIO_close(listener);
5637         if (connector != -1)
5638             PerlLIO_close(connector);
5639         if (acceptor != -1)
5640             PerlLIO_close(acceptor);
5641         RESTORE_ERRNO;
5642         return -1;
5643     }
5644 }
5645 #else
5646 /* In any case have a stub so that there's code corresponding
5647  * to the my_socketpair in global.sym. */
5648 int
5649 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
5650 #ifdef HAS_SOCKETPAIR
5651     return socketpair(family, type, protocol, fd);
5652 #else
5653     return -1;
5654 #endif
5655 }
5656 #endif
5657
5658 /*
5659
5660 =for apidoc sv_nosharing
5661
5662 Dummy routine which "shares" an SV when there is no sharing module present.
5663 Or "locks" it. Or "unlocks" it. In other words, ignores its single SV argument.
5664 Exists to avoid test for a NULL function pointer and because it could
5665 potentially warn under some level of strict-ness.
5666
5667 =cut
5668 */
5669
5670 void
5671 Perl_sv_nosharing(pTHX_ SV *sv)
5672 {
5673     PERL_UNUSED_CONTEXT;
5674     PERL_UNUSED_ARG(sv);
5675 }
5676
5677 /*
5678
5679 =for apidoc sv_destroyable
5680
5681 Dummy routine which reports that object can be destroyed when there is no
5682 sharing module present.  It ignores its single SV argument, and returns
5683 'true'.  Exists to avoid test for a NULL function pointer and because it
5684 could potentially warn under some level of strict-ness.
5685
5686 =cut
5687 */
5688
5689 bool
5690 Perl_sv_destroyable(pTHX_ SV *sv)
5691 {
5692     PERL_UNUSED_CONTEXT;
5693     PERL_UNUSED_ARG(sv);
5694     return TRUE;
5695 }
5696
5697 U32
5698 Perl_parse_unicode_opts(pTHX_ const char **popt)
5699 {
5700   const char *p = *popt;
5701   U32 opt = 0;
5702
5703   PERL_ARGS_ASSERT_PARSE_UNICODE_OPTS;
5704
5705   if (*p) {
5706        if (isDIGIT(*p)) {
5707             opt = (U32) atoi(p);
5708             while (isDIGIT(*p))
5709                 p++;
5710             if (*p && *p != '\n' && *p != '\r')
5711                  Perl_croak(aTHX_ "Unknown Unicode option letter '%c'", *p);
5712        }
5713        else {
5714             for (; *p; p++) {
5715                  switch (*p) {
5716                  case PERL_UNICODE_STDIN:
5717                       opt |= PERL_UNICODE_STDIN_FLAG;   break;
5718                  case PERL_UNICODE_STDOUT:
5719                       opt |= PERL_UNICODE_STDOUT_FLAG;  break;
5720                  case PERL_UNICODE_STDERR:
5721                       opt |= PERL_UNICODE_STDERR_FLAG;  break;
5722                  case PERL_UNICODE_STD:
5723                       opt |= PERL_UNICODE_STD_FLAG;     break;
5724                  case PERL_UNICODE_IN:
5725                       opt |= PERL_UNICODE_IN_FLAG;      break;
5726                  case PERL_UNICODE_OUT:
5727                       opt |= PERL_UNICODE_OUT_FLAG;     break;
5728                  case PERL_UNICODE_INOUT:
5729                       opt |= PERL_UNICODE_INOUT_FLAG;   break;
5730                  case PERL_UNICODE_LOCALE:
5731                       opt |= PERL_UNICODE_LOCALE_FLAG;  break;
5732                  case PERL_UNICODE_ARGV:
5733                       opt |= PERL_UNICODE_ARGV_FLAG;    break;
5734                  case PERL_UNICODE_UTF8CACHEASSERT:
5735                       opt |= PERL_UNICODE_UTF8CACHEASSERT_FLAG; break;
5736                  default:
5737                       if (*p != '\n' && *p != '\r')
5738                           Perl_croak(aTHX_
5739                                      "Unknown Unicode option letter '%c'", *p);
5740                  }
5741             }
5742        }
5743   }
5744   else
5745        opt = PERL_UNICODE_DEFAULT_FLAGS;
5746
5747   if (opt & ~PERL_UNICODE_ALL_FLAGS)
5748        Perl_croak(aTHX_ "Unknown Unicode option value %"UVuf,
5749                   (UV) (opt & ~PERL_UNICODE_ALL_FLAGS));
5750
5751   *popt = p;
5752
5753   return opt;
5754 }
5755
5756 U32
5757 Perl_seed(pTHX)
5758 {
5759     dVAR;
5760     /*
5761      * This is really just a quick hack which grabs various garbage
5762      * values.  It really should be a real hash algorithm which
5763      * spreads the effect of every input bit onto every output bit,
5764      * if someone who knows about such things would bother to write it.
5765      * Might be a good idea to add that function to CORE as well.
5766      * No numbers below come from careful analysis or anything here,
5767      * except they are primes and SEED_C1 > 1E6 to get a full-width
5768      * value from (tv_sec * SEED_C1 + tv_usec).  The multipliers should
5769      * probably be bigger too.
5770      */
5771 #if RANDBITS > 16
5772 #  define SEED_C1       1000003
5773 #define   SEED_C4       73819
5774 #else
5775 #  define SEED_C1       25747
5776 #define   SEED_C4       20639
5777 #endif
5778 #define   SEED_C2       3
5779 #define   SEED_C3       269
5780 #define   SEED_C5       26107
5781
5782 #ifndef PERL_NO_DEV_RANDOM
5783     int fd;
5784 #endif
5785     U32 u;
5786 #ifdef VMS
5787 #  include <starlet.h>
5788     /* when[] = (low 32 bits, high 32 bits) of time since epoch
5789      * in 100-ns units, typically incremented ever 10 ms.        */
5790     unsigned int when[2];
5791 #else
5792 #  ifdef HAS_GETTIMEOFDAY
5793     struct timeval when;
5794 #  else
5795     Time_t when;
5796 #  endif
5797 #endif
5798
5799 /* This test is an escape hatch, this symbol isn't set by Configure. */
5800 #ifndef PERL_NO_DEV_RANDOM
5801 #ifndef PERL_RANDOM_DEVICE
5802    /* /dev/random isn't used by default because reads from it will block
5803     * if there isn't enough entropy available.  You can compile with
5804     * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
5805     * is enough real entropy to fill the seed. */
5806 #  define PERL_RANDOM_DEVICE "/dev/urandom"
5807 #endif
5808     fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
5809     if (fd != -1) {
5810         if (PerlLIO_read(fd, (void*)&u, sizeof u) != sizeof u)
5811             u = 0;
5812         PerlLIO_close(fd);
5813         if (u)
5814             return u;
5815     }
5816 #endif
5817
5818 #ifdef VMS
5819     _ckvmssts(sys$gettim(when));
5820     u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
5821 #else
5822 #  ifdef HAS_GETTIMEOFDAY
5823     PerlProc_gettimeofday(&when,NULL);
5824     u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
5825 #  else
5826     (void)time(&when);
5827     u = (U32)SEED_C1 * when;
5828 #  endif
5829 #endif
5830     u += SEED_C3 * (U32)PerlProc_getpid();
5831     u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
5832 #ifndef PLAN9           /* XXX Plan9 assembler chokes on this; fix needed  */
5833     u += SEED_C5 * (U32)PTR2UV(&when);
5834 #endif
5835     return u;
5836 }
5837
5838 UV
5839 Perl_get_hash_seed(pTHX)
5840 {
5841     dVAR;
5842      const char *s = PerlEnv_getenv("PERL_HASH_SEED");
5843      UV myseed = 0;
5844
5845      if (s)
5846         while (isSPACE(*s))
5847             s++;
5848      if (s && isDIGIT(*s))
5849           myseed = (UV)Atoul(s);
5850      else
5851 #ifdef USE_HASH_SEED_EXPLICIT
5852      if (s)
5853 #endif
5854      {
5855           /* Compute a random seed */
5856           (void)seedDrand01((Rand_seed_t)seed());
5857           myseed = (UV)(Drand01() * (NV)UV_MAX);
5858 #if RANDBITS < (UVSIZE * 8)
5859           /* Since there are not enough randbits to to reach all
5860            * the bits of a UV, the low bits might need extra
5861            * help.  Sum in another random number that will
5862            * fill in the low bits. */
5863           myseed +=
5864                (UV)(Drand01() * (NV)((((UV)1) << ((UVSIZE * 8 - RANDBITS))) - 1));
5865 #endif /* RANDBITS < (UVSIZE * 8) */
5866           if (myseed == 0) { /* Superparanoia. */
5867               myseed = (UV)(Drand01() * (NV)UV_MAX); /* One more chance. */
5868               if (myseed == 0)
5869                   Perl_croak(aTHX_ "Your random numbers are not that random");
5870           }
5871      }
5872      PL_rehash_seed_set = TRUE;
5873
5874      return myseed;
5875 }
5876
5877 #ifdef USE_ITHREADS
5878 bool
5879 Perl_stashpv_hvname_match(pTHX_ const COP *c, const HV *hv)
5880 {
5881     const char * const stashpv = CopSTASHPV(c);
5882     const char * const name = HvNAME_get(hv);
5883     PERL_UNUSED_CONTEXT;
5884     PERL_ARGS_ASSERT_STASHPV_HVNAME_MATCH;
5885
5886     if (stashpv == name)
5887         return TRUE;
5888     if (stashpv && name)
5889         if (strEQ(stashpv, name))
5890             return TRUE;
5891     return FALSE;
5892 }
5893 #endif
5894
5895
5896 #ifdef PERL_GLOBAL_STRUCT
5897
5898 #define PERL_GLOBAL_STRUCT_INIT
5899 #include "opcode.h" /* the ppaddr and check */
5900
5901 struct perl_vars *
5902 Perl_init_global_struct(pTHX)
5903 {
5904     struct perl_vars *plvarsp = NULL;
5905 # ifdef PERL_GLOBAL_STRUCT
5906     const IV nppaddr = sizeof(Gppaddr)/sizeof(Perl_ppaddr_t);
5907     const IV ncheck  = sizeof(Gcheck) /sizeof(Perl_check_t);
5908 #  ifdef PERL_GLOBAL_STRUCT_PRIVATE
5909     /* PerlMem_malloc() because can't use even safesysmalloc() this early. */
5910     plvarsp = (struct perl_vars*)PerlMem_malloc(sizeof(struct perl_vars));
5911     if (!plvarsp)
5912         exit(1);
5913 #  else
5914     plvarsp = PL_VarsPtr;
5915 #  endif /* PERL_GLOBAL_STRUCT_PRIVATE */
5916 #  undef PERLVAR
5917 #  undef PERLVARA
5918 #  undef PERLVARI
5919 #  undef PERLVARIC
5920 #  undef PERLVARISC
5921 #  define PERLVAR(var,type) /**/
5922 #  define PERLVARA(var,n,type) /**/
5923 #  define PERLVARI(var,type,init) plvarsp->var = init;
5924 #  define PERLVARIC(var,type,init) plvarsp->var = init;
5925 #  define PERLVARISC(var,init) Copy(init, plvarsp->var, sizeof(init), char);
5926 #  include "perlvars.h"
5927 #  undef PERLVAR
5928 #  undef PERLVARA
5929 #  undef PERLVARI
5930 #  undef PERLVARIC
5931 #  undef PERLVARISC
5932 #  ifdef PERL_GLOBAL_STRUCT
5933     plvarsp->Gppaddr =
5934         (Perl_ppaddr_t*)
5935         PerlMem_malloc(nppaddr * sizeof(Perl_ppaddr_t));
5936     if (!plvarsp->Gppaddr)
5937         exit(1);
5938     plvarsp->Gcheck  =
5939         (Perl_check_t*)
5940         PerlMem_malloc(ncheck  * sizeof(Perl_check_t));
5941     if (!plvarsp->Gcheck)
5942         exit(1);
5943     Copy(Gppaddr, plvarsp->Gppaddr, nppaddr, Perl_ppaddr_t);
5944     Copy(Gcheck,  plvarsp->Gcheck,  ncheck,  Perl_check_t);
5945 #  endif
5946 #  ifdef PERL_SET_VARS
5947     PERL_SET_VARS(plvarsp);
5948 #  endif
5949 # undef PERL_GLOBAL_STRUCT_INIT
5950 # endif
5951     return plvarsp;
5952 }
5953
5954 #endif /* PERL_GLOBAL_STRUCT */
5955
5956 #ifdef PERL_GLOBAL_STRUCT
5957
5958 void
5959 Perl_free_global_struct(pTHX_ struct perl_vars *plvarsp)
5960 {
5961     PERL_ARGS_ASSERT_FREE_GLOBAL_STRUCT;
5962 # ifdef PERL_GLOBAL_STRUCT
5963 #  ifdef PERL_UNSET_VARS
5964     PERL_UNSET_VARS(plvarsp);
5965 #  endif
5966     free(plvarsp->Gppaddr);
5967     free(plvarsp->Gcheck);
5968 #  ifdef PERL_GLOBAL_STRUCT_PRIVATE
5969     free(plvarsp);
5970 #  endif
5971 # endif
5972 }
5973
5974 #endif /* PERL_GLOBAL_STRUCT */
5975
5976 #ifdef PERL_MEM_LOG
5977
5978 /* -DPERL_MEM_LOG: the Perl_mem_log_..() is compiled, including the
5979  * the default implementation, unless -DPERL_MEM_LOG_NOIMPL is also
5980  * given, and you supply your own implementation.
5981  *
5982  * The default implementation reads a single env var, PERL_MEM_LOG,
5983  * expecting one or more of the following:
5984  *
5985  *    \d+ - fd          fd to write to          : must be 1st (atoi)
5986  *    'm' - memlog      was PERL_MEM_LOG=1
5987  *    's' - svlog       was PERL_SV_LOG=1
5988  *    't' - timestamp   was PERL_MEM_LOG_TIMESTAMP=1
5989  *
5990  * This makes the logger controllable enough that it can reasonably be
5991  * added to the system perl.
5992  */
5993
5994 /* -DPERL_MEM_LOG_SPRINTF_BUF_SIZE=X: size of a (stack-allocated) buffer
5995  * the Perl_mem_log_...() will use (either via sprintf or snprintf).
5996  */
5997 #define PERL_MEM_LOG_SPRINTF_BUF_SIZE 128
5998
5999 /* -DPERL_MEM_LOG_FD=N: the file descriptor the Perl_mem_log_...()
6000  * writes to.  In the default logger, this is settable at runtime.
6001  */
6002 #ifndef PERL_MEM_LOG_FD
6003 #  define PERL_MEM_LOG_FD 2 /* If STDERR is too boring for you. */
6004 #endif
6005
6006 #ifndef PERL_MEM_LOG_NOIMPL
6007
6008 # ifdef DEBUG_LEAKING_SCALARS
6009 #   define SV_LOG_SERIAL_FMT        " [%lu]"
6010 #   define _SV_LOG_SERIAL_ARG(sv)   , (unsigned long) (sv)->sv_debug_serial
6011 # else
6012 #   define SV_LOG_SERIAL_FMT
6013 #   define _SV_LOG_SERIAL_ARG(sv)
6014 # endif
6015
6016 static void
6017 S_mem_log_common(enum mem_log_type mlt, const UV n,
6018                  const UV typesize, const char *type_name, const SV *sv,
6019                  Malloc_t oldalloc, Malloc_t newalloc,
6020                  const char *filename, const int linenumber,
6021                  const char *funcname)
6022 {
6023     const char *pmlenv;
6024
6025     PERL_ARGS_ASSERT_MEM_LOG_COMMON;
6026
6027     pmlenv = PerlEnv_getenv("PERL_MEM_LOG");
6028     if (!pmlenv)
6029         return;
6030     if (mlt < MLT_NEW_SV ? strchr(pmlenv,'m') : strchr(pmlenv,'s'))
6031     {
6032         /* We can't use SVs or PerlIO for obvious reasons,
6033          * so we'll use stdio and low-level IO instead. */
6034         char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE];
6035
6036 #   ifdef HAS_GETTIMEOFDAY
6037 #     define MEM_LOG_TIME_FMT   "%10d.%06d: "
6038 #     define MEM_LOG_TIME_ARG   (int)tv.tv_sec, (int)tv.tv_usec
6039         struct timeval tv;
6040         gettimeofday(&tv, 0);
6041 #   else
6042 #     define MEM_LOG_TIME_FMT   "%10d: "
6043 #     define MEM_LOG_TIME_ARG   (int)when
6044         Time_t when;
6045         (void)time(&when);
6046 #   endif
6047         /* If there are other OS specific ways of hires time than
6048          * gettimeofday() (see ext/Time-HiRes), the easiest way is
6049          * probably that they would be used to fill in the struct
6050          * timeval. */
6051         {
6052             STRLEN len;
6053             int fd = atoi(pmlenv);
6054             if (!fd)
6055                 fd = PERL_MEM_LOG_FD;
6056
6057             if (strchr(pmlenv, 't')) {
6058                 len = my_snprintf(buf, sizeof(buf),
6059                                 MEM_LOG_TIME_FMT, MEM_LOG_TIME_ARG);
6060                 PerlLIO_write(fd, buf, len);
6061             }
6062             switch (mlt) {
6063             case MLT_ALLOC:
6064                 len = my_snprintf(buf, sizeof(buf),
6065                         "alloc: %s:%d:%s: %"IVdf" %"UVuf
6066                         " %s = %"IVdf": %"UVxf"\n",
6067                         filename, linenumber, funcname, n, typesize,
6068                         type_name, n * typesize, PTR2UV(newalloc));
6069                 break;
6070             case MLT_REALLOC:
6071                 len = my_snprintf(buf, sizeof(buf),
6072                         "realloc: %s:%d:%s: %"IVdf" %"UVuf
6073                         " %s = %"IVdf": %"UVxf" -> %"UVxf"\n",
6074                         filename, linenumber, funcname, n, typesize,
6075                         type_name, n * typesize, PTR2UV(oldalloc),
6076                         PTR2UV(newalloc));
6077                 break;
6078             case MLT_FREE:
6079                 len = my_snprintf(buf, sizeof(buf),
6080                         "free: %s:%d:%s: %"UVxf"\n",
6081                         filename, linenumber, funcname,
6082                         PTR2UV(oldalloc));
6083                 break;
6084             case MLT_NEW_SV:
6085             case MLT_DEL_SV:
6086                 len = my_snprintf(buf, sizeof(buf),
6087                         "%s_SV: %s:%d:%s: %"UVxf SV_LOG_SERIAL_FMT "\n",
6088                         mlt == MLT_NEW_SV ? "new" : "del",
6089                         filename, linenumber, funcname,
6090                         PTR2UV(sv) _SV_LOG_SERIAL_ARG(sv));
6091                 break;
6092             default:
6093                 len = 0;
6094             }
6095             PerlLIO_write(fd, buf, len);
6096         }
6097     }
6098 }
6099 #endif /* !PERL_MEM_LOG_NOIMPL */
6100
6101 #ifndef PERL_MEM_LOG_NOIMPL
6102 # define \
6103     mem_log_common_if(alty, num, tysz, tynm, sv, oal, nal, flnm, ln, fnnm) \
6104     mem_log_common   (alty, num, tysz, tynm, sv, oal, nal, flnm, ln, fnnm)
6105 #else
6106 /* this is suboptimal, but bug compatible.  User is providing their
6107    own implemenation, but is getting these functions anyway, and they
6108    do nothing. But _NOIMPL users should be able to cope or fix */
6109 # define \
6110     mem_log_common_if(alty, num, tysz, tynm, u, oal, nal, flnm, ln, fnnm) \
6111     /* mem_log_common_if_PERL_MEM_LOG_NOIMPL */
6112 #endif
6113
6114 Malloc_t
6115 Perl_mem_log_alloc(const UV n, const UV typesize, const char *type_name,
6116                    Malloc_t newalloc,
6117                    const char *filename, const int linenumber,
6118                    const char *funcname)
6119 {
6120     mem_log_common_if(MLT_ALLOC, n, typesize, type_name,
6121                       NULL, NULL, newalloc,
6122                       filename, linenumber, funcname);
6123     return newalloc;
6124 }
6125
6126 Malloc_t
6127 Perl_mem_log_realloc(const UV n, const UV typesize, const char *type_name,
6128                      Malloc_t oldalloc, Malloc_t newalloc,
6129                      const char *filename, const int linenumber,
6130                      const char *funcname)
6131 {
6132     mem_log_common_if(MLT_REALLOC, n, typesize, type_name,
6133                       NULL, oldalloc, newalloc,
6134                       filename, linenumber, funcname);
6135     return newalloc;
6136 }
6137
6138 Malloc_t
6139 Perl_mem_log_free(Malloc_t oldalloc,
6140                   const char *filename, const int linenumber,
6141                   const char *funcname)
6142 {
6143     mem_log_common_if(MLT_FREE, 0, 0, "", NULL, oldalloc, NULL,
6144                       filename, linenumber, funcname);
6145     return oldalloc;
6146 }
6147
6148 void
6149 Perl_mem_log_new_sv(const SV *sv,
6150                     const char *filename, const int linenumber,
6151                     const char *funcname)
6152 {
6153     mem_log_common_if(MLT_NEW_SV, 0, 0, "", sv, NULL, NULL,
6154                       filename, linenumber, funcname);
6155 }
6156
6157 void
6158 Perl_mem_log_del_sv(const SV *sv,
6159                     const char *filename, const int linenumber,
6160                     const char *funcname)
6161 {
6162     mem_log_common_if(MLT_DEL_SV, 0, 0, "", sv, NULL, NULL,
6163                       filename, linenumber, funcname);
6164 }
6165
6166 #endif /* PERL_MEM_LOG */
6167
6168 /*
6169 =for apidoc my_sprintf
6170
6171 The C library C<sprintf>, wrapped if necessary, to ensure that it will return
6172 the length of the string written to the buffer. Only rare pre-ANSI systems
6173 need the wrapper function - usually this is a direct call to C<sprintf>.
6174
6175 =cut
6176 */
6177 #ifndef SPRINTF_RETURNS_STRLEN
6178 int
6179 Perl_my_sprintf(char *buffer, const char* pat, ...)
6180 {
6181     va_list args;
6182     PERL_ARGS_ASSERT_MY_SPRINTF;
6183     va_start(args, pat);
6184     vsprintf(buffer, pat, args);
6185     va_end(args);
6186     return strlen(buffer);
6187 }
6188 #endif
6189
6190 /*
6191 =for apidoc my_snprintf
6192
6193 The C library C<snprintf> functionality, if available and
6194 standards-compliant (uses C<vsnprintf>, actually).  However, if the
6195 C<vsnprintf> is not available, will unfortunately use the unsafe
6196 C<vsprintf> which can overrun the buffer (there is an overrun check,
6197 but that may be too late).  Consider using C<sv_vcatpvf> instead, or
6198 getting C<vsnprintf>.
6199
6200 =cut
6201 */
6202 int
6203 Perl_my_snprintf(char *buffer, const Size_t len, const char *format, ...)
6204 {
6205     dTHX;
6206     int retval;
6207     va_list ap;
6208     PERL_ARGS_ASSERT_MY_SNPRINTF;
6209     va_start(ap, format);
6210 #ifdef HAS_VSNPRINTF
6211     retval = vsnprintf(buffer, len, format, ap);
6212 #else
6213     retval = vsprintf(buffer, format, ap);
6214 #endif
6215     va_end(ap);
6216     /* vsnprintf() shows failure with >= len, vsprintf() with < 0 */
6217     if (retval < 0 || (len > 0 && (Size_t)retval >= len))
6218         Perl_croak(aTHX_ "panic: my_snprintf buffer overflow");
6219     return retval;
6220 }
6221
6222 /*
6223 =for apidoc my_vsnprintf
6224
6225 The C library C<vsnprintf> if available and standards-compliant.
6226 However, if if the C<vsnprintf> is not available, will unfortunately
6227 use the unsafe C<vsprintf> which can overrun the buffer (there is an
6228 overrun check, but that may be too late).  Consider using
6229 C<sv_vcatpvf> instead, or getting C<vsnprintf>.
6230
6231 =cut
6232 */
6233 int
6234 Perl_my_vsnprintf(char *buffer, const Size_t len, const char *format, va_list ap)
6235 {
6236     dTHX;
6237     int retval;
6238 #ifdef NEED_VA_COPY
6239     va_list apc;
6240
6241     PERL_ARGS_ASSERT_MY_VSNPRINTF;
6242
6243     Perl_va_copy(ap, apc);
6244 # ifdef HAS_VSNPRINTF
6245     retval = vsnprintf(buffer, len, format, apc);
6246 # else
6247     retval = vsprintf(buffer, format, apc);
6248 # endif
6249 #else
6250 # ifdef HAS_VSNPRINTF
6251     retval = vsnprintf(buffer, len, format, ap);
6252 # else
6253     retval = vsprintf(buffer, format, ap);
6254 # endif
6255 #endif /* #ifdef NEED_VA_COPY */
6256     /* vsnprintf() shows failure with >= len, vsprintf() with < 0 */
6257     if (retval < 0 || (len > 0 && (Size_t)retval >= len))
6258         Perl_croak(aTHX_ "panic: my_vsnprintf buffer overflow");
6259     return retval;
6260 }
6261
6262 void
6263 Perl_my_clearenv(pTHX)
6264 {
6265     dVAR;
6266 #if ! defined(PERL_MICRO)
6267 #  if defined(PERL_IMPLICIT_SYS) || defined(WIN32)
6268     PerlEnv_clearenv();
6269 #  else /* ! (PERL_IMPLICIT_SYS || WIN32) */
6270 #    if defined(USE_ENVIRON_ARRAY)
6271 #      if defined(USE_ITHREADS)
6272     /* only the parent thread can clobber the process environment */
6273     if (PL_curinterp == aTHX)
6274 #      endif /* USE_ITHREADS */
6275     {
6276 #      if ! defined(PERL_USE_SAFE_PUTENV)
6277     if ( !PL_use_safe_putenv) {
6278       I32 i;
6279       if (environ == PL_origenviron)
6280         environ = (char**)safesysmalloc(sizeof(char*));
6281       else
6282         for (i = 0; environ[i]; i++)
6283           (void)safesysfree(environ[i]);
6284     }
6285     environ[0] = NULL;
6286 #      else /* PERL_USE_SAFE_PUTENV */
6287 #        if defined(HAS_CLEARENV)
6288     (void)clearenv();
6289 #        elif defined(HAS_UNSETENV)
6290     int bsiz = 80; /* Most envvar names will be shorter than this. */
6291     int bufsiz = bsiz * sizeof(char); /* sizeof(char) paranoid? */
6292     char *buf = (char*)safesysmalloc(bufsiz);
6293     while (*environ != NULL) {
6294       char *e = strchr(*environ, '=');
6295       int l = e ? e - *environ : (int)strlen(*environ);
6296       if (bsiz < l + 1) {
6297         (void)safesysfree(buf);
6298         bsiz = l + 1; /* + 1 for the \0. */
6299         buf = (char*)safesysmalloc(bufsiz);
6300       }
6301       memcpy(buf, *environ, l);
6302       buf[l] = '\0';
6303       (void)unsetenv(buf);
6304     }
6305     (void)safesysfree(buf);
6306 #        else /* ! HAS_CLEARENV && ! HAS_UNSETENV */
6307     /* Just null environ and accept the leakage. */
6308     *environ = NULL;
6309 #        endif /* HAS_CLEARENV || HAS_UNSETENV */
6310 #      endif /* ! PERL_USE_SAFE_PUTENV */
6311     }
6312 #    endif /* USE_ENVIRON_ARRAY */
6313 #  endif /* PERL_IMPLICIT_SYS || WIN32 */
6314 #endif /* PERL_MICRO */
6315 }
6316
6317 #ifdef PERL_IMPLICIT_CONTEXT
6318
6319 /* Implements the MY_CXT_INIT macro. The first time a module is loaded,
6320 the global PL_my_cxt_index is incremented, and that value is assigned to
6321 that module's static my_cxt_index (who's address is passed as an arg).
6322 Then, for each interpreter this function is called for, it makes sure a
6323 void* slot is available to hang the static data off, by allocating or
6324 extending the interpreter's PL_my_cxt_list array */
6325
6326 #ifndef PERL_GLOBAL_STRUCT_PRIVATE
6327 void *
6328 Perl_my_cxt_init(pTHX_ int *index, size_t size)
6329 {
6330     dVAR;
6331     void *p;
6332     PERL_ARGS_ASSERT_MY_CXT_INIT;
6333     if (*index == -1) {
6334         /* this module hasn't been allocated an index yet */
6335 #if defined(USE_ITHREADS)
6336         MUTEX_LOCK(&PL_my_ctx_mutex);
6337 #endif
6338         *index = PL_my_cxt_index++;
6339 #if defined(USE_ITHREADS)
6340         MUTEX_UNLOCK(&PL_my_ctx_mutex);
6341 #endif
6342     }
6343
6344     /* make sure the array is big enough */
6345     if (PL_my_cxt_size <= *index) {
6346         if (PL_my_cxt_size) {
6347             while (PL_my_cxt_size <= *index)
6348                 PL_my_cxt_size *= 2;
6349             Renew(PL_my_cxt_list, PL_my_cxt_size, void *);
6350         }
6351         else {
6352             PL_my_cxt_size = 16;
6353             Newx(PL_my_cxt_list, PL_my_cxt_size, void *);
6354         }
6355     }
6356     /* newSV() allocates one more than needed */
6357     p = (void*)SvPVX(newSV(size-1));
6358     PL_my_cxt_list[*index] = p;
6359     Zero(p, size, char);
6360     return p;
6361 }
6362
6363 #else /* #ifndef PERL_GLOBAL_STRUCT_PRIVATE */
6364
6365 int
6366 Perl_my_cxt_index(pTHX_ const char *my_cxt_key)
6367 {
6368     dVAR;
6369     int index;
6370
6371     PERL_ARGS_ASSERT_MY_CXT_INDEX;
6372
6373     for (index = 0; index < PL_my_cxt_index; index++) {
6374         const char *key = PL_my_cxt_keys[index];
6375         /* try direct pointer compare first - there are chances to success,
6376          * and it's much faster.
6377          */
6378         if ((key == my_cxt_key) || strEQ(key, my_cxt_key))
6379             return index;
6380     }
6381     return -1;
6382 }
6383
6384 void *
6385 Perl_my_cxt_init(pTHX_ const char *my_cxt_key, size_t size)
6386 {
6387     dVAR;
6388     void *p;
6389     int index;
6390
6391     PERL_ARGS_ASSERT_MY_CXT_INIT;
6392
6393     index = Perl_my_cxt_index(aTHX_ my_cxt_key);
6394     if (index == -1) {
6395         /* this module hasn't been allocated an index yet */
6396 #if defined(USE_ITHREADS)
6397         MUTEX_LOCK(&PL_my_ctx_mutex);
6398 #endif
6399         index = PL_my_cxt_index++;
6400 #if defined(USE_ITHREADS)
6401         MUTEX_UNLOCK(&PL_my_ctx_mutex);
6402 #endif
6403     }
6404
6405     /* make sure the array is big enough */
6406     if (PL_my_cxt_size <= index) {
6407         int old_size = PL_my_cxt_size;
6408         int i;
6409         if (PL_my_cxt_size) {
6410             while (PL_my_cxt_size <= index)
6411                 PL_my_cxt_size *= 2;
6412             Renew(PL_my_cxt_list, PL_my_cxt_size, void *);
6413             Renew(PL_my_cxt_keys, PL_my_cxt_size, const char *);
6414         }
6415         else {
6416             PL_my_cxt_size = 16;
6417             Newx(PL_my_cxt_list, PL_my_cxt_size, void *);
6418             Newx(PL_my_cxt_keys, PL_my_cxt_size, const char *);
6419         }
6420         for (i = old_size; i < PL_my_cxt_size; i++) {
6421             PL_my_cxt_keys[i] = 0;
6422             PL_my_cxt_list[i] = 0;
6423         }
6424     }
6425     PL_my_cxt_keys[index] = my_cxt_key;
6426     /* newSV() allocates one more than needed */
6427     p = (void*)SvPVX(newSV(size-1));
6428     PL_my_cxt_list[index] = p;
6429     Zero(p, size, char);
6430     return p;
6431 }
6432 #endif /* #ifndef PERL_GLOBAL_STRUCT_PRIVATE */
6433 #endif /* PERL_IMPLICIT_CONTEXT */
6434
6435 #ifndef HAS_STRLCAT
6436 Size_t
6437 Perl_my_strlcat(char *dst, const char *src, Size_t size)
6438 {
6439     Size_t used, length, copy;
6440
6441     used = strlen(dst);
6442     length = strlen(src);
6443     if (size > 0 && used < size - 1) {
6444         copy = (length >= size - used) ? size - used - 1 : length;
6445         memcpy(dst + used, src, copy);
6446         dst[used + copy] = '\0';
6447     }
6448     return used + length;
6449 }
6450 #endif
6451
6452 #ifndef HAS_STRLCPY
6453 Size_t
6454 Perl_my_strlcpy(char *dst, const char *src, Size_t size)
6455 {
6456     Size_t length, copy;
6457
6458     length = strlen(src);
6459     if (size > 0) {
6460         copy = (length >= size) ? size - 1 : length;
6461         memcpy(dst, src, copy);
6462         dst[copy] = '\0';
6463     }
6464     return length;
6465 }
6466 #endif
6467
6468 #if defined(_MSC_VER) && (_MSC_VER >= 1300) && (_MSC_VER < 1400) && (WINVER < 0x0500)
6469 /* VC7 or 7.1, building with pre-VC7 runtime libraries. */
6470 long _ftol( double ); /* Defined by VC6 C libs. */
6471 long _ftol2( double dblSource ) { return _ftol( dblSource ); }
6472 #endif
6473
6474 void
6475 Perl_get_db_sub(pTHX_ SV **svp, CV *cv)
6476 {
6477     dVAR;
6478     SV * const dbsv = GvSVn(PL_DBsub);
6479     /* We do not care about using sv to call CV;
6480      * it's for informational purposes only.
6481      */
6482
6483     PERL_ARGS_ASSERT_GET_DB_SUB;
6484
6485     save_item(dbsv);
6486     if (!PERLDB_SUB_NN) {
6487         GV * const gv = CvGV(cv);
6488
6489         if ( svp && ((CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
6490              || strEQ(GvNAME(gv), "END")
6491              || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
6492                  !( (SvTYPE(*svp) == SVt_PVGV)
6493                     && (GvCV((const GV *)*svp) == cv) )))) {
6494             /* Use GV from the stack as a fallback. */
6495             /* GV is potentially non-unique, or contain different CV. */
6496             SV * const tmp = newRV(MUTABLE_SV(cv));
6497             sv_setsv(dbsv, tmp);
6498             SvREFCNT_dec(tmp);
6499         }
6500         else {
6501             gv_efullname3(dbsv, gv, NULL);
6502         }
6503     }
6504     else {
6505         const int type = SvTYPE(dbsv);
6506         if (type < SVt_PVIV && type != SVt_IV)
6507             sv_upgrade(dbsv, SVt_PVIV);
6508         (void)SvIOK_on(dbsv);
6509         SvIV_set(dbsv, PTR2IV(cv));     /* Do it the quickest way  */
6510     }
6511 }
6512
6513 int
6514 Perl_my_dirfd(pTHX_ DIR * dir) {
6515
6516     /* Most dirfd implementations have problems when passed NULL. */
6517     if(!dir)
6518         return -1;
6519 #ifdef HAS_DIRFD
6520     return dirfd(dir);
6521 #elif defined(HAS_DIR_DD_FD)
6522     return dir->dd_fd;
6523 #else
6524     Perl_die(aTHX_ PL_no_func, "dirfd");
6525    /* NOT REACHED */
6526     return 0;
6527 #endif
6528 }
6529
6530 REGEXP *
6531 Perl_get_re_arg(pTHX_ SV *sv) {
6532
6533     if (sv) {
6534         if (SvMAGICAL(sv))
6535             mg_get(sv);
6536         if (SvROK(sv))
6537             sv = MUTABLE_SV(SvRV(sv));
6538         if (SvTYPE(sv) == SVt_REGEXP)
6539             return (REGEXP*) sv;
6540     }
6541
6542     return NULL;
6543 }
6544
6545 /*
6546  * Local variables:
6547  * c-indentation-style: bsd
6548  * c-basic-offset: 4
6549  * indent-tabs-mode: t
6550  * End:
6551  *
6552  * ex: set ts=8 sts=4 sw=4 noet:
6553  */