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 #ifdef USE_PERLIO
  29 #include "perliol.h" /* For PerlIOUnix_refcnt */
  30 #endif
  31
  32 #ifndef PERL_MICRO
  33 #include <signal.h>
  34 #ifndef SIG_ERR
  35 # define SIG_ERR ((Sighandler_t) -1)
  36 #endif
  37 #endif
  38
  39 #ifdef __Lynx__
  40 /* Missing protos on LynxOS */
  41 int putenv(char *);
  42 #endif
  43
  44 #ifdef I_SYS_WAIT
  45 #  include <sys/wait.h>
  46 #endif
  47
  48 #ifdef HAS_SELECT
  49 # ifdef I_SYS_SELECT
  50 #  include <sys/select.h>
  51 # endif
  52 #endif
  53
  54 #define FLUSH
  55
  56 #if defined(HAS_FCNTL) && defined(F_SETFD) && !defined(FD_CLOEXEC)
  57 #  define FD_CLOEXEC 1                  /* NeXT needs this */
  58 #endif
  59
  60 /* NOTE:  Do not call the next three routines directly.  Use the macros
  61  * in handy.h, so that we can easily redefine everything to do tracking of
  62  * allocated hunks back to the original New to track down any memory leaks.
  63  * XXX This advice seems to be widely ignored :-(   --AD  August 1996.
  64  */
  65
  66 static char *
  67 S_write_no_mem(pTHX)
  68 {
  69     dVAR;
  70     /* Can't use PerlIO to write as it allocates memory */
  71     PerlLIO_write(PerlIO_fileno(Perl_error_log),
  72                   PL_no_mem, strlen(PL_no_mem));
  73     my_exit(1);
  74     NORETURN_FUNCTION_END;
  75 }
  76
  77 #if defined (DEBUGGING) || defined(PERL_IMPLICIT_SYS) || defined (PERL_TRACK_MEMPOOL)
  78 #  define ALWAYS_NEED_THX
  79 #endif
  80
  81 /* paranoid version of system's malloc() */
  82
  83 Malloc_t
  84 Perl_safesysmalloc(MEM_SIZE size)
  85 {
  86 #ifdef ALWAYS_NEED_THX
  87     dTHX;
  88 #endif
  89     Malloc_t ptr;
  90 #ifdef HAS_64K_LIMIT
  91         if (size > 0xffff) {
  92             PerlIO_printf(Perl_error_log,
  93                           "Allocation too large: %lx\n", size) FLUSH;
  94             my_exit(1);
  95         }
  96 #endif /* HAS_64K_LIMIT */
  97 #ifdef PERL_TRACK_MEMPOOL
  98     size += sTHX;
  99 #endif
 100 #ifdef DEBUGGING
 101     if ((long)size < 0)
 102         Perl_croak_nocontext("panic: malloc");
 103 #endif
 104     ptr = (Malloc_t)PerlMem_malloc(size?size:1);        /* malloc(0) is NASTY on our system */
 105     PERL_ALLOC_CHECK(ptr);
 106     if (ptr != NULL) {
 107 #ifdef PERL_TRACK_MEMPOOL
 108         struct perl_memory_debug_header *const header
 109             = (struct perl_memory_debug_header *)ptr;
 110 #endif
 111
 112 #ifdef PERL_POISON
 113         PoisonNew(((char *)ptr), size, char);
 114 #endif
 115
 116 #ifdef PERL_TRACK_MEMPOOL
 117         header->interpreter = aTHX;
 118         /* Link us into the list.  */
 119         header->prev = &PL_memory_debug_header;
 120         header->next = PL_memory_debug_header.next;
 121         PL_memory_debug_header.next = header;
 122         header->next->prev = header;
 123 #  ifdef PERL_POISON
 124         header->size = size;
 125 #  endif
 126         ptr = (Malloc_t)((char*)ptr+sTHX);
 127 #endif
 128         DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) malloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
 129         return ptr;
 130 }
 131     else {
 132 #ifndef ALWAYS_NEED_THX
 133         dTHX;
 134 #endif
 135         if (PL_nomemok)
 136             return NULL;
 137         else {
 138             return write_no_mem();
 139         }
 140     }
 141     /*NOTREACHED*/
 142 }
 143
 144 /* paranoid version of system's realloc() */
 145
 146 Malloc_t
 147 Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
 148 {
 149 #ifdef ALWAYS_NEED_THX
 150     dTHX;
 151 #endif
 152     Malloc_t ptr;
 153 #if !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) && !defined(PERL_MICRO)
 154     Malloc_t PerlMem_realloc();
 155 #endif /* !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) */
 156
 157 #ifdef HAS_64K_LIMIT
 158     if (size > 0xffff) {
 159         PerlIO_printf(Perl_error_log,
 160                       "Reallocation too large: %lx\n", size) FLUSH;
 161         my_exit(1);
 162     }
 163 #endif /* HAS_64K_LIMIT */
 164     if (!size) {
 165         safesysfree(where);
 166         return NULL;
 167     }
 168
 169     if (!where)
 170         return safesysmalloc(size);
 171 #ifdef PERL_TRACK_MEMPOOL
 172     where = (Malloc_t)((char*)where-sTHX);
 173     size += sTHX;
 174     {
 175         struct perl_memory_debug_header *const header
 176             = (struct perl_memory_debug_header *)where;
 177
 178         if (header->interpreter != aTHX) {
 179             Perl_croak_nocontext("panic: realloc from wrong pool");
 180         }
 181         assert(header->next->prev == header);
 182         assert(header->prev->next == header);
 183 #  ifdef PERL_POISON
 184         if (header->size > size) {
 185             const MEM_SIZE freed_up = header->size - size;
 186             char *start_of_freed = ((char *)where) + size;
 187             PoisonFree(start_of_freed, freed_up, char);
 188         }
 189         header->size = size;
 190 #  endif
 191     }
 192 #endif
 193 #ifdef DEBUGGING
 194     if ((long)size < 0)
 195         Perl_croak_nocontext("panic: realloc");
 196 #endif
 197     ptr = (Malloc_t)PerlMem_realloc(where,size);
 198     PERL_ALLOC_CHECK(ptr);
 199
 200     /* MUST do this fixup first, before doing ANYTHING else, as anything else
 201        might allocate memory/free/move memory, and until we do the fixup, it
 202        may well be chasing (and writing to) free memory.  */
 203 #ifdef PERL_TRACK_MEMPOOL
 204     if (ptr != NULL) {
 205         struct perl_memory_debug_header *const header
 206             = (struct perl_memory_debug_header *)ptr;
 207
 208 #  ifdef PERL_POISON
 209         if (header->size < size) {
 210             const MEM_SIZE fresh = size - header->size;
 211             char *start_of_fresh = ((char *)ptr) + size;
 212             PoisonNew(start_of_fresh, fresh, char);
 213         }
 214 #  endif
 215
 216         header->next->prev = header;
 217         header->prev->next = header;
 218
 219         ptr = (Malloc_t)((char*)ptr+sTHX);
 220     }
 221 #endif
 222
 223     /* In particular, must do that fixup above before logging anything via
 224      *printf(), as it can reallocate memory, which can cause SEGVs.  */
 225
 226     DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) rfree\n",PTR2UV(where),(long)PL_an++));
 227     DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) realloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
 228
 229
 230     if (ptr != NULL) {
 231         return ptr;
 232     }
 233     else {
 234 #ifndef ALWAYS_NEED_THX
 235         dTHX;
 236 #endif
 237         if (PL_nomemok)
 238             return NULL;
 239         else {
 240             return write_no_mem();
 241         }
 242     }
 243     /*NOTREACHED*/
 244 }
 245
 246 /* safe version of system's free() */
 247
 248 Free_t
 249 Perl_safesysfree(Malloc_t where)
 250 {
 251 #ifdef ALWAYS_NEED_THX
 252     dTHX;
 253 #else
 254     dVAR;
 255 #endif
 256     DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) free\n",PTR2UV(where),(long)PL_an++));
 257     if (where) {
 258 #ifdef PERL_TRACK_MEMPOOL
 259         where = (Malloc_t)((char*)where-sTHX);
 260         {
 261             struct perl_memory_debug_header *const header
 262                 = (struct perl_memory_debug_header *)where;
 263
 264             if (header->interpreter != aTHX) {
 265                 Perl_croak_nocontext("panic: free from wrong pool");
 266             }
 267             if (!header->prev) {
 268                 Perl_croak_nocontext("panic: duplicate free");
 269             }
 270             if (!(header->next) || header->next->prev != header
 271                 || header->prev->next != header) {
 272                 Perl_croak_nocontext("panic: bad free");
 273             }
 274             /* Unlink us from the chain.  */
 275             header->next->prev = header->prev;
 276             header->prev->next = header->next;
 277 #  ifdef PERL_POISON
 278             PoisonNew(where, header->size, char);
 279 #  endif
 280             /* Trigger the duplicate free warning.  */
 281             header->next = NULL;
 282         }
 283 #endif
 284         PerlMem_free(where);
 285     }
 286 }
 287
 288 /* safe version of system's calloc() */
 289
 290 Malloc_t
 291 Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size)
 292 {
 293 #ifdef ALWAYS_NEED_THX
 294     dTHX;
 295 #endif
 296     Malloc_t ptr;
 297 #if defined(PERL_TRACK_MEMPOOL) || defined(HAS_64K_LIMIT) || defined(DEBUGGING)
 298     MEM_SIZE total_size = 0;
 299 #endif
 300
 301     /* Even though calloc() for zero bytes is strange, be robust. */
 302     if (size && (count <= MEM_SIZE_MAX / size)) {
 303 #if defined(PERL_TRACK_MEMPOOL) || defined(HAS_64K_LIMIT) || defined(DEBUGGING)
 304         total_size = size * count;
 305 #endif
 306     }
 307     else
 308         Perl_croak_nocontext("%s", PL_memory_wrap);
 309 #ifdef PERL_TRACK_MEMPOOL
 310     if (sTHX <= MEM_SIZE_MAX - (MEM_SIZE)total_size)
 311         total_size += sTHX;
 312     else
 313         Perl_croak_nocontext("%s", PL_memory_wrap);
 314 #endif
 315 #ifdef HAS_64K_LIMIT
 316     if (total_size > 0xffff) {
 317         PerlIO_printf(Perl_error_log,
 318                       "Allocation too large: %lx\n", total_size) FLUSH;
 319         my_exit(1);
 320     }
 321 #endif /* HAS_64K_LIMIT */
 322 #ifdef DEBUGGING
 323     if ((long)size < 0 || (long)count < 0)
 324         Perl_croak_nocontext("panic: calloc");
 325 #endif
 326 #ifdef PERL_TRACK_MEMPOOL
 327     /* Have to use malloc() because we've added some space for our tracking
 328        header.  */
 329     /* malloc(0) is non-portable. */
 330     ptr = (Malloc_t)PerlMem_malloc(total_size ? total_size : 1);
 331 #else
 332     /* Use calloc() because it might save a memset() if the memory is fresh
 333        and clean from the OS.  */
 334     if (count && size)
 335         ptr = (Malloc_t)PerlMem_calloc(count, size);
 336     else /* calloc(0) is non-portable. */
 337         ptr = (Malloc_t)PerlMem_calloc(count ? count : 1, size ? size : 1);
 338 #endif
 339     PERL_ALLOC_CHECK(ptr);
 340     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));
 341     if (ptr != NULL) {
 342 #ifdef PERL_TRACK_MEMPOOL
 343         {
 344             struct perl_memory_debug_header *const header
 345                 = (struct perl_memory_debug_header *)ptr;
 346
 347             memset((void*)ptr, 0, total_size);
 348             header->interpreter = aTHX;
 349             /* Link us into the list.  */
 350             header->prev = &PL_memory_debug_header;
 351             header->next = PL_memory_debug_header.next;
 352             PL_memory_debug_header.next = header;
 353             header->next->prev = header;
 354 #  ifdef PERL_POISON
 355             header->size = total_size;
 356 #  endif
 357             ptr = (Malloc_t)((char*)ptr+sTHX);
 358         }
 359 #endif
 360         return ptr;
 361     }
 362     else {
 363 #ifndef ALWAYS_NEED_THX
 364         dTHX;
 365 #endif
 366         if (PL_nomemok)
 367             return NULL;
 368         return write_no_mem();
 369     }
 370 }
 371
 372 /* These must be defined when not using Perl's malloc for binary
 373  * compatibility */
 374
 375 #ifndef MYMALLOC
 376
 377 Malloc_t Perl_malloc (MEM_SIZE nbytes)
 378 {
 379     dTHXs;
 380     return (Malloc_t)PerlMem_malloc(nbytes);
 381 }
 382
 383 Malloc_t Perl_calloc (MEM_SIZE elements, MEM_SIZE size)
 384 {
 385     dTHXs;
 386     return (Malloc_t)PerlMem_calloc(elements, size);
 387 }
 388
 389 Malloc_t Perl_realloc (Malloc_t where, MEM_SIZE nbytes)
 390 {
 391     dTHXs;
 392     return (Malloc_t)PerlMem_realloc(where, nbytes);
 393 }
 394
 395 Free_t   Perl_mfree (Malloc_t where)
 396 {
 397     dTHXs;
 398     PerlMem_free(where);
 399 }
 400
 401 #endif
 402
 403 /* copy a string up to some (non-backslashed) delimiter, if any */
 404
 405 char *
 406 Perl_delimcpy(register char *to, register const char *toend, register const char *from, register const char *fromend, register int delim, I32 *retlen)
 407 {
 408     register I32 tolen;
 409
 410     PERL_ARGS_ASSERT_DELIMCPY;
 411
 412     for (tolen = 0; from < fromend; from++, tolen++) {
 413         if (*from == '\\') {
 414             if (from[1] != delim) {
 415                 if (to < toend)
 416                     *to++ = *from;
 417                 tolen++;
 418             }
 419             from++;
 420         }
 421         else if (*from == delim)
 422             break;
 423         if (to < toend)
 424             *to++ = *from;
 425     }
 426     if (to < toend)
 427         *to = '\0';
 428     *retlen = tolen;
 429     return (char *)from;
 430 }
 431
 432 /* return ptr to little string in big string, NULL if not found */
 433 /* This routine was donated by Corey Satten. */
 434
 435 char *
 436 Perl_instr(register const char *big, register const char *little)
 437 {
 438     register I32 first;
 439
 440     PERL_ARGS_ASSERT_INSTR;
 441
 442     if (!little)
 443         return (char*)big;
 444     first = *little++;
 445     if (!first)
 446         return (char*)big;
 447     while (*big) {
 448         register const char *s, *x;
 449         if (*big++ != first)
 450             continue;
 451         for (x=big,s=little; *s; /**/ ) {
 452             if (!*x)
 453                 return NULL;
 454             if (*s != *x)
 455                 break;
 456             else {
 457                 s++;
 458                 x++;
 459             }
 460         }
 461         if (!*s)
 462             return (char*)(big-1);
 463     }
 464     return NULL;
 465 }
 466
 467 /* same as instr but allow embedded nulls */
 468
 469 char *
 470 Perl_ninstr(const char *big, const char *bigend, const char *little, const char *lend)
 471 {
 472     PERL_ARGS_ASSERT_NINSTR;
 473     if (little >= lend)
 474         return (char*)big;
 475     {
 476         const char first = *little;
 477         const char *s, *x;
 478         bigend -= lend - little++;
 479     OUTER:
 480         while (big <= bigend) {
 481             if (*big++ == first) {
 482                 for (x=big,s=little; s < lend; x++,s++) {
 483                     if (*s != *x)
 484                         goto OUTER;
 485                 }
 486                 return (char*)(big-1);
 487             }
 488         }
 489     }
 490     return NULL;
 491 }
 492
 493 /* reverse of the above--find last substring */
 494
 495 char *
 496 Perl_rninstr(register const char *big, const char *bigend, const char *little, const char *lend)
 497 {
 498     register const char *bigbeg;
 499     register const I32 first = *little;
 500     register const char * const littleend = lend;
 501
 502     PERL_ARGS_ASSERT_RNINSTR;
 503
 504     if (little >= littleend)
 505         return (char*)bigend;
 506     bigbeg = big;
 507     big = bigend - (littleend - little++);
 508     while (big >= bigbeg) {
 509         register const char *s, *x;
 510         if (*big-- != first)
 511             continue;
 512         for (x=big+2,s=little; s < littleend; /**/ ) {
 513             if (*s != *x)
 514                 break;
 515             else {
 516                 x++;
 517                 s++;
 518             }
 519         }
 520         if (s >= littleend)
 521             return (char*)(big+1);
 522     }
 523     return NULL;
 524 }
 525
 526 /* As a space optimization, we do not compile tables for strings of length
 527    0 and 1, and for strings of length 2 unless FBMcf_TAIL.  These are
 528    special-cased in fbm_instr().
 529
 530    If FBMcf_TAIL, the table is created as if the string has a trailing \n. */
 531
 532 /*
 533 =head1 Miscellaneous Functions
 534
 535 =for apidoc fbm_compile
 536
 537 Analyses the string in order to make fast searches on it using fbm_instr()
 538 -- the Boyer-Moore algorithm.
 539
 540 =cut
 541 */
 542
 543 void
 544 Perl_fbm_compile(pTHX_ SV *sv, U32 flags)
 545 {
 546     dVAR;
 547     register const U8 *s;
 548     register U32 i;
 549     STRLEN len;
 550     U32 rarest = 0;
 551     U32 frequency = 256;
 552
 553     PERL_ARGS_ASSERT_FBM_COMPILE;
 554
 555     if (flags & FBMcf_TAIL) {
 556         MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL;
 557         sv_catpvs(sv, "\n");            /* Taken into account in fbm_instr() */
 558         if (mg && mg->mg_len >= 0)
 559             mg->mg_len++;
 560     }
 561     s = (U8*)SvPV_force_mutable(sv, len);
 562     if (len == 0)               /* TAIL might be on a zero-length string. */
 563         return;
 564     SvUPGRADE(sv, SVt_PVGV);
 565     SvIOK_off(sv);
 566     SvNOK_off(sv);
 567     SvVALID_on(sv);
 568     if (len > 2) {
 569         const unsigned char *sb;
 570         const U8 mlen = (len>255) ? 255 : (U8)len;
 571         register U8 *table;
 572
 573         Sv_Grow(sv, len + 256 + PERL_FBM_TABLE_OFFSET);
 574         table
 575             = (unsigned char*)(SvPVX_mutable(sv) + len + PERL_FBM_TABLE_OFFSET);
 576         s = table - 1 - PERL_FBM_TABLE_OFFSET;  /* last char */
 577         memset((void*)table, mlen, 256);
 578         i = 0;
 579         sb = s - mlen + 1;                      /* first char (maybe) */
 580         while (s >= sb) {
 581             if (table[*s] == mlen)
 582                 table[*s] = (U8)i;
 583             s--, i++;
 584         }
 585     } else {
 586         Sv_Grow(sv, len + PERL_FBM_TABLE_OFFSET);
 587     }
 588     sv_magic(sv, NULL, PERL_MAGIC_bm, NULL, 0); /* deep magic */
 589
 590     s = (const unsigned char*)(SvPVX_const(sv));        /* deeper magic */
 591     for (i = 0; i < len; i++) {
 592         if (PL_freq[s[i]] < frequency) {
 593             rarest = i;
 594             frequency = PL_freq[s[i]];
 595         }
 596     }
 597     BmFLAGS(sv) = (U8)flags;
 598     BmRARE(sv) = s[rarest];
 599     BmPREVIOUS(sv) = rarest;
 600     BmUSEFUL(sv) = 100;                 /* Initial value */
 601     if (flags & FBMcf_TAIL)
 602         SvTAIL_on(sv);
 603     DEBUG_r(PerlIO_printf(Perl_debug_log, "rarest char %c at %lu\n",
 604                           BmRARE(sv),(unsigned long)BmPREVIOUS(sv)));
 605 }
 606
 607 /* If SvTAIL(littlestr), it has a fake '\n' at end. */
 608 /* If SvTAIL is actually due to \Z or \z, this gives false positives
 609    if multiline */
 610
 611 /*
 612 =for apidoc fbm_instr
 613
 614 Returns the location of the SV in the string delimited by C<str> and
 615 C<strend>.  It returns C<NULL> if the string can't be found.  The C<sv>
 616 does not have to be fbm_compiled, but the search will not be as fast
 617 then.
 618
 619 =cut
 620 */
 621
 622 char *
 623 Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *littlestr, U32 flags)
 624 {
 625     register unsigned char *s;
 626     STRLEN l;
 627     register const unsigned char *little
 628         = (const unsigned char *)SvPV_const(littlestr,l);
 629     register STRLEN littlelen = l;
 630     register const I32 multiline = flags & FBMrf_MULTILINE;
 631
 632     PERL_ARGS_ASSERT_FBM_INSTR;
 633
 634     if ((STRLEN)(bigend - big) < littlelen) {
 635         if ( SvTAIL(littlestr)
 636              && ((STRLEN)(bigend - big) == littlelen - 1)
 637              && (littlelen == 1
 638                  || (*big == *little &&
 639                      memEQ((char *)big, (char *)little, littlelen - 1))))
 640             return (char*)big;
 641         return NULL;
 642     }
 643
 644     if (littlelen <= 2) {               /* Special-cased */
 645
 646         if (littlelen == 1) {
 647             if (SvTAIL(littlestr) && !multiline) { /* Anchor only! */
 648                 /* Know that bigend != big.  */
 649                 if (bigend[-1] == '\n')
 650                     return (char *)(bigend - 1);
 651                 return (char *) bigend;
 652             }
 653             s = big;
 654             while (s < bigend) {
 655                 if (*s == *little)
 656                     return (char *)s;
 657                 s++;
 658             }
 659             if (SvTAIL(littlestr))
 660                 return (char *) bigend;
 661             return NULL;
 662         }
 663         if (!littlelen)
 664             return (char*)big;          /* Cannot be SvTAIL! */
 665
 666         /* littlelen is 2 */
 667         if (SvTAIL(littlestr) && !multiline) {
 668             if (bigend[-1] == '\n' && bigend[-2] == *little)
 669                 return (char*)bigend - 2;
 670             if (bigend[-1] == *little)
 671                 return (char*)bigend - 1;
 672             return NULL;
 673         }
 674         {
 675             /* This should be better than FBM if c1 == c2, and almost
 676                as good otherwise: maybe better since we do less indirection.
 677                And we save a lot of memory by caching no table. */
 678             const unsigned char c1 = little[0];
 679             const unsigned char c2 = little[1];
 680
 681             s = big + 1;
 682             bigend--;
 683             if (c1 != c2) {
 684                 while (s <= bigend) {
 685                     if (s[0] == c2) {
 686                         if (s[-1] == c1)
 687                             return (char*)s - 1;
 688                         s += 2;
 689                         continue;
 690                     }
 691                   next_chars:
 692                     if (s[0] == c1) {
 693                         if (s == bigend)
 694                             goto check_1char_anchor;
 695                         if (s[1] == c2)
 696                             return (char*)s;
 697                         else {
 698                             s++;
 699                             goto next_chars;
 700                         }
 701                     }
 702                     else
 703                         s += 2;
 704                 }
 705                 goto check_1char_anchor;
 706             }
 707             /* Now c1 == c2 */
 708             while (s <= bigend) {
 709                 if (s[0] == c1) {
 710                     if (s[-1] == c1)
 711                         return (char*)s - 1;
 712                     if (s == bigend)
 713                         goto check_1char_anchor;
 714                     if (s[1] == c1)
 715                         return (char*)s;
 716                     s += 3;
 717                 }
 718                 else
 719                     s += 2;
 720             }
 721         }
 722       check_1char_anchor:               /* One char and anchor! */
 723         if (SvTAIL(littlestr) && (*bigend == *little))
 724             return (char *)bigend;      /* bigend is already decremented. */
 725         return NULL;
 726     }
 727     if (SvTAIL(littlestr) && !multiline) {      /* tail anchored? */
 728         s = bigend - littlelen;
 729         if (s >= big && bigend[-1] == '\n' && *s == *little
 730             /* Automatically of length > 2 */
 731             && memEQ((char*)s + 1, (char*)little + 1, littlelen - 2))
 732         {
 733             return (char*)s;            /* how sweet it is */
 734         }
 735         if (s[1] == *little
 736             && memEQ((char*)s + 2, (char*)little + 1, littlelen - 2))
 737         {
 738             return (char*)s + 1;        /* how sweet it is */
 739         }
 740         return NULL;
 741     }
 742     if (!SvVALID(littlestr)) {
 743         char * const b = ninstr((char*)big,(char*)bigend,
 744                          (char*)little, (char*)little + littlelen);
 745
 746         if (!b && SvTAIL(littlestr)) {  /* Automatically multiline!  */
 747             /* Chop \n from littlestr: */
 748             s = bigend - littlelen + 1;
 749             if (*s == *little
 750                 && memEQ((char*)s + 1, (char*)little + 1, littlelen - 2))
 751             {
 752                 return (char*)s;
 753             }
 754             return NULL;
 755         }
 756         return b;
 757     }
 758
 759     /* Do actual FBM.  */
 760     if (littlelen > (STRLEN)(bigend - big))
 761         return NULL;
 762
 763     {
 764         register const unsigned char * const table
 765             = little + littlelen + PERL_FBM_TABLE_OFFSET;
 766         register const unsigned char *oldlittle;
 767
 768         --littlelen;                    /* Last char found by table lookup */
 769
 770         s = big + littlelen;
 771         little += littlelen;            /* last char */
 772         oldlittle = little;
 773         if (s < bigend) {
 774             register I32 tmp;
 775
 776           top2:
 777             if ((tmp = table[*s])) {
 778                 if ((s += tmp) < bigend)
 779                     goto top2;
 780                 goto check_end;
 781             }
 782             else {              /* less expensive than calling strncmp() */
 783                 register unsigned char * const olds = s;
 784
 785                 tmp = littlelen;
 786
 787                 while (tmp--) {
 788                     if (*--s == *--little)
 789                         continue;
 790                     s = olds + 1;       /* here we pay the price for failure */
 791                     little = oldlittle;
 792                     if (s < bigend)     /* fake up continue to outer loop */
 793                         goto top2;
 794                     goto check_end;
 795                 }
 796                 return (char *)s;
 797             }
 798         }
 799       check_end:
 800         if ( s == bigend
 801              && (BmFLAGS(littlestr) & FBMcf_TAIL)
 802              && memEQ((char *)(bigend - littlelen),
 803                       (char *)(oldlittle - littlelen), littlelen) )
 804             return (char*)bigend - littlelen;
 805         return NULL;
 806     }
 807 }
 808
 809 /* start_shift, end_shift are positive quantities which give offsets
 810    of ends of some substring of bigstr.
 811    If "last" we want the last occurrence.
 812    old_posp is the way of communication between consequent calls if
 813    the next call needs to find the .
 814    The initial *old_posp should be -1.
 815
 816    Note that we take into account SvTAIL, so one can get extra
 817    optimizations if _ALL flag is set.
 818  */
 819
 820 /* If SvTAIL is actually due to \Z or \z, this gives false positives
 821    if PL_multiline.  In fact if !PL_multiline the authoritative answer
 822    is not supported yet. */
 823
 824 char *
 825 Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift, I32 *old_posp, I32 last)
 826 {
 827     dVAR;
 828     register const unsigned char *big;
 829     register I32 pos;
 830     register I32 previous;
 831     register I32 first;
 832     register const unsigned char *little;
 833     register I32 stop_pos;
 834     register const unsigned char *littleend;
 835     I32 found = 0;
 836
 837     PERL_ARGS_ASSERT_SCREAMINSTR;
 838
 839     assert(SvTYPE(littlestr) == SVt_PVGV);
 840     assert(SvVALID(littlestr));
 841
 842     if (*old_posp == -1
 843         ? (pos = PL_screamfirst[BmRARE(littlestr)]) < 0
 844         : (((pos = *old_posp), pos += PL_screamnext[pos]) == 0)) {
 845       cant_find:
 846         if ( BmRARE(littlestr) == '\n'
 847              && BmPREVIOUS(littlestr) == SvCUR(littlestr) - 1) {
 848             little = (const unsigned char *)(SvPVX_const(littlestr));
 849             littleend = little + SvCUR(littlestr);
 850             first = *little++;
 851             goto check_tail;
 852         }
 853         return NULL;
 854     }
 855
 856     little = (const unsigned char *)(SvPVX_const(littlestr));
 857     littleend = little + SvCUR(littlestr);
 858     first = *little++;
 859     /* The value of pos we can start at: */
 860     previous = BmPREVIOUS(littlestr);
 861     big = (const unsigned char *)(SvPVX_const(bigstr));
 862     /* The value of pos we can stop at: */
 863     stop_pos = SvCUR(bigstr) - end_shift - (SvCUR(littlestr) - 1 - previous);
 864     if (previous + start_shift > stop_pos) {
 865 /*
 866   stop_pos does not include SvTAIL in the count, so this check is incorrect
 867   (I think) - see [ID 20010618.006] and t/op/study.t. HVDS 2001/06/19
 868 */
 869 #if 0
 870         if (previous + start_shift == stop_pos + 1) /* A fake '\n'? */
 871             goto check_tail;
 872 #endif
 873         return NULL;
 874     }
 875     while (pos < previous + start_shift) {
 876         if (!(pos += PL_screamnext[pos]))
 877             goto cant_find;
 878     }
 879     big -= previous;
 880     do {
 881         register const unsigned char *s, *x;
 882         if (pos >= stop_pos) break;
 883         if (big[pos] != first)
 884             continue;
 885         for (x=big+pos+1,s=little; s < littleend; /**/ ) {
 886             if (*s++ != *x++) {
 887                 s--;
 888                 break;
 889             }
 890         }
 891         if (s == littleend) {
 892             *old_posp = pos;
 893             if (!last) return (char *)(big+pos);
 894             found = 1;
 895         }
 896     } while ( pos += PL_screamnext[pos] );
 897     if (last && found)
 898         return (char *)(big+(*old_posp));
 899   check_tail:
 900     if (!SvTAIL(littlestr) || (end_shift > 0))
 901         return NULL;
 902     /* Ignore the trailing "\n".  This code is not microoptimized */
 903     big = (const unsigned char *)(SvPVX_const(bigstr) + SvCUR(bigstr));
 904     stop_pos = littleend - little;      /* Actual littlestr len */
 905     if (stop_pos == 0)
 906         return (char*)big;
 907     big -= stop_pos;
 908     if (*big == first
 909         && ((stop_pos == 1) ||
 910             memEQ((char *)(big + 1), (char *)little, stop_pos - 1)))
 911         return (char*)big;
 912     return NULL;
 913 }
 914
 915 /*
 916 =for apidoc foldEQ
 917
 918 Returns true if the leading len bytes of the strings s1 and s2 are the same
 919 case-insensitively; false otherwise.  Uppercase and lowercase ASCII range bytes
 920 match themselves and their opposite case counterparts.  Non-cased and non-ASCII
 921 range bytes match only themselves.
 922
 923 =cut
 924 */
 925
 926
 927 I32
 928 Perl_foldEQ(const char *s1, const char *s2, register I32 len)
 929 {
 930     register const U8 *a = (const U8 *)s1;
 931     register const U8 *b = (const U8 *)s2;
 932
 933     PERL_ARGS_ASSERT_FOLDEQ;
 934
 935     while (len--) {
 936         if (*a != *b && *a != PL_fold[*b])
 937             return 0;
 938         a++,b++;
 939     }
 940     return 1;
 941 }
 942 I32
 943 Perl_foldEQ_latin1(const char *s1, const char *s2, register I32 len)
 944 {
 945     /* Compare non-utf8 using Unicode (Latin1) semantics.  Does not work on
 946      * MICRO_SIGN, LATIN_SMALL_LETTER_SHARP_S, nor
 947      * LATIN_SMALL_LETTER_Y_WITH_DIAERESIS, and does not check for these.  Nor
 948      * does it check that the strings each have at least 'len' characters */
 949
 950     register const U8 *a = (const U8 *)s1;
 951     register const U8 *b = (const U8 *)s2;
 952
 953     PERL_ARGS_ASSERT_FOLDEQ_LATIN1;
 954
 955     while (len--) {
 956         if (*a != *b && *a != PL_fold_latin1[*b]) {
 957             return 0;
 958         }
 959         a++, b++;
 960     }
 961     return 1;
 962 }
 963
 964 /*
 965 =for apidoc foldEQ_locale
 966
 967 Returns true if the leading len bytes of the strings s1 and s2 are the same
 968 case-insensitively in the current locale; false otherwise.
 969
 970 =cut
 971 */
 972
 973 I32
 974 Perl_foldEQ_locale(const char *s1, const char *s2, register I32 len)
 975 {
 976     dVAR;
 977     register const U8 *a = (const U8 *)s1;
 978     register const U8 *b = (const U8 *)s2;
 979
 980     PERL_ARGS_ASSERT_FOLDEQ_LOCALE;
 981
 982     while (len--) {
 983         if (*a != *b && *a != PL_fold_locale[*b])
 984             return 0;
 985         a++,b++;
 986     }
 987     return 1;
 988 }
 989
 990 /* copy a string to a safe spot */
 991
 992 /*
 993 =head1 Memory Management
 994
 995 =for apidoc savepv
 996
 997 Perl's version of C<strdup()>. Returns a pointer to a newly allocated
 998 string which is a duplicate of C<pv>. The size of the string is
 999 determined by C<strlen()>. The memory allocated for the new string can
1000 be freed with the C<Safefree()> function.
1001
1002 =cut
1003 */
1004
1005 char *
1006 Perl_savepv(pTHX_ const char *pv)
1007 {
1008     PERL_UNUSED_CONTEXT;
1009     if (!pv)
1010         return NULL;
1011     else {
1012         char *newaddr;
1013         const STRLEN pvlen = strlen(pv)+1;
1014         Newx(newaddr, pvlen, char);
1015         return (char*)memcpy(newaddr, pv, pvlen);
1016     }
1017 }
1018
1019 /* same thing but with a known length */
1020
1021 /*
1022 =for apidoc savepvn
1023
1024 Perl's version of what C<strndup()> would be if it existed. Returns a
1025 pointer to a newly allocated string which is a duplicate of the first
1026 C<len> bytes from C<pv>, plus a trailing NUL byte. The memory allocated for
1027 the new string can be freed with the C<Safefree()> function.
1028
1029 =cut
1030 */
1031
1032 char *
1033 Perl_savepvn(pTHX_ const char *pv, register I32 len)
1034 {
1035     register char *newaddr;
1036     PERL_UNUSED_CONTEXT;
1037
1038     Newx(newaddr,len+1,char);
1039     /* Give a meaning to NULL pointer mainly for the use in sv_magic() */
1040     if (pv) {
1041         /* might not be null terminated */
1042         newaddr[len] = '\0';
1043         return (char *) CopyD(pv,newaddr,len,char);
1044     }
1045     else {
1046         return (char *) ZeroD(newaddr,len+1,char);
1047     }
1048 }
1049
1050 /*
1051 =for apidoc savesharedpv
1052
1053 A version of C<savepv()> which allocates the duplicate string in memory
1054 which is shared between threads.
1055
1056 =cut
1057 */
1058 char *
1059 Perl_savesharedpv(pTHX_ const char *pv)
1060 {
1061     register char *newaddr;
1062     STRLEN pvlen;
1063     if (!pv)
1064         return NULL;
1065
1066     pvlen = strlen(pv)+1;
1067     newaddr = (char*)PerlMemShared_malloc(pvlen);
1068     if (!newaddr) {
1069         return write_no_mem();
1070     }
1071     return (char*)memcpy(newaddr, pv, pvlen);
1072 }
1073
1074 /*
1075 =for apidoc savesharedpvn
1076
1077 A version of C<savepvn()> which allocates the duplicate string in memory
1078 which is shared between threads. (With the specific difference that a NULL
1079 pointer is not acceptable)
1080
1081 =cut
1082 */
1083 char *
1084 Perl_savesharedpvn(pTHX_ const char *const pv, const STRLEN len)
1085 {
1086     char *const newaddr = (char*)PerlMemShared_malloc(len + 1);
1087
1088     PERL_ARGS_ASSERT_SAVESHAREDPVN;
1089
1090     if (!newaddr) {
1091         return write_no_mem();
1092     }
1093     newaddr[len] = '\0';
1094     return (char*)memcpy(newaddr, pv, len);
1095 }
1096
1097 /*
1098 =for apidoc savesvpv
1099
1100 A version of C<savepv()>/C<savepvn()> which gets the string to duplicate from
1101 the passed in SV using C<SvPV()>
1102
1103 =cut
1104 */
1105
1106 char *
1107 Perl_savesvpv(pTHX_ SV *sv)
1108 {
1109     STRLEN len;
1110     const char * const pv = SvPV_const(sv, len);
1111     register char *newaddr;
1112
1113     PERL_ARGS_ASSERT_SAVESVPV;
1114
1115     ++len;
1116     Newx(newaddr,len,char);
1117     return (char *) CopyD(pv,newaddr,len,char);
1118 }
1119
1120 /*
1121 =for apidoc savesharedsvpv
1122
1123 A version of C<savesharedpv()> which allocates the duplicate string in
1124 memory which is shared between threads.
1125
1126 =cut
1127 */
1128
1129 char *
1130 Perl_savesharedsvpv(pTHX_ SV *sv)
1131 {
1132     STRLEN len;
1133     const char * const pv = SvPV_const(sv, len);
1134
1135     PERL_ARGS_ASSERT_SAVESHAREDSVPV;
1136
1137     return savesharedpvn(pv, len);
1138 }
1139
1140 /* the SV for Perl_form() and mess() is not kept in an arena */
1141
1142 STATIC SV *
1143 S_mess_alloc(pTHX)
1144 {
1145     dVAR;
1146     SV *sv;
1147     XPVMG *any;
1148
1149     if (PL_phase != PERL_PHASE_DESTRUCT)
1150         return newSVpvs_flags("", SVs_TEMP);
1151
1152     if (PL_mess_sv)
1153         return PL_mess_sv;
1154
1155     /* Create as PVMG now, to avoid any upgrading later */
1156     Newx(sv, 1, SV);
1157     Newxz(any, 1, XPVMG);
1158     SvFLAGS(sv) = SVt_PVMG;
1159     SvANY(sv) = (void*)any;
1160     SvPV_set(sv, NULL);
1161     SvREFCNT(sv) = 1 << 30; /* practically infinite */
1162     PL_mess_sv = sv;
1163     return sv;
1164 }
1165
1166 #if defined(PERL_IMPLICIT_CONTEXT)
1167 char *
1168 Perl_form_nocontext(const char* pat, ...)
1169 {
1170     dTHX;
1171     char *retval;
1172     va_list args;
1173     PERL_ARGS_ASSERT_FORM_NOCONTEXT;
1174     va_start(args, pat);
1175     retval = vform(pat, &args);
1176     va_end(args);
1177     return retval;
1178 }
1179 #endif /* PERL_IMPLICIT_CONTEXT */
1180
1181 /*
1182 =head1 Miscellaneous Functions
1183 =for apidoc form
1184
1185 Takes a sprintf-style format pattern and conventional
1186 (non-SV) arguments and returns the formatted string.
1187
1188     (char *) Perl_form(pTHX_ const char* pat, ...)
1189
1190 can be used any place a string (char *) is required:
1191
1192     char * s = Perl_form("%d.%d",major,minor);
1193
1194 Uses a single private buffer so if you want to format several strings you
1195 must explicitly copy the earlier strings away (and free the copies when you
1196 are done).
1197
1198 =cut
1199 */
1200
1201 char *
1202 Perl_form(pTHX_ const char* pat, ...)
1203 {
1204     char *retval;
1205     va_list args;
1206     PERL_ARGS_ASSERT_FORM;
1207     va_start(args, pat);
1208     retval = vform(pat, &args);
1209     va_end(args);
1210     return retval;
1211 }
1212
1213 char *
1214 Perl_vform(pTHX_ const char *pat, va_list *args)
1215 {
1216     SV * const sv = mess_alloc();
1217     PERL_ARGS_ASSERT_VFORM;
1218     sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
1219     return SvPVX(sv);
1220 }
1221
1222 /*
1223 =for apidoc Am|SV *|mess|const char *pat|...
1224
1225 Take a sprintf-style format pattern and argument list.  These are used to
1226 generate a string message.  If the message does not end with a newline,
1227 then it will be extended with some indication of the current location
1228 in the code, as described for L</mess_sv>.
1229
1230 Normally, the resulting message is returned in a new mortal SV.
1231 During global destruction a single SV may be shared between uses of
1232 this function.
1233
1234 =cut
1235 */
1236
1237 #if defined(PERL_IMPLICIT_CONTEXT)
1238 SV *
1239 Perl_mess_nocontext(const char *pat, ...)
1240 {
1241     dTHX;
1242     SV *retval;
1243     va_list args;
1244     PERL_ARGS_ASSERT_MESS_NOCONTEXT;
1245     va_start(args, pat);
1246     retval = vmess(pat, &args);
1247     va_end(args);
1248     return retval;
1249 }
1250 #endif /* PERL_IMPLICIT_CONTEXT */
1251
1252 SV *
1253 Perl_mess(pTHX_ const char *pat, ...)
1254 {
1255     SV *retval;
1256     va_list args;
1257     PERL_ARGS_ASSERT_MESS;
1258     va_start(args, pat);
1259     retval = vmess(pat, &args);
1260     va_end(args);
1261     return retval;
1262 }
1263
1264 STATIC const COP*
1265 S_closest_cop(pTHX_ const COP *cop, const OP *o)
1266 {
1267     dVAR;
1268     /* Look for PL_op starting from o.  cop is the last COP we've seen. */
1269
1270     PERL_ARGS_ASSERT_CLOSEST_COP;
1271
1272     if (!o || o == PL_op)
1273         return cop;
1274
1275     if (o->op_flags & OPf_KIDS) {
1276         const OP *kid;
1277         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
1278             const COP *new_cop;
1279
1280             /* If the OP_NEXTSTATE has been optimised away we can still use it
1281              * the get the file and line number. */
1282
1283             if (kid->op_type == OP_NULL && kid->op_targ == OP_NEXTSTATE)
1284                 cop = (const COP *)kid;
1285
1286             /* Keep searching, and return when we've found something. */
1287
1288             new_cop = closest_cop(cop, kid);
1289             if (new_cop)
1290                 return new_cop;
1291         }
1292     }
1293
1294     /* Nothing found. */
1295
1296     return NULL;
1297 }
1298
1299 /*
1300 =for apidoc Am|SV *|mess_sv|SV *basemsg|bool consume
1301
1302 Expands a message, intended for the user, to include an indication of
1303 the current location in the code, if the message does not already appear
1304 to be complete.
1305
1306 C<basemsg> is the initial message or object.  If it is a reference, it
1307 will be used as-is and will be the result of this function.  Otherwise it
1308 is used as a string, and if it already ends with a newline, it is taken
1309 to be complete, and the result of this function will be the same string.
1310 If the message does not end with a newline, then a segment such as C<at
1311 foo.pl line 37> will be appended, and possibly other clauses indicating
1312 the current state of execution.  The resulting message will end with a
1313 dot and a newline.
1314
1315 Normally, the resulting message is returned in a new mortal SV.
1316 During global destruction a single SV may be shared between uses of this
1317 function.  If C<consume> is true, then the function is permitted (but not
1318 required) to modify and return C<basemsg> instead of allocating a new SV.
1319
1320 =cut
1321 */
1322
1323 SV *
1324 Perl_mess_sv(pTHX_ SV *basemsg, bool consume)
1325 {
1326     dVAR;
1327     SV *sv;
1328
1329     PERL_ARGS_ASSERT_MESS_SV;
1330
1331     if (SvROK(basemsg)) {
1332         if (consume) {
1333             sv = basemsg;
1334         }
1335         else {
1336             sv = mess_alloc();
1337             sv_setsv(sv, basemsg);
1338         }
1339         return sv;
1340     }
1341
1342     if (SvPOK(basemsg) && consume) {
1343         sv = basemsg;
1344     }
1345     else {
1346         sv = mess_alloc();
1347         sv_copypv(sv, basemsg);
1348     }
1349
1350     if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') {
1351         /*
1352          * Try and find the file and line for PL_op.  This will usually be
1353          * PL_curcop, but it might be a cop that has been optimised away.  We
1354          * can try to find such a cop by searching through the optree starting
1355          * from the sibling of PL_curcop.
1356          */
1357
1358         const COP *cop = closest_cop(PL_curcop, PL_curcop->op_sibling);
1359         if (!cop)
1360             cop = PL_curcop;
1361
1362         if (CopLINE(cop))
1363             Perl_sv_catpvf(aTHX_ sv, " at %s line %"IVdf,
1364             OutCopFILE(cop), (IV)CopLINE(cop));
1365         /* Seems that GvIO() can be untrustworthy during global destruction. */
1366         if (GvIO(PL_last_in_gv) && (SvTYPE(GvIOp(PL_last_in_gv)) == SVt_PVIO)
1367                 && IoLINES(GvIOp(PL_last_in_gv)))
1368         {
1369             const bool line_mode = (RsSIMPLE(PL_rs) &&
1370                               SvCUR(PL_rs) == 1 && *SvPVX_const(PL_rs) == '\n');
1371             Perl_sv_catpvf(aTHX_ sv, ", <%s> %s %"IVdf,
1372                            PL_last_in_gv == PL_argvgv ? "" : GvNAME(PL_last_in_gv),
1373                            line_mode ? "line" : "chunk",
1374                            (IV)IoLINES(GvIOp(PL_last_in_gv)));
1375         }
1376         if (PL_phase == PERL_PHASE_DESTRUCT)
1377             sv_catpvs(sv, " during global destruction");
1378         sv_catpvs(sv, ".\n");
1379     }
1380     return sv;
1381 }
1382
1383 /*
1384 =for apidoc Am|SV *|vmess|const char *pat|va_list *args
1385
1386 C<pat> and C<args> are a sprintf-style format pattern and encapsulated
1387 argument list.  These are used to generate a string message.  If the
1388 message does not end with a newline, then it will be extended with
1389 some indication of the current location in the code, as described for
1390 L</mess_sv>.
1391
1392 Normally, the resulting message is returned in a new mortal SV.
1393 During global destruction a single SV may be shared between uses of
1394 this function.
1395
1396 =cut
1397 */
1398
1399 SV *
1400 Perl_vmess(pTHX_ const char *pat, va_list *args)
1401 {
1402     dVAR;
1403     SV * const sv = mess_alloc();
1404
1405     PERL_ARGS_ASSERT_VMESS;
1406
1407     sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
1408     return mess_sv(sv, 1);
1409 }
1410
1411 void
1412 Perl_write_to_stderr(pTHX_ SV* msv)
1413 {
1414     dVAR;
1415     IO *io;
1416     MAGIC *mg;
1417
1418     PERL_ARGS_ASSERT_WRITE_TO_STDERR;
1419
1420     if (PL_stderrgv && SvREFCNT(PL_stderrgv)
1421         && (io = GvIO(PL_stderrgv))
1422         && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
1423         Perl_magic_methcall(aTHX_ MUTABLE_SV(io), mg, "PRINT",
1424                             G_SCALAR | G_DISCARD | G_WRITING_TO_STDERR, 1, msv);
1425     else {
1426 #ifdef USE_SFIO
1427         /* SFIO can really mess with your errno */
1428         dSAVED_ERRNO;
1429 #endif
1430         PerlIO * const serr = Perl_error_log;
1431
1432         do_print(msv, serr);
1433         (void)PerlIO_flush(serr);
1434 #ifdef USE_SFIO
1435         RESTORE_ERRNO;
1436 #endif
1437     }
1438 }
1439
1440 /*
1441 =head1 Warning and Dieing
1442 */
1443
1444 /* Common code used in dieing and warning */
1445
1446 STATIC SV *
1447 S_with_queued_errors(pTHX_ SV *ex)
1448 {
1449     PERL_ARGS_ASSERT_WITH_QUEUED_ERRORS;
1450     if (PL_errors && SvCUR(PL_errors) && !SvROK(ex)) {
1451         sv_catsv(PL_errors, ex);
1452         ex = sv_mortalcopy(PL_errors);
1453         SvCUR_set(PL_errors, 0);
1454     }
1455     return ex;
1456 }
1457
1458 STATIC bool
1459 S_invoke_exception_hook(pTHX_ SV *ex, bool warn)
1460 {
1461     dVAR;
1462     HV *stash;
1463     GV *gv;
1464     CV *cv;
1465     SV **const hook = warn ? &PL_warnhook : &PL_diehook;
1466     /* sv_2cv might call Perl_croak() or Perl_warner() */
1467     SV * const oldhook = *hook;
1468
1469     if (!oldhook)
1470         return FALSE;
1471
1472     ENTER;
1473     SAVESPTR(*hook);
1474     *hook = NULL;
1475     cv = sv_2cv(oldhook, &stash, &gv, 0);
1476     LEAVE;
1477     if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
1478         dSP;
1479         SV *exarg;
1480
1481         ENTER;
1482         save_re_context();
1483         if (warn) {
1484             SAVESPTR(*hook);
1485             *hook = NULL;
1486         }
1487         exarg = newSVsv(ex);
1488         SvREADONLY_on(exarg);
1489         SAVEFREESV(exarg);
1490
1491         PUSHSTACKi(warn ? PERLSI_WARNHOOK : PERLSI_DIEHOOK);
1492         PUSHMARK(SP);
1493         XPUSHs(exarg);
1494         PUTBACK;
1495         call_sv(MUTABLE_SV(cv), G_DISCARD);
1496         POPSTACK;
1497         LEAVE;
1498         return TRUE;
1499     }
1500     return FALSE;
1501 }
1502
1503 /*
1504 =for apidoc Am|OP *|die_sv|SV *baseex
1505
1506 Behaves the same as L</croak_sv>, except for the return type.
1507 It should be used only where the C<OP *> return type is required.
1508 The function never actually returns.
1509
1510 =cut
1511 */
1512
1513 OP *
1514 Perl_die_sv(pTHX_ SV *baseex)
1515 {
1516     PERL_ARGS_ASSERT_DIE_SV;
1517     croak_sv(baseex);
1518     /* NOTREACHED */
1519     return NULL;
1520 }
1521
1522 /*
1523 =for apidoc Am|OP *|die|const char *pat|...
1524
1525 Behaves the same as L</croak>, except for the return type.
1526 It should be used only where the C<OP *> return type is required.
1527 The function never actually returns.
1528
1529 =cut
1530 */
1531
1532 #if defined(PERL_IMPLICIT_CONTEXT)
1533 OP *
1534 Perl_die_nocontext(const char* pat, ...)
1535 {
1536     dTHX;
1537     va_list args;
1538     va_start(args, pat);
1539     vcroak(pat, &args);
1540     /* NOTREACHED */
1541     va_end(args);
1542     return NULL;
1543 }
1544 #endif /* PERL_IMPLICIT_CONTEXT */
1545
1546 OP *
1547 Perl_die(pTHX_ const char* pat, ...)
1548 {
1549     va_list args;
1550     va_start(args, pat);
1551     vcroak(pat, &args);
1552     /* NOTREACHED */
1553     va_end(args);
1554     return NULL;
1555 }
1556
1557 /*
1558 =for apidoc Am|void|croak_sv|SV *baseex
1559
1560 This is an XS interface to Perl's C<die> function.
1561
1562 C<baseex> is the error message or object.  If it is a reference, it
1563 will be used as-is.  Otherwise it is used as a string, and if it does
1564 not end with a newline then it will be extended with some indication of
1565 the current location in the code, as described for L</mess_sv>.
1566
1567 The error message or object will be used as an exception, by default
1568 returning control to the nearest enclosing C<eval>, but subject to
1569 modification by a C<$SIG{__DIE__}> handler.  In any case, the C<croak_sv>
1570 function never returns normally.
1571
1572 To die with a simple string message, the L</croak> function may be
1573 more convenient.
1574
1575 =cut
1576 */
1577
1578 void
1579 Perl_croak_sv(pTHX_ SV *baseex)
1580 {
1581     SV *ex = with_queued_errors(mess_sv(baseex, 0));
1582     PERL_ARGS_ASSERT_CROAK_SV;
1583     invoke_exception_hook(ex, FALSE);
1584     die_unwind(ex);
1585 }
1586
1587 /*
1588 =for apidoc Am|void|vcroak|const char *pat|va_list *args
1589
1590 This is an XS interface to Perl's C<die> function.
1591
1592 C<pat> and C<args> are a sprintf-style format pattern and encapsulated
1593 argument list.  These are used to generate a string message.  If the
1594 message does not end with a newline, then it will be extended with
1595 some indication of the current location in the code, as described for
1596 L</mess_sv>.
1597
1598 The error message will be used as an exception, by default
1599 returning control to the nearest enclosing C<eval>, but subject to
1600 modification by a C<$SIG{__DIE__}> handler.  In any case, the C<croak>
1601 function never returns normally.
1602
1603 For historical reasons, if C<pat> is null then the contents of C<ERRSV>
1604 (C<$@>) will be used as an error message or object instead of building an
1605 error message from arguments.  If you want to throw a non-string object,
1606 or build an error message in an SV yourself, it is preferable to use
1607 the L</croak_sv> function, which does not involve clobbering C<ERRSV>.
1608
1609 =cut
1610 */
1611
1612 void
1613 Perl_vcroak(pTHX_ const char* pat, va_list *args)
1614 {
1615     SV *ex = with_queued_errors(pat ? vmess(pat, args) : mess_sv(ERRSV, 0));
1616     invoke_exception_hook(ex, FALSE);
1617     die_unwind(ex);
1618 }
1619
1620 /*
1621 =for apidoc Am|void|croak|const char *pat|...
1622
1623 This is an XS interface to Perl's C<die> function.
1624
1625 Take a sprintf-style format pattern and argument list.  These are used to
1626 generate a string message.  If the message does not end with a newline,
1627 then it will be extended with some indication of the current location
1628 in the code, as described for L</mess_sv>.
1629
1630 The error message will be used as an exception, by default
1631 returning control to the nearest enclosing C<eval>, but subject to
1632 modification by a C<$SIG{__DIE__}> handler.  In any case, the C<croak>
1633 function never returns normally.
1634
1635 For historical reasons, if C<pat> is null then the contents of C<ERRSV>
1636 (C<$@>) will be used as an error message or object instead of building an
1637 error message from arguments.  If you want to throw a non-string object,
1638 or build an error message in an SV yourself, it is preferable to use
1639 the L</croak_sv> function, which does not involve clobbering C<ERRSV>.
1640
1641 =cut
1642 */
1643
1644 #if defined(PERL_IMPLICIT_CONTEXT)
1645 void
1646 Perl_croak_nocontext(const char *pat, ...)
1647 {
1648     dTHX;
1649     va_list args;
1650     va_start(args, pat);
1651     vcroak(pat, &args);
1652     /* NOTREACHED */
1653     va_end(args);
1654 }
1655 #endif /* PERL_IMPLICIT_CONTEXT */
1656
1657 void
1658 Perl_croak(pTHX_ const char *pat, ...)
1659 {
1660     va_list args;
1661     va_start(args, pat);
1662     vcroak(pat, &args);
1663     /* NOTREACHED */
1664     va_end(args);
1665 }
1666
1667 /*
1668 =for apidoc Am|void|croak_no_modify
1669
1670 Exactly equivalent to C<Perl_croak(aTHX_ "%s", PL_no_modify)>, but generates
1671 terser object code than using C<Perl_croak>. Less code used on exception code
1672 paths reduces CPU cache pressure.
1673
1674 =cut
1675 */
1676
1677 void
1678 Perl_croak_no_modify(pTHX)
1679 {
1680     Perl_croak(aTHX_ "%s", PL_no_modify);
1681 }
1682
1683 /*
1684 =for apidoc Am|void|warn_sv|SV *baseex
1685
1686 This is an XS interface to Perl's C<warn> function.
1687
1688 C<baseex> is the error message or object.  If it is a reference, it
1689 will be used as-is.  Otherwise it is used as a string, and if it does
1690 not end with a newline then it will be extended with some indication of
1691 the current location in the code, as described for L</mess_sv>.
1692
1693 The error message or object will by default be written to standard error,
1694 but this is subject to modification by a C<$SIG{__WARN__}> handler.
1695
1696 To warn with a simple string message, the L</warn> function may be
1697 more convenient.
1698
1699 =cut
1700 */
1701
1702 void
1703 Perl_warn_sv(pTHX_ SV *baseex)
1704 {
1705     SV *ex = mess_sv(baseex, 0);
1706     PERL_ARGS_ASSERT_WARN_SV;
1707     if (!invoke_exception_hook(ex, TRUE))
1708         write_to_stderr(ex);
1709 }
1710
1711 /*
1712 =for apidoc Am|void|vwarn|const char *pat|va_list *args
1713
1714 This is an XS interface to Perl's C<warn> function.
1715
1716 C<pat> and C<args> are a sprintf-style format pattern and encapsulated
1717 argument list.  These are used to generate a string message.  If the
1718 message does not end with a newline, then it will be extended with
1719 some indication of the current location in the code, as described for
1720 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</vcroak>, C<pat> is not permitted to be null.
1726
1727 =cut
1728 */
1729
1730 void
1731 Perl_vwarn(pTHX_ const char* pat, va_list *args)
1732 {
1733     SV *ex = vmess(pat, args);
1734     PERL_ARGS_ASSERT_VWARN;
1735     if (!invoke_exception_hook(ex, TRUE))
1736         write_to_stderr(ex);
1737 }
1738
1739 /*
1740 =for apidoc Am|void|warn|const char *pat|...
1741
1742 This is an XS interface to Perl's C<warn> function.
1743
1744 Take a sprintf-style format pattern and argument list.  These are used to
1745 generate a string message.  If the message does not end with a newline,
1746 then it will be extended with some indication of the current location
1747 in the code, as described for L</mess_sv>.
1748
1749 The error message or object will by default be written to standard error,
1750 but this is subject to modification by a C<$SIG{__WARN__}> handler.
1751
1752 Unlike with L</croak>, C<pat> is not permitted to be null.
1753
1754 =cut
1755 */
1756
1757 #if defined(PERL_IMPLICIT_CONTEXT)
1758 void
1759 Perl_warn_nocontext(const char *pat, ...)
1760 {
1761     dTHX;
1762     va_list args;
1763     PERL_ARGS_ASSERT_WARN_NOCONTEXT;
1764     va_start(args, pat);
1765     vwarn(pat, &args);
1766     va_end(args);
1767 }
1768 #endif /* PERL_IMPLICIT_CONTEXT */
1769
1770 void
1771 Perl_warn(pTHX_ const char *pat, ...)
1772 {
1773     va_list args;
1774     PERL_ARGS_ASSERT_WARN;
1775     va_start(args, pat);
1776     vwarn(pat, &args);
1777     va_end(args);
1778 }
1779
1780 #if defined(PERL_IMPLICIT_CONTEXT)
1781 void
1782 Perl_warner_nocontext(U32 err, const char *pat, ...)
1783 {
1784     dTHX;
1785     va_list args;
1786     PERL_ARGS_ASSERT_WARNER_NOCONTEXT;
1787     va_start(args, pat);
1788     vwarner(err, pat, &args);
1789     va_end(args);
1790 }
1791 #endif /* PERL_IMPLICIT_CONTEXT */
1792
1793 void
1794 Perl_ck_warner_d(pTHX_ U32 err, const char* pat, ...)
1795 {
1796     PERL_ARGS_ASSERT_CK_WARNER_D;
1797
1798     if (Perl_ckwarn_d(aTHX_ err)) {
1799         va_list args;
1800         va_start(args, pat);
1801         vwarner(err, pat, &args);
1802         va_end(args);
1803     }
1804 }
1805
1806 void
1807 Perl_ck_warner(pTHX_ U32 err, const char* pat, ...)
1808 {
1809     PERL_ARGS_ASSERT_CK_WARNER;
1810
1811     if (Perl_ckwarn(aTHX_ err)) {
1812         va_list args;
1813         va_start(args, pat);
1814         vwarner(err, pat, &args);
1815         va_end(args);
1816     }
1817 }
1818
1819 void
1820 Perl_warner(pTHX_ U32  err, const char* pat,...)
1821 {
1822     va_list args;
1823     PERL_ARGS_ASSERT_WARNER;
1824     va_start(args, pat);
1825     vwarner(err, pat, &args);
1826     va_end(args);
1827 }
1828
1829 void
1830 Perl_vwarner(pTHX_ U32  err, const char* pat, va_list* args)
1831 {
1832     dVAR;
1833     PERL_ARGS_ASSERT_VWARNER;
1834     if (PL_warnhook == PERL_WARNHOOK_FATAL || ckDEAD(err)) {
1835         SV * const msv = vmess(pat, args);
1836
1837         invoke_exception_hook(msv, FALSE);
1838         die_unwind(msv);
1839     }
1840     else {
1841         Perl_vwarn(aTHX_ pat, args);
1842     }
1843 }
1844
1845 /* implements the ckWARN? macros */
1846
1847 bool
1848 Perl_ckwarn(pTHX_ U32 w)
1849 {
1850     dVAR;
1851     /* If lexical warnings have not been set, use $^W.  */
1852     if (isLEXWARN_off)
1853         return PL_dowarn & G_WARN_ON;
1854
1855     return ckwarn_common(w);
1856 }
1857
1858 /* implements the ckWARN?_d macro */
1859
1860 bool
1861 Perl_ckwarn_d(pTHX_ U32 w)
1862 {
1863     dVAR;
1864     /* If lexical warnings have not been set then default classes warn.  */
1865     if (isLEXWARN_off)
1866         return TRUE;
1867
1868     return ckwarn_common(w);
1869 }
1870
1871 static bool
1872 S_ckwarn_common(pTHX_ U32 w)
1873 {
1874     if (PL_curcop->cop_warnings == pWARN_ALL)
1875         return TRUE;
1876
1877     if (PL_curcop->cop_warnings == pWARN_NONE)
1878         return FALSE;
1879
1880     /* Check the assumption that at least the first slot is non-zero.  */
1881     assert(unpackWARN1(w));
1882
1883     /* Check the assumption that it is valid to stop as soon as a zero slot is
1884        seen.  */
1885     if (!unpackWARN2(w)) {
1886         assert(!unpackWARN3(w));
1887         assert(!unpackWARN4(w));
1888     } else if (!unpackWARN3(w)) {
1889         assert(!unpackWARN4(w));
1890     }
1891
1892     /* Right, dealt with all the special cases, which are implemented as non-
1893        pointers, so there is a pointer to a real warnings mask.  */
1894     do {
1895         if (isWARN_on(PL_curcop->cop_warnings, unpackWARN1(w)))
1896             return TRUE;
1897     } while (w >>= WARNshift);
1898
1899     return FALSE;
1900 }
1901
1902 /* Set buffer=NULL to get a new one.  */
1903 STRLEN *
1904 Perl_new_warnings_bitfield(pTHX_ STRLEN *buffer, const char *const bits,
1905                            STRLEN size) {
1906     const MEM_SIZE len_wanted = sizeof(STRLEN) + size;
1907     PERL_UNUSED_CONTEXT;
1908     PERL_ARGS_ASSERT_NEW_WARNINGS_BITFIELD;
1909
1910     buffer = (STRLEN*)
1911         (specialWARN(buffer) ?
1912          PerlMemShared_malloc(len_wanted) :
1913          PerlMemShared_realloc(buffer, len_wanted));
1914     buffer[0] = size;
1915     Copy(bits, (buffer + 1), size, char);
1916     return buffer;
1917 }
1918
1919 /* since we've already done strlen() for both nam and val
1920  * we can use that info to make things faster than
1921  * sprintf(s, "%s=%s", nam, val)
1922  */
1923 #define my_setenv_format(s, nam, nlen, val, vlen) \
1924    Copy(nam, s, nlen, char); \
1925    *(s+nlen) = '='; \
1926    Copy(val, s+(nlen+1), vlen, char); \
1927    *(s+(nlen+1+vlen)) = '\0'
1928
1929 #ifdef USE_ENVIRON_ARRAY
1930        /* VMS' my_setenv() is in vms.c */
1931 #if !defined(WIN32) && !defined(NETWARE)
1932 void
1933 Perl_my_setenv(pTHX_ const char *nam, const char *val)
1934 {
1935   dVAR;
1936 #ifdef USE_ITHREADS
1937   /* only parent thread can modify process environment */
1938   if (PL_curinterp == aTHX)
1939 #endif
1940   {
1941 #ifndef PERL_USE_SAFE_PUTENV
1942     if (!PL_use_safe_putenv) {
1943     /* most putenv()s leak, so we manipulate environ directly */
1944     register I32 i;
1945     register const I32 len = strlen(nam);
1946     int nlen, vlen;
1947
1948     /* where does it go? */
1949     for (i = 0; environ[i]; i++) {
1950         if (strnEQ(environ[i],nam,len) && environ[i][len] == '=')
1951             break;
1952     }
1953
1954     if (environ == PL_origenviron) {   /* need we copy environment? */
1955        I32 j;
1956        I32 max;
1957        char **tmpenv;
1958
1959        max = i;
1960        while (environ[max])
1961            max++;
1962        tmpenv = (char**)safesysmalloc((max+2) * sizeof(char*));
1963        for (j=0; j<max; j++) {         /* copy environment */
1964            const int len = strlen(environ[j]);
1965            tmpenv[j] = (char*)safesysmalloc((len+1)*sizeof(char));
1966            Copy(environ[j], tmpenv[j], len+1, char);
1967        }
1968        tmpenv[max] = NULL;
1969        environ = tmpenv;               /* tell exec where it is now */
1970     }
1971     if (!val) {
1972        safesysfree(environ[i]);
1973        while (environ[i]) {
1974            environ[i] = environ[i+1];
1975            i++;
1976         }
1977        return;
1978     }
1979     if (!environ[i]) {                 /* does not exist yet */
1980        environ = (char**)safesysrealloc(environ, (i+2) * sizeof(char*));
1981        environ[i+1] = NULL;    /* make sure it's null terminated */
1982     }
1983     else
1984        safesysfree(environ[i]);
1985        nlen = strlen(nam);
1986        vlen = strlen(val);
1987
1988        environ[i] = (char*)safesysmalloc((nlen+vlen+2) * sizeof(char));
1989        /* all that work just for this */
1990        my_setenv_format(environ[i], nam, nlen, val, vlen);
1991     } else {
1992 # endif
1993 #   if defined(__CYGWIN__) || defined(EPOC) || defined(__SYMBIAN32__) || defined(__riscos__)
1994 #       if defined(HAS_UNSETENV)
1995         if (val == NULL) {
1996             (void)unsetenv(nam);
1997         } else {
1998             (void)setenv(nam, val, 1);
1999         }
2000 #       else /* ! HAS_UNSETENV */
2001         (void)setenv(nam, val, 1);
2002 #       endif /* HAS_UNSETENV */
2003 #   else
2004 #       if defined(HAS_UNSETENV)
2005         if (val == NULL) {
2006             (void)unsetenv(nam);
2007         } else {
2008             const int nlen = strlen(nam);
2009             const int vlen = strlen(val);
2010             char * const new_env =
2011                 (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
2012             my_setenv_format(new_env, nam, nlen, val, vlen);
2013             (void)putenv(new_env);
2014         }
2015 #       else /* ! HAS_UNSETENV */
2016         char *new_env;
2017         const int nlen = strlen(nam);
2018         int vlen;
2019         if (!val) {
2020            val = "";
2021         }
2022         vlen = strlen(val);
2023         new_env = (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
2024         /* all that work just for this */
2025         my_setenv_format(new_env, nam, nlen, val, vlen);
2026         (void)putenv(new_env);
2027 #       endif /* HAS_UNSETENV */
2028 #   endif /* __CYGWIN__ */
2029 #ifndef PERL_USE_SAFE_PUTENV
2030     }
2031 #endif
2032   }
2033 }
2034
2035 #else /* WIN32 || NETWARE */
2036
2037 void
2038 Perl_my_setenv(pTHX_ const char *nam, const char *val)
2039 {
2040     dVAR;
2041     register char *envstr;
2042     const int nlen = strlen(nam);
2043     int vlen;
2044
2045     if (!val) {
2046        val = "";
2047     }
2048     vlen = strlen(val);
2049     Newx(envstr, nlen+vlen+2, char);
2050     my_setenv_format(envstr, nam, nlen, val, vlen);
2051     (void)PerlEnv_putenv(envstr);
2052     Safefree(envstr);
2053 }
2054
2055 #endif /* WIN32 || NETWARE */
2056
2057 #endif /* !VMS && !EPOC*/
2058
2059 #ifdef UNLINK_ALL_VERSIONS
2060 I32
2061 Perl_unlnk(pTHX_ const char *f) /* unlink all versions of a file */
2062 {
2063     I32 retries = 0;
2064
2065     PERL_ARGS_ASSERT_UNLNK;
2066
2067     while (PerlLIO_unlink(f) >= 0)
2068         retries++;
2069     return retries ? 0 : -1;
2070 }
2071 #endif
2072
2073 /* this is a drop-in replacement for bcopy() */
2074 #if (!defined(HAS_MEMCPY) && !defined(HAS_BCOPY)) || (!defined(HAS_MEMMOVE) && !defined(HAS_SAFE_MEMCPY) && !defined(HAS_SAFE_BCOPY))
2075 char *
2076 Perl_my_bcopy(register const char *from,register char *to,register I32 len)
2077 {
2078     char * const retval = to;
2079
2080     PERL_ARGS_ASSERT_MY_BCOPY;
2081
2082     if (from - to >= 0) {
2083         while (len--)
2084             *to++ = *from++;
2085     }
2086     else {
2087         to += len;
2088         from += len;
2089         while (len--)
2090             *(--to) = *(--from);
2091     }
2092     return retval;
2093 }
2094 #endif
2095
2096 /* this is a drop-in replacement for memset() */
2097 #ifndef HAS_MEMSET
2098 void *
2099 Perl_my_memset(register char *loc, register I32 ch, register I32 len)
2100 {
2101     char * const retval = loc;
2102
2103     PERL_ARGS_ASSERT_MY_MEMSET;
2104
2105     while (len--)
2106         *loc++ = ch;
2107     return retval;
2108 }
2109 #endif
2110
2111 /* this is a drop-in replacement for bzero() */
2112 #if !defined(HAS_BZERO) && !defined(HAS_MEMSET)
2113 char *
2114 Perl_my_bzero(register char *loc, register I32 len)
2115 {
2116     char * const retval = loc;
2117
2118     PERL_ARGS_ASSERT_MY_BZERO;
2119
2120     while (len--)
2121         *loc++ = 0;
2122     return retval;
2123 }
2124 #endif
2125
2126 /* this is a drop-in replacement for memcmp() */
2127 #if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP)
2128 I32
2129 Perl_my_memcmp(const char *s1, const char *s2, register I32 len)
2130 {
2131     register const U8 *a = (const U8 *)s1;
2132     register const U8 *b = (const U8 *)s2;
2133     register I32 tmp;
2134
2135     PERL_ARGS_ASSERT_MY_MEMCMP;
2136
2137     while (len--) {
2138         if ((tmp = *a++ - *b++))
2139             return tmp;
2140     }
2141     return 0;
2142 }
2143 #endif /* !HAS_MEMCMP || !HAS_SANE_MEMCMP */
2144
2145 #ifndef HAS_VPRINTF
2146 /* This vsprintf replacement should generally never get used, since
2147    vsprintf was available in both System V and BSD 2.11.  (There may
2148    be some cross-compilation or embedded set-ups where it is needed,
2149    however.)
2150
2151    If you encounter a problem in this function, it's probably a symptom
2152    that Configure failed to detect your system's vprintf() function.
2153    See the section on "item vsprintf" in the INSTALL file.
2154
2155    This version may compile on systems with BSD-ish <stdio.h>,
2156    but probably won't on others.
2157 */
2158
2159 #ifdef USE_CHAR_VSPRINTF
2160 char *
2161 #else
2162 int
2163 #endif
2164 vsprintf(char *dest, const char *pat, void *args)
2165 {
2166     FILE fakebuf;
2167
2168 #if defined(STDIO_PTR_LVALUE) && defined(STDIO_CNT_LVALUE)
2169     FILE_ptr(&fakebuf) = (STDCHAR *) dest;
2170     FILE_cnt(&fakebuf) = 32767;
2171 #else
2172     /* These probably won't compile -- If you really need
2173        this, you'll have to figure out some other method. */
2174     fakebuf._ptr = dest;
2175     fakebuf._cnt = 32767;
2176 #endif
2177 #ifndef _IOSTRG
2178 #define _IOSTRG 0
2179 #endif
2180     fakebuf._flag = _IOWRT|_IOSTRG;
2181     _doprnt(pat, args, &fakebuf);       /* what a kludge */
2182 #if defined(STDIO_PTR_LVALUE)
2183     *(FILE_ptr(&fakebuf)++) = '\0';
2184 #else
2185     /* PerlIO has probably #defined away fputc, but we want it here. */
2186 #  ifdef fputc
2187 #    undef fputc  /* XXX Should really restore it later */
2188 #  endif
2189     (void)fputc('\0', &fakebuf);
2190 #endif
2191 #ifdef USE_CHAR_VSPRINTF
2192     return(dest);
2193 #else
2194     return 0;           /* perl doesn't use return value */
2195 #endif
2196 }
2197
2198 #endif /* HAS_VPRINTF */
2199
2200 #ifdef MYSWAP
2201 #if BYTEORDER != 0x4321
2202 short
2203 Perl_my_swap(pTHX_ short s)
2204 {
2205 #if (BYTEORDER & 1) == 0
2206     short result;
2207
2208     result = ((s & 255) << 8) + ((s >> 8) & 255);
2209     return result;
2210 #else
2211     return s;
2212 #endif
2213 }
2214
2215 long
2216 Perl_my_htonl(pTHX_ long l)
2217 {
2218     union {
2219         long result;
2220         char c[sizeof(long)];
2221     } u;
2222
2223 #if BYTEORDER == 0x1234 || BYTEORDER == 0x12345678
2224 #if BYTEORDER == 0x12345678
2225     u.result = 0;
2226 #endif
2227     u.c[0] = (l >> 24) & 255;
2228     u.c[1] = (l >> 16) & 255;
2229     u.c[2] = (l >> 8) & 255;
2230     u.c[3] = l & 255;
2231     return u.result;
2232 #else
2233 #if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
2234     Perl_croak(aTHX_ "Unknown BYTEORDER\n");
2235 #else
2236     register I32 o;
2237     register I32 s;
2238
2239     for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
2240         u.c[o & 0xf] = (l >> s) & 255;
2241     }
2242     return u.result;
2243 #endif
2244 #endif
2245 }
2246
2247 long
2248 Perl_my_ntohl(pTHX_ long l)
2249 {
2250     union {
2251         long l;
2252         char c[sizeof(long)];
2253     } u;
2254
2255 #if BYTEORDER == 0x1234
2256     u.c[0] = (l >> 24) & 255;
2257     u.c[1] = (l >> 16) & 255;
2258     u.c[2] = (l >> 8) & 255;
2259     u.c[3] = l & 255;
2260     return u.l;
2261 #else
2262 #if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
2263     Perl_croak(aTHX_ "Unknown BYTEORDER\n");
2264 #else
2265     register I32 o;
2266     register I32 s;
2267
2268     u.l = l;
2269     l = 0;
2270     for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
2271         l |= (u.c[o & 0xf] & 255) << s;
2272     }
2273     return l;
2274 #endif
2275 #endif
2276 }
2277
2278 #endif /* BYTEORDER != 0x4321 */
2279 #endif /* MYSWAP */
2280
2281 /*
2282  * Little-endian byte order functions - 'v' for 'VAX', or 'reVerse'.
2283  * If these functions are defined,
2284  * the BYTEORDER is neither 0x1234 nor 0x4321.
2285  * However, this is not assumed.
2286  * -DWS
2287  */
2288
2289 #define HTOLE(name,type)                                        \
2290         type                                                    \
2291         name (register type n)                                  \
2292         {                                                       \
2293             union {                                             \
2294                 type value;                                     \
2295                 char c[sizeof(type)];                           \
2296             } u;                                                \
2297             register U32 i;                                     \
2298             register U32 s = 0;                                 \
2299             for (i = 0; i < sizeof(u.c); i++, s += 8) {         \
2300                 u.c[i] = (n >> s) & 0xFF;                       \
2301             }                                                   \
2302             return u.value;                                     \
2303         }
2304
2305 #define LETOH(name,type)                                        \
2306         type                                                    \
2307         name (register type n)                                  \
2308         {                                                       \
2309             union {                                             \
2310                 type value;                                     \
2311                 char c[sizeof(type)];                           \
2312             } u;                                                \
2313             register U32 i;                                     \
2314             register U32 s = 0;                                 \
2315             u.value = n;                                        \
2316             n = 0;                                              \
2317             for (i = 0; i < sizeof(u.c); i++, s += 8) {         \
2318                 n |= ((type)(u.c[i] & 0xFF)) << s;              \
2319             }                                                   \
2320             return n;                                           \
2321         }
2322
2323 /*
2324  * Big-endian byte order functions.
2325  */
2326
2327 #define HTOBE(name,type)                                        \
2328         type                                                    \
2329         name (register type n)                                  \
2330         {                                                       \
2331             union {                                             \
2332                 type value;                                     \
2333                 char c[sizeof(type)];                           \
2334             } u;                                                \
2335             register U32 i;                                     \
2336             register U32 s = 8*(sizeof(u.c)-1);                 \
2337             for (i = 0; i < sizeof(u.c); i++, s -= 8) {         \
2338                 u.c[i] = (n >> s) & 0xFF;                       \
2339             }                                                   \
2340             return u.value;                                     \
2341         }
2342
2343 #define BETOH(name,type)                                        \
2344         type                                                    \
2345         name (register type n)                                  \
2346         {                                                       \
2347             union {                                             \
2348                 type value;                                     \
2349                 char c[sizeof(type)];                           \
2350             } u;                                                \
2351             register U32 i;                                     \
2352             register U32 s = 8*(sizeof(u.c)-1);                 \
2353             u.value = n;                                        \
2354             n = 0;                                              \
2355             for (i = 0; i < sizeof(u.c); i++, s -= 8) {         \
2356                 n |= ((type)(u.c[i] & 0xFF)) << s;              \
2357             }                                                   \
2358             return n;                                           \
2359         }
2360
2361 /*
2362  * If we just can't do it...
2363  */
2364
2365 #define NOT_AVAIL(name,type)                                    \
2366         type                                                    \
2367         name (register type n)                                  \
2368         {                                                       \
2369             Perl_croak_nocontext(#name "() not available");     \
2370             return n; /* not reached */                         \
2371         }
2372
2373
2374 #if defined(HAS_HTOVS) && !defined(htovs)
2375 HTOLE(htovs,short)
2376 #endif
2377 #if defined(HAS_HTOVL) && !defined(htovl)
2378 HTOLE(htovl,long)
2379 #endif
2380 #if defined(HAS_VTOHS) && !defined(vtohs)
2381 LETOH(vtohs,short)
2382 #endif
2383 #if defined(HAS_VTOHL) && !defined(vtohl)
2384 LETOH(vtohl,long)
2385 #endif
2386
2387 #ifdef PERL_NEED_MY_HTOLE16
2388 # if U16SIZE == 2
2389 HTOLE(Perl_my_htole16,U16)
2390 # else
2391 NOT_AVAIL(Perl_my_htole16,U16)
2392 # endif
2393 #endif
2394 #ifdef PERL_NEED_MY_LETOH16
2395 # if U16SIZE == 2
2396 LETOH(Perl_my_letoh16,U16)
2397 # else
2398 NOT_AVAIL(Perl_my_letoh16,U16)
2399 # endif
2400 #endif
2401 #ifdef PERL_NEED_MY_HTOBE16
2402 # if U16SIZE == 2
2403 HTOBE(Perl_my_htobe16,U16)
2404 # else
2405 NOT_AVAIL(Perl_my_htobe16,U16)
2406 # endif
2407 #endif
2408 #ifdef PERL_NEED_MY_BETOH16
2409 # if U16SIZE == 2
2410 BETOH(Perl_my_betoh16,U16)
2411 # else
2412 NOT_AVAIL(Perl_my_betoh16,U16)
2413 # endif
2414 #endif
2415
2416 #ifdef PERL_NEED_MY_HTOLE32
2417 # if U32SIZE == 4
2418 HTOLE(Perl_my_htole32,U32)
2419 # else
2420 NOT_AVAIL(Perl_my_htole32,U32)
2421 # endif
2422 #endif
2423 #ifdef PERL_NEED_MY_LETOH32
2424 # if U32SIZE == 4
2425 LETOH(Perl_my_letoh32,U32)
2426 # else
2427 NOT_AVAIL(Perl_my_letoh32,U32)
2428 # endif
2429 #endif
2430 #ifdef PERL_NEED_MY_HTOBE32
2431 # if U32SIZE == 4
2432 HTOBE(Perl_my_htobe32,U32)
2433 # else
2434 NOT_AVAIL(Perl_my_htobe32,U32)
2435 # endif
2436 #endif
2437 #ifdef PERL_NEED_MY_BETOH32
2438 # if U32SIZE == 4
2439 BETOH(Perl_my_betoh32,U32)
2440 # else
2441 NOT_AVAIL(Perl_my_betoh32,U32)
2442 # endif
2443 #endif
2444
2445 #ifdef PERL_NEED_MY_HTOLE64
2446 # if U64SIZE == 8
2447 HTOLE(Perl_my_htole64,U64)
2448 # else
2449 NOT_AVAIL(Perl_my_htole64,U64)
2450 # endif
2451 #endif
2452 #ifdef PERL_NEED_MY_LETOH64
2453 # if U64SIZE == 8
2454 LETOH(Perl_my_letoh64,U64)
2455 # else
2456 NOT_AVAIL(Perl_my_letoh64,U64)
2457 # endif
2458 #endif
2459 #ifdef PERL_NEED_MY_HTOBE64
2460 # if U64SIZE == 8
2461 HTOBE(Perl_my_htobe64,U64)
2462 # else
2463 NOT_AVAIL(Perl_my_htobe64,U64)
2464 # endif
2465 #endif
2466 #ifdef PERL_NEED_MY_BETOH64
2467 # if U64SIZE == 8
2468 BETOH(Perl_my_betoh64,U64)
2469 # else
2470 NOT_AVAIL(Perl_my_betoh64,U64)
2471 # endif
2472 #endif
2473
2474 #ifdef PERL_NEED_MY_HTOLES
2475 HTOLE(Perl_my_htoles,short)
2476 #endif
2477 #ifdef PERL_NEED_MY_LETOHS
2478 LETOH(Perl_my_letohs,short)
2479 #endif
2480 #ifdef PERL_NEED_MY_HTOBES
2481 HTOBE(Perl_my_htobes,short)
2482 #endif
2483 #ifdef PERL_NEED_MY_BETOHS
2484 BETOH(Perl_my_betohs,short)
2485 #endif
2486
2487 #ifdef PERL_NEED_MY_HTOLEI
2488 HTOLE(Perl_my_htolei,int)
2489 #endif
2490 #ifdef PERL_NEED_MY_LETOHI
2491 LETOH(Perl_my_letohi,int)
2492 #endif
2493 #ifdef PERL_NEED_MY_HTOBEI
2494 HTOBE(Perl_my_htobei,int)
2495 #endif
2496 #ifdef PERL_NEED_MY_BETOHI
2497 BETOH(Perl_my_betohi,int)
2498 #endif
2499
2500 #ifdef PERL_NEED_MY_HTOLEL
2501 HTOLE(Perl_my_htolel,long)
2502 #endif
2503 #ifdef PERL_NEED_MY_LETOHL
2504 LETOH(Perl_my_letohl,long)
2505 #endif
2506 #ifdef PERL_NEED_MY_HTOBEL
2507 HTOBE(Perl_my_htobel,long)
2508 #endif
2509 #ifdef PERL_NEED_MY_BETOHL
2510 BETOH(Perl_my_betohl,long)
2511 #endif
2512
2513 void
2514 Perl_my_swabn(void *ptr, int n)
2515 {
2516     register char *s = (char *)ptr;
2517     register char *e = s + (n-1);
2518     register char tc;
2519
2520     PERL_ARGS_ASSERT_MY_SWABN;
2521
2522     for (n /= 2; n > 0; s++, e--, n--) {
2523       tc = *s;
2524       *s = *e;
2525       *e = tc;
2526     }
2527 }
2528
2529 PerlIO *
2530 Perl_my_popen_list(pTHX_ const char *mode, int n, SV **args)
2531 {
2532 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(OS2) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(NETWARE) && !defined(__LIBCATAMOUNT__)
2533     dVAR;
2534     int p[2];
2535     register I32 This, that;
2536     register Pid_t pid;
2537     SV *sv;
2538     I32 did_pipes = 0;
2539     int pp[2];
2540
2541     PERL_ARGS_ASSERT_MY_POPEN_LIST;
2542
2543     PERL_FLUSHALL_FOR_CHILD;
2544     This = (*mode == 'w');
2545     that = !This;
2546     if (PL_tainting) {
2547         taint_env();
2548         taint_proper("Insecure %s%s", "EXEC");
2549     }
2550     if (PerlProc_pipe(p) < 0)
2551         return NULL;
2552     /* Try for another pipe pair for error return */
2553     if (PerlProc_pipe(pp) >= 0)
2554         did_pipes = 1;
2555     while ((pid = PerlProc_fork()) < 0) {
2556         if (errno != EAGAIN) {
2557             PerlLIO_close(p[This]);
2558             PerlLIO_close(p[that]);
2559             if (did_pipes) {
2560                 PerlLIO_close(pp[0]);
2561                 PerlLIO_close(pp[1]);
2562             }
2563             return NULL;
2564         }
2565         Perl_ck_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds");
2566         sleep(5);
2567     }
2568     if (pid == 0) {
2569         /* Child */
2570 #undef THIS
2571 #undef THAT
2572 #define THIS that
2573 #define THAT This
2574         /* Close parent's end of error status pipe (if any) */
2575         if (did_pipes) {
2576             PerlLIO_close(pp[0]);
2577 #if defined(HAS_FCNTL) && defined(F_SETFD)
2578             /* Close error pipe automatically if exec works */
2579             fcntl(pp[1], F_SETFD, FD_CLOEXEC);
2580 #endif
2581         }
2582         /* Now dup our end of _the_ pipe to right position */
2583         if (p[THIS] != (*mode == 'r')) {
2584             PerlLIO_dup2(p[THIS], *mode == 'r');
2585             PerlLIO_close(p[THIS]);
2586             if (p[THAT] != (*mode == 'r'))      /* if dup2() didn't close it */
2587                 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
2588         }
2589         else
2590             PerlLIO_close(p[THAT]);     /* close parent's end of _the_ pipe */
2591 #if !defined(HAS_FCNTL) || !defined(F_SETFD)
2592         /* No automatic close - do it by hand */
2593 #  ifndef NOFILE
2594 #  define NOFILE 20
2595 #  endif
2596         {
2597             int fd;
2598
2599             for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++) {
2600                 if (fd != pp[1])
2601                     PerlLIO_close(fd);
2602             }
2603         }
2604 #endif
2605         do_aexec5(NULL, args-1, args-1+n, pp[1], did_pipes);
2606         PerlProc__exit(1);
2607 #undef THIS
2608 #undef THAT
2609     }
2610     /* Parent */
2611     do_execfree();      /* free any memory malloced by child on fork */
2612     if (did_pipes)
2613         PerlLIO_close(pp[1]);
2614     /* Keep the lower of the two fd numbers */
2615     if (p[that] < p[This]) {
2616         PerlLIO_dup2(p[This], p[that]);
2617         PerlLIO_close(p[This]);
2618         p[This] = p[that];
2619     }
2620     else
2621         PerlLIO_close(p[that]);         /* close child's end of pipe */
2622
2623     sv = *av_fetch(PL_fdpid,p[This],TRUE);
2624     SvUPGRADE(sv,SVt_IV);
2625     SvIV_set(sv, pid);
2626     PL_forkprocess = pid;
2627     /* If we managed to get status pipe check for exec fail */
2628     if (did_pipes && pid > 0) {
2629         int errkid;
2630         unsigned n = 0;
2631         SSize_t n1;
2632
2633         while (n < sizeof(int)) {
2634             n1 = PerlLIO_read(pp[0],
2635                               (void*)(((char*)&errkid)+n),
2636                               (sizeof(int)) - n);
2637             if (n1 <= 0)
2638                 break;
2639             n += n1;
2640         }
2641         PerlLIO_close(pp[0]);
2642         did_pipes = 0;
2643         if (n) {                        /* Error */
2644             int pid2, status;
2645             PerlLIO_close(p[This]);
2646             if (n != sizeof(int))
2647                 Perl_croak(aTHX_ "panic: kid popen errno read");
2648             do {
2649                 pid2 = wait4pid(pid, &status, 0);
2650             } while (pid2 == -1 && errno == EINTR);
2651             errno = errkid;             /* Propagate errno from kid */
2652             return NULL;
2653         }
2654     }
2655     if (did_pipes)
2656          PerlLIO_close(pp[0]);
2657     return PerlIO_fdopen(p[This], mode);
2658 #else
2659 #  ifdef OS2    /* Same, without fork()ing and all extra overhead... */
2660     return my_syspopen4(aTHX_ NULL, mode, n, args);
2661 #  else
2662     Perl_croak(aTHX_ "List form of piped open not implemented");
2663     return (PerlIO *) NULL;
2664 #  endif
2665 #endif
2666 }
2667
2668     /* VMS' my_popen() is in VMS.c, same with OS/2. */
2669 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(__LIBCATAMOUNT__)
2670 PerlIO *
2671 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2672 {
2673     dVAR;
2674     int p[2];
2675     register I32 This, that;
2676     register Pid_t pid;
2677     SV *sv;
2678     const I32 doexec = !(*cmd == '-' && cmd[1] == '\0');
2679     I32 did_pipes = 0;
2680     int pp[2];
2681
2682     PERL_ARGS_ASSERT_MY_POPEN;
2683
2684     PERL_FLUSHALL_FOR_CHILD;
2685 #ifdef OS2
2686     if (doexec) {
2687         return my_syspopen(aTHX_ cmd,mode);
2688     }
2689 #endif
2690     This = (*mode == 'w');
2691     that = !This;
2692     if (doexec && PL_tainting) {
2693         taint_env();
2694         taint_proper("Insecure %s%s", "EXEC");
2695     }
2696     if (PerlProc_pipe(p) < 0)
2697         return NULL;
2698     if (doexec && PerlProc_pipe(pp) >= 0)
2699         did_pipes = 1;
2700     while ((pid = PerlProc_fork()) < 0) {
2701         if (errno != EAGAIN) {
2702             PerlLIO_close(p[This]);
2703             PerlLIO_close(p[that]);
2704             if (did_pipes) {
2705                 PerlLIO_close(pp[0]);
2706                 PerlLIO_close(pp[1]);
2707             }
2708             if (!doexec)
2709                 Perl_croak(aTHX_ "Can't fork: %s", Strerror(errno));
2710             return NULL;
2711         }
2712         Perl_ck_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds");
2713         sleep(5);
2714     }
2715     if (pid == 0) {
2716
2717 #undef THIS
2718 #undef THAT
2719 #define THIS that
2720 #define THAT This
2721         if (did_pipes) {
2722             PerlLIO_close(pp[0]);
2723 #if defined(HAS_FCNTL) && defined(F_SETFD)
2724             fcntl(pp[1], F_SETFD, FD_CLOEXEC);
2725 #endif
2726         }
2727         if (p[THIS] != (*mode == 'r')) {
2728             PerlLIO_dup2(p[THIS], *mode == 'r');
2729             PerlLIO_close(p[THIS]);
2730             if (p[THAT] != (*mode == 'r'))      /* if dup2() didn't close it */
2731                 PerlLIO_close(p[THAT]);
2732         }
2733         else
2734             PerlLIO_close(p[THAT]);
2735 #ifndef OS2
2736         if (doexec) {
2737 #if !defined(HAS_FCNTL) || !defined(F_SETFD)
2738 #ifndef NOFILE
2739 #define NOFILE 20
2740 #endif
2741             {
2742                 int fd;
2743
2744                 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++)
2745                     if (fd != pp[1])
2746                         PerlLIO_close(fd);
2747             }
2748 #endif
2749             /* may or may not use the shell */
2750             do_exec3(cmd, pp[1], did_pipes);
2751             PerlProc__exit(1);
2752         }
2753 #endif  /* defined OS2 */
2754
2755 #ifdef PERLIO_USING_CRLF
2756    /* Since we circumvent IO layers when we manipulate low-level
2757       filedescriptors directly, need to manually switch to the
2758       default, binary, low-level mode; see PerlIOBuf_open(). */
2759    PerlLIO_setmode((*mode == 'r'), O_BINARY);
2760 #endif
2761 #ifdef THREADS_HAVE_PIDS
2762         PL_ppid = (IV)getppid();
2763 #endif
2764         PL_forkprocess = 0;
2765 #ifdef PERL_USES_PL_PIDSTATUS
2766         hv_clear(PL_pidstatus); /* we have no children */
2767 #endif
2768         return NULL;
2769 #undef THIS
2770 #undef THAT
2771     }
2772     do_execfree();      /* free any memory malloced by child on vfork */
2773     if (did_pipes)
2774         PerlLIO_close(pp[1]);
2775     if (p[that] < p[This]) {
2776         PerlLIO_dup2(p[This], p[that]);
2777         PerlLIO_close(p[This]);
2778         p[This] = p[that];
2779     }
2780     else
2781         PerlLIO_close(p[that]);
2782
2783     sv = *av_fetch(PL_fdpid,p[This],TRUE);
2784     SvUPGRADE(sv,SVt_IV);
2785     SvIV_set(sv, pid);
2786     PL_forkprocess = pid;
2787     if (did_pipes && pid > 0) {
2788         int errkid;
2789         unsigned n = 0;
2790         SSize_t n1;
2791
2792         while (n < sizeof(int)) {
2793             n1 = PerlLIO_read(pp[0],
2794                               (void*)(((char*)&errkid)+n),
2795                               (sizeof(int)) - n);
2796             if (n1 <= 0)
2797                 break;
2798             n += n1;
2799         }
2800         PerlLIO_close(pp[0]);
2801         did_pipes = 0;
2802         if (n) {                        /* Error */
2803             int pid2, status;
2804             PerlLIO_close(p[This]);
2805             if (n != sizeof(int))
2806                 Perl_croak(aTHX_ "panic: kid popen errno read");
2807             do {
2808                 pid2 = wait4pid(pid, &status, 0);
2809             } while (pid2 == -1 && errno == EINTR);
2810             errno = errkid;             /* Propagate errno from kid */
2811             return NULL;
2812         }
2813     }
2814     if (did_pipes)
2815          PerlLIO_close(pp[0]);
2816     return PerlIO_fdopen(p[This], mode);
2817 }
2818 #else
2819 #if defined(atarist) || defined(EPOC)
2820 FILE *popen();
2821 PerlIO *
2822 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2823 {
2824     PERL_ARGS_ASSERT_MY_POPEN;
2825     PERL_FLUSHALL_FOR_CHILD;
2826     /* Call system's popen() to get a FILE *, then import it.
2827        used 0 for 2nd parameter to PerlIO_importFILE;
2828        apparently not used
2829     */
2830     return PerlIO_importFILE(popen(cmd, mode), 0);
2831 }
2832 #else
2833 #if defined(DJGPP)
2834 FILE *djgpp_popen();
2835 PerlIO *
2836 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2837 {
2838     PERL_FLUSHALL_FOR_CHILD;
2839     /* Call system's popen() to get a FILE *, then import it.
2840        used 0 for 2nd parameter to PerlIO_importFILE;
2841        apparently not used
2842     */
2843     return PerlIO_importFILE(djgpp_popen(cmd, mode), 0);
2844 }
2845 #else
2846 #if defined(__LIBCATAMOUNT__)
2847 PerlIO *
2848 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2849 {
2850     return NULL;
2851 }
2852 #endif
2853 #endif
2854 #endif
2855
2856 #endif /* !DOSISH */
2857
2858 /* this is called in parent before the fork() */
2859 void
2860 Perl_atfork_lock(void)
2861 {
2862    dVAR;
2863 #if defined(USE_ITHREADS)
2864     /* locks must be held in locking order (if any) */
2865 #  ifdef MYMALLOC
2866     MUTEX_LOCK(&PL_malloc_mutex);
2867 #  endif
2868     OP_REFCNT_LOCK;
2869 #endif
2870 }
2871
2872 /* this is called in both parent and child after the fork() */
2873 void
2874 Perl_atfork_unlock(void)
2875 {
2876     dVAR;
2877 #if defined(USE_ITHREADS)
2878     /* locks must be released in same order as in atfork_lock() */
2879 #  ifdef MYMALLOC
2880     MUTEX_UNLOCK(&PL_malloc_mutex);
2881 #  endif
2882     OP_REFCNT_UNLOCK;
2883 #endif
2884 }
2885
2886 Pid_t
2887 Perl_my_fork(void)
2888 {
2889 #if defined(HAS_FORK)
2890     Pid_t pid;
2891 #if defined(USE_ITHREADS) && !defined(HAS_PTHREAD_ATFORK)
2892     atfork_lock();
2893     pid = fork();
2894     atfork_unlock();
2895 #else
2896     /* atfork_lock() and atfork_unlock() are installed as pthread_atfork()
2897      * handlers elsewhere in the code */
2898     pid = fork();
2899 #endif
2900     return pid;
2901 #else
2902     /* this "canna happen" since nothing should be calling here if !HAS_FORK */
2903     Perl_croak_nocontext("fork() not available");
2904     return 0;
2905 #endif /* HAS_FORK */
2906 }
2907
2908 #ifdef DUMP_FDS
2909 void
2910 Perl_dump_fds(pTHX_ const char *const s)
2911 {
2912     int fd;
2913     Stat_t tmpstatbuf;
2914
2915     PERL_ARGS_ASSERT_DUMP_FDS;
2916
2917     PerlIO_printf(Perl_debug_log,"%s", s);
2918     for (fd = 0; fd < 32; fd++) {
2919         if (PerlLIO_fstat(fd,&tmpstatbuf) >= 0)
2920             PerlIO_printf(Perl_debug_log," %d",fd);
2921     }
2922     PerlIO_printf(Perl_debug_log,"\n");
2923     return;
2924 }
2925 #endif  /* DUMP_FDS */
2926
2927 #ifndef HAS_DUP2
2928 int
2929 dup2(int oldfd, int newfd)
2930 {
2931 #if defined(HAS_FCNTL) && defined(F_DUPFD)
2932     if (oldfd == newfd)
2933         return oldfd;
2934     PerlLIO_close(newfd);
2935     return fcntl(oldfd, F_DUPFD, newfd);
2936 #else
2937 #define DUP2_MAX_FDS 256
2938     int fdtmp[DUP2_MAX_FDS];
2939     I32 fdx = 0;
2940     int fd;
2941
2942     if (oldfd == newfd)
2943         return oldfd;
2944     PerlLIO_close(newfd);
2945     /* good enough for low fd's... */
2946     while ((fd = PerlLIO_dup(oldfd)) != newfd && fd >= 0) {
2947         if (fdx >= DUP2_MAX_FDS) {
2948             PerlLIO_close(fd);
2949             fd = -1;
2950             break;
2951         }
2952         fdtmp[fdx++] = fd;
2953     }
2954     while (fdx > 0)
2955         PerlLIO_close(fdtmp[--fdx]);
2956     return fd;
2957 #endif
2958 }
2959 #endif
2960
2961 #ifndef PERL_MICRO
2962 #ifdef HAS_SIGACTION
2963
2964 Sighandler_t
2965 Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
2966 {
2967     dVAR;
2968     struct sigaction act, oact;
2969
2970 #ifdef USE_ITHREADS
2971     /* only "parent" interpreter can diddle signals */
2972     if (PL_curinterp != aTHX)
2973         return (Sighandler_t) SIG_ERR;
2974 #endif
2975
2976     act.sa_handler = (void(*)(int))handler;
2977     sigemptyset(&act.sa_mask);
2978     act.sa_flags = 0;
2979 #ifdef SA_RESTART
2980     if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2981         act.sa_flags |= SA_RESTART;     /* SVR4, 4.3+BSD */
2982 #endif
2983 #if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
2984     if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
2985         act.sa_flags |= SA_NOCLDWAIT;
2986 #endif
2987     if (sigaction(signo, &act, &oact) == -1)
2988         return (Sighandler_t) SIG_ERR;
2989     else
2990         return (Sighandler_t) oact.sa_handler;
2991 }
2992
2993 Sighandler_t
2994 Perl_rsignal_state(pTHX_ int signo)
2995 {
2996     struct sigaction oact;
2997     PERL_UNUSED_CONTEXT;
2998
2999     if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1)
3000         return (Sighandler_t) SIG_ERR;
3001     else
3002         return (Sighandler_t) oact.sa_handler;
3003 }
3004
3005 int
3006 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
3007 {
3008     dVAR;
3009     struct sigaction act;
3010
3011     PERL_ARGS_ASSERT_RSIGNAL_SAVE;
3012
3013 #ifdef USE_ITHREADS
3014     /* only "parent" interpreter can diddle signals */
3015     if (PL_curinterp != aTHX)
3016         return -1;
3017 #endif
3018
3019     act.sa_handler = (void(*)(int))handler;
3020     sigemptyset(&act.sa_mask);
3021     act.sa_flags = 0;
3022 #ifdef SA_RESTART
3023     if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
3024         act.sa_flags |= SA_RESTART;     /* SVR4, 4.3+BSD */
3025 #endif
3026 #if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
3027     if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
3028         act.sa_flags |= SA_NOCLDWAIT;
3029 #endif
3030     return sigaction(signo, &act, save);
3031 }
3032
3033 int
3034 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
3035 {
3036     dVAR;
3037 #ifdef USE_ITHREADS
3038     /* only "parent" interpreter can diddle signals */
3039     if (PL_curinterp != aTHX)
3040         return -1;
3041 #endif
3042
3043     return sigaction(signo, save, (struct sigaction *)NULL);
3044 }
3045
3046 #else /* !HAS_SIGACTION */
3047
3048 Sighandler_t
3049 Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
3050 {
3051 #if defined(USE_ITHREADS) && !defined(WIN32)
3052     /* only "parent" interpreter can diddle signals */
3053     if (PL_curinterp != aTHX)
3054         return (Sighandler_t) SIG_ERR;
3055 #endif
3056
3057     return PerlProc_signal(signo, handler);
3058 }
3059
3060 static Signal_t
3061 sig_trap(int signo)
3062 {
3063     dVAR;
3064     PL_sig_trapped++;
3065 }
3066
3067 Sighandler_t
3068 Perl_rsignal_state(pTHX_ int signo)
3069 {
3070     dVAR;
3071     Sighandler_t oldsig;
3072
3073 #if defined(USE_ITHREADS) && !defined(WIN32)
3074     /* only "parent" interpreter can diddle signals */
3075     if (PL_curinterp != aTHX)
3076         return (Sighandler_t) SIG_ERR;
3077 #endif
3078
3079     PL_sig_trapped = 0;
3080     oldsig = PerlProc_signal(signo, sig_trap);
3081     PerlProc_signal(signo, oldsig);
3082     if (PL_sig_trapped)
3083         PerlProc_kill(PerlProc_getpid(), signo);
3084     return oldsig;
3085 }
3086
3087 int
3088 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
3089 {
3090 #if defined(USE_ITHREADS) && !defined(WIN32)
3091     /* only "parent" interpreter can diddle signals */
3092     if (PL_curinterp != aTHX)
3093         return -1;
3094 #endif
3095     *save = PerlProc_signal(signo, handler);
3096     return (*save == (Sighandler_t) SIG_ERR) ? -1 : 0;
3097 }
3098
3099 int
3100 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
3101 {
3102 #if defined(USE_ITHREADS) && !defined(WIN32)
3103     /* only "parent" interpreter can diddle signals */
3104     if (PL_curinterp != aTHX)
3105         return -1;
3106 #endif
3107     return (PerlProc_signal(signo, *save) == (Sighandler_t) SIG_ERR) ? -1 : 0;
3108 }
3109
3110 #endif /* !HAS_SIGACTION */
3111 #endif /* !PERL_MICRO */
3112
3113     /* VMS' my_pclose() is in VMS.c; same with OS/2 */
3114 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(__LIBCATAMOUNT__)
3115 I32
3116 Perl_my_pclose(pTHX_ PerlIO *ptr)
3117 {
3118     dVAR;
3119     Sigsave_t hstat, istat, qstat;
3120     int status;
3121     SV **svp;
3122     Pid_t pid;
3123     Pid_t pid2 = 0;
3124     bool close_failed;
3125     dSAVEDERRNO;
3126     const int fd = PerlIO_fileno(ptr);
3127
3128 #ifdef USE_PERLIO
3129     /* Find out whether the refcount is low enough for us to wait for the
3130        child proc without blocking. */
3131     const bool should_wait = PerlIOUnix_refcnt(fd) == 1;
3132 #else
3133     const bool should_wait = 1;
3134 #endif
3135
3136     svp = av_fetch(PL_fdpid,fd,TRUE);
3137     pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1;
3138     SvREFCNT_dec(*svp);
3139     *svp = &PL_sv_undef;
3140 #ifdef OS2
3141     if (pid == -1) {                    /* Opened by popen. */
3142         return my_syspclose(ptr);
3143     }
3144 #endif
3145     close_failed = (PerlIO_close(ptr) == EOF);
3146     SAVE_ERRNO;
3147 #ifdef UTS
3148     if(PerlProc_kill(pid, 0) < 0) { return(pid); }   /* HOM 12/23/91 */
3149 #endif
3150 #ifndef PERL_MICRO
3151     rsignal_save(SIGHUP,  (Sighandler_t) SIG_IGN, &hstat);
3152     rsignal_save(SIGINT,  (Sighandler_t) SIG_IGN, &istat);
3153     rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qstat);
3154 #endif
3155     if (should_wait) do {
3156         pid2 = wait4pid(pid, &status, 0);
3157     } while (pid2 == -1 && errno == EINTR);
3158 #ifndef PERL_MICRO
3159     rsignal_restore(SIGHUP, &hstat);
3160     rsignal_restore(SIGINT, &istat);
3161     rsignal_restore(SIGQUIT, &qstat);
3162 #endif
3163     if (close_failed) {
3164         RESTORE_ERRNO;
3165         return -1;
3166     }
3167     return(
3168       should_wait
3169        ? pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status)
3170        : 0
3171     );
3172 }
3173 #else
3174 #if defined(__LIBCATAMOUNT__)
3175 I32
3176 Perl_my_pclose(pTHX_ PerlIO *ptr)
3177 {
3178     return -1;
3179 }
3180 #endif
3181 #endif /* !DOSISH */
3182
3183 #if  (!defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(NETWARE)) && !defined(__LIBCATAMOUNT__)
3184 I32
3185 Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
3186 {
3187     dVAR;
3188     I32 result = 0;
3189     PERL_ARGS_ASSERT_WAIT4PID;
3190     if (!pid)
3191         return -1;
3192 #ifdef PERL_USES_PL_PIDSTATUS
3193     {
3194         if (pid > 0) {
3195             /* The keys in PL_pidstatus are now the raw 4 (or 8) bytes of the
3196                pid, rather than a string form.  */
3197             SV * const * const svp = hv_fetch(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),FALSE);
3198             if (svp && *svp != &PL_sv_undef) {
3199                 *statusp = SvIVX(*svp);
3200                 (void)hv_delete(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),
3201                                 G_DISCARD);
3202                 return pid;
3203             }
3204         }
3205         else {
3206             HE *entry;
3207
3208             hv_iterinit(PL_pidstatus);
3209             if ((entry = hv_iternext(PL_pidstatus))) {
3210                 SV * const sv = hv_iterval(PL_pidstatus,entry);
3211                 I32 len;
3212                 const char * const spid = hv_iterkey(entry,&len);
3213
3214                 assert (len == sizeof(Pid_t));
3215                 memcpy((char *)&pid, spid, len);
3216                 *statusp = SvIVX(sv);
3217                 /* The hash iterator is currently on this entry, so simply
3218                    calling hv_delete would trigger the lazy delete, which on
3219                    aggregate does more work, beacuse next call to hv_iterinit()
3220                    would spot the flag, and have to call the delete routine,
3221                    while in the meantime any new entries can't re-use that
3222                    memory.  */
3223                 hv_iterinit(PL_pidstatus);
3224                 (void)hv_delete(PL_pidstatus,spid,len,G_DISCARD);
3225                 return pid;
3226             }
3227         }
3228     }
3229 #endif
3230 #ifdef HAS_WAITPID
3231 #  ifdef HAS_WAITPID_RUNTIME
3232     if (!HAS_WAITPID_RUNTIME)
3233         goto hard_way;
3234 #  endif
3235     result = PerlProc_waitpid(pid,statusp,flags);
3236     goto finish;
3237 #endif
3238 #if !defined(HAS_WAITPID) && defined(HAS_WAIT4)
3239     result = wait4((pid==-1)?0:pid,statusp,flags,NULL);
3240     goto finish;
3241 #endif
3242 #ifdef PERL_USES_PL_PIDSTATUS
3243 #if defined(HAS_WAITPID) && defined(HAS_WAITPID_RUNTIME)
3244   hard_way:
3245 #endif
3246     {
3247         if (flags)
3248             Perl_croak(aTHX_ "Can't do waitpid with flags");
3249         else {
3250             while ((result = PerlProc_wait(statusp)) != pid && pid > 0 && result >= 0)
3251                 pidgone(result,*statusp);
3252             if (result < 0)
3253                 *statusp = -1;
3254         }
3255     }
3256 #endif
3257 #if defined(HAS_WAITPID) || defined(HAS_WAIT4)
3258   finish:
3259 #endif
3260     if (result < 0 && errno == EINTR) {
3261         PERL_ASYNC_CHECK();
3262         errno = EINTR; /* reset in case a signal handler changed $! */
3263     }
3264     return result;
3265 }
3266 #endif /* !DOSISH || OS2 || WIN32 || NETWARE */
3267
3268 #ifdef PERL_USES_PL_PIDSTATUS
3269 void
3270 S_pidgone(pTHX_ Pid_t pid, int status)
3271 {
3272     register SV *sv;
3273
3274     sv = *hv_fetch(PL_pidstatus,(const char*)&pid,sizeof(Pid_t),TRUE);
3275     SvUPGRADE(sv,SVt_IV);
3276     SvIV_set(sv, status);
3277     return;
3278 }
3279 #endif
3280
3281 #if defined(atarist) || defined(OS2) || defined(EPOC)
3282 int pclose();
3283 #ifdef HAS_FORK
3284 int                                     /* Cannot prototype with I32
3285                                            in os2ish.h. */
3286 my_syspclose(PerlIO *ptr)
3287 #else
3288 I32
3289 Perl_my_pclose(pTHX_ PerlIO *ptr)
3290 #endif
3291 {
3292     /* Needs work for PerlIO ! */
3293     FILE * const f = PerlIO_findFILE(ptr);
3294     const I32 result = pclose(f);
3295     PerlIO_releaseFILE(ptr,f);
3296     return result;
3297 }
3298 #endif
3299
3300 #if defined(DJGPP)
3301 int djgpp_pclose();
3302 I32
3303 Perl_my_pclose(pTHX_ PerlIO *ptr)
3304 {
3305     /* Needs work for PerlIO ! */
3306     FILE * const f = PerlIO_findFILE(ptr);
3307     I32 result = djgpp_pclose(f);
3308     result = (result << 8) & 0xff00;
3309     PerlIO_releaseFILE(ptr,f);
3310     return result;
3311 }
3312 #endif
3313
3314 #define PERL_REPEATCPY_LINEAR 4
3315 void
3316 Perl_repeatcpy(register char *to, register const char *from, I32 len, register I32 count)
3317 {
3318     PERL_ARGS_ASSERT_REPEATCPY;
3319
3320     if (len == 1)
3321         memset(to, *from, count);
3322     else if (count) {
3323         register char *p = to;
3324         I32 items, linear, half;
3325
3326         linear = count < PERL_REPEATCPY_LINEAR ? count : PERL_REPEATCPY_LINEAR;
3327         for (items = 0; items < linear; ++items) {
3328             register const char *q = from;
3329             I32 todo;
3330             for (todo = len; todo > 0; todo--)
3331                 *p++ = *q++;
3332         }
3333
3334         half = count / 2;
3335         while (items <= half) {
3336             I32 size = items * len;
3337             memcpy(p, to, size);
3338             p     += size;
3339             items *= 2;
3340         }
3341
3342         if (count > items)
3343             memcpy(p, to, (count - items) * len);
3344     }
3345 }
3346
3347 #ifndef HAS_RENAME
3348 I32
3349 Perl_same_dirent(pTHX_ const char *a, const char *b)
3350 {
3351     char *fa = strrchr(a,'/');
3352     char *fb = strrchr(b,'/');
3353     Stat_t tmpstatbuf1;
3354     Stat_t tmpstatbuf2;
3355     SV * const tmpsv = sv_newmortal();
3356
3357     PERL_ARGS_ASSERT_SAME_DIRENT;
3358
3359     if (fa)
3360         fa++;
3361     else
3362         fa = a;
3363     if (fb)
3364         fb++;
3365     else
3366         fb = b;
3367     if (strNE(a,b))
3368         return FALSE;
3369     if (fa == a)
3370         sv_setpvs(tmpsv, ".");
3371     else
3372         sv_setpvn(tmpsv, a, fa - a);
3373     if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf1) < 0)
3374         return FALSE;
3375     if (fb == b)
3376         sv_setpvs(tmpsv, ".");
3377     else
3378         sv_setpvn(tmpsv, b, fb - b);
3379     if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf2) < 0)
3380         return FALSE;
3381     return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev &&
3382            tmpstatbuf1.st_ino == tmpstatbuf2.st_ino;
3383 }
3384 #endif /* !HAS_RENAME */
3385
3386 char*
3387 Perl_find_script(pTHX_ const char *scriptname, bool dosearch,
3388                  const char *const *const search_ext, I32 flags)
3389 {
3390     dVAR;
3391     const char *xfound = NULL;
3392     char *xfailed = NULL;
3393     char tmpbuf[MAXPATHLEN];
3394     register char *s;
3395     I32 len = 0;
3396     int retval;
3397     char *bufend;
3398 #if defined(DOSISH) && !defined(OS2) && !defined(atarist)
3399 #  define SEARCH_EXTS ".bat", ".cmd", NULL
3400 #  define MAX_EXT_LEN 4
3401 #endif
3402 #ifdef OS2
3403 #  define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
3404 #  define MAX_EXT_LEN 4
3405 #endif
3406 #ifdef VMS
3407 #  define SEARCH_EXTS ".pl", ".com", NULL
3408 #  define MAX_EXT_LEN 4
3409 #endif
3410     /* additional extensions to try in each dir if scriptname not found */
3411 #ifdef SEARCH_EXTS
3412     static const char *const exts[] = { SEARCH_EXTS };
3413     const char *const *const ext = search_ext ? search_ext : exts;
3414     int extidx = 0, i = 0;
3415     const char *curext = NULL;
3416 #else
3417     PERL_UNUSED_ARG(search_ext);
3418 #  define MAX_EXT_LEN 0
3419 #endif
3420
3421     PERL_ARGS_ASSERT_FIND_SCRIPT;
3422
3423     /*
3424      * If dosearch is true and if scriptname does not contain path
3425      * delimiters, search the PATH for scriptname.
3426      *
3427      * If SEARCH_EXTS is also defined, will look for each
3428      * scriptname{SEARCH_EXTS} whenever scriptname is not found
3429      * while searching the PATH.
3430      *
3431      * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
3432      * proceeds as follows:
3433      *   If DOSISH or VMSISH:
3434      *     + look for ./scriptname{,.foo,.bar}
3435      *     + search the PATH for scriptname{,.foo,.bar}
3436      *
3437      *   If !DOSISH:
3438      *     + look *only* in the PATH for scriptname{,.foo,.bar} (note
3439      *       this will not look in '.' if it's not in the PATH)
3440      */
3441     tmpbuf[0] = '\0';
3442
3443 #ifdef VMS
3444 #  ifdef ALWAYS_DEFTYPES
3445     len = strlen(scriptname);
3446     if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') {
3447         int idx = 0, deftypes = 1;
3448         bool seen_dot = 1;
3449
3450         const int hasdir = !dosearch || (strpbrk(scriptname,":[</") != NULL);
3451 #  else
3452     if (dosearch) {
3453         int idx = 0, deftypes = 1;
3454         bool seen_dot = 1;
3455
3456         const int hasdir = (strpbrk(scriptname,":[</") != NULL);
3457 #  endif
3458         /* The first time through, just add SEARCH_EXTS to whatever we
3459          * already have, so we can check for default file types. */
3460         while (deftypes ||
3461                (!hasdir && my_trnlnm("DCL$PATH",tmpbuf,idx++)) )
3462         {
3463             if (deftypes) {
3464                 deftypes = 0;
3465                 *tmpbuf = '\0';
3466             }
3467             if ((strlen(tmpbuf) + strlen(scriptname)
3468                  + MAX_EXT_LEN) >= sizeof tmpbuf)
3469                 continue;       /* don't search dir with too-long name */
3470             my_strlcat(tmpbuf, scriptname, sizeof(tmpbuf));
3471 #else  /* !VMS */
3472
3473 #ifdef DOSISH
3474     if (strEQ(scriptname, "-"))
3475         dosearch = 0;
3476     if (dosearch) {             /* Look in '.' first. */
3477         const char *cur = scriptname;
3478 #ifdef SEARCH_EXTS
3479         if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
3480             while (ext[i])
3481                 if (strEQ(ext[i++],curext)) {
3482                     extidx = -1;                /* already has an ext */
3483                     break;
3484                 }
3485         do {
3486 #endif
3487             DEBUG_p(PerlIO_printf(Perl_debug_log,
3488                                   "Looking for %s\n",cur));
3489             if (PerlLIO_stat(cur,&PL_statbuf) >= 0
3490                 && !S_ISDIR(PL_statbuf.st_mode)) {
3491                 dosearch = 0;
3492                 scriptname = cur;
3493 #ifdef SEARCH_EXTS
3494                 break;
3495 #endif
3496             }
3497 #ifdef SEARCH_EXTS
3498             if (cur == scriptname) {
3499                 len = strlen(scriptname);
3500                 if (len+MAX_EXT_LEN+1 >= sizeof(tmpbuf))
3501                     break;
3502                 my_strlcpy(tmpbuf, scriptname, sizeof(tmpbuf));
3503                 cur = tmpbuf;
3504             }
3505         } while (extidx >= 0 && ext[extidx]     /* try an extension? */
3506                  && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len));
3507 #endif
3508     }
3509 #endif
3510
3511     if (dosearch && !strchr(scriptname, '/')
3512 #ifdef DOSISH
3513                  && !strchr(scriptname, '\\')
3514 #endif
3515                  && (s = PerlEnv_getenv("PATH")))
3516     {
3517         bool seen_dot = 0;
3518
3519         bufend = s + strlen(s);
3520         while (s < bufend) {
3521 #if defined(atarist) || defined(DOSISH)
3522             for (len = 0; *s
3523 #  ifdef atarist
3524                     && *s != ','
3525 #  endif
3526                     && *s != ';'; len++, s++) {
3527                 if (len < sizeof tmpbuf)
3528                     tmpbuf[len] = *s;
3529             }
3530             if (len < sizeof tmpbuf)
3531                 tmpbuf[len] = '\0';
3532 #else  /* ! (atarist || DOSISH) */
3533             s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, bufend,
3534                         ':',
3535                         &len);
3536 #endif /* ! (atarist || DOSISH) */
3537             if (s < bufend)
3538                 s++;
3539             if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf)
3540                 continue;       /* don't search dir with too-long name */
3541             if (len
3542 #  if defined(atarist) || defined(DOSISH)
3543                 && tmpbuf[len - 1] != '/'
3544                 && tmpbuf[len - 1] != '\\'
3545 #  endif
3546                )
3547                 tmpbuf[len++] = '/';
3548             if (len == 2 && tmpbuf[0] == '.')
3549                 seen_dot = 1;
3550             (void)my_strlcpy(tmpbuf + len, scriptname, sizeof(tmpbuf) - len);
3551 #endif  /* !VMS */
3552
3553 #ifdef SEARCH_EXTS
3554             len = strlen(tmpbuf);
3555             if (extidx > 0)     /* reset after previous loop */
3556                 extidx = 0;
3557             do {
3558 #endif
3559                 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tmpbuf));
3560                 retval = PerlLIO_stat(tmpbuf,&PL_statbuf);
3561                 if (S_ISDIR(PL_statbuf.st_mode)) {
3562                     retval = -1;
3563                 }
3564 #ifdef SEARCH_EXTS
3565             } while (  retval < 0               /* not there */
3566                     && extidx>=0 && ext[extidx] /* try an extension? */
3567                     && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len)
3568                 );
3569 #endif
3570             if (retval < 0)
3571                 continue;
3572             if (S_ISREG(PL_statbuf.st_mode)
3573                 && cando(S_IRUSR,TRUE,&PL_statbuf)
3574 #if !defined(DOSISH)
3575                 && cando(S_IXUSR,TRUE,&PL_statbuf)
3576 #endif
3577                 )
3578             {
3579                 xfound = tmpbuf;                /* bingo! */
3580                 break;
3581             }
3582             if (!xfailed)
3583                 xfailed = savepv(tmpbuf);
3584         }
3585 #ifndef DOSISH
3586         if (!xfound && !seen_dot && !xfailed &&
3587             (PerlLIO_stat(scriptname,&PL_statbuf) < 0
3588              || S_ISDIR(PL_statbuf.st_mode)))
3589 #endif
3590             seen_dot = 1;                       /* Disable message. */
3591         if (!xfound) {
3592             if (flags & 1) {                    /* do or die? */
3593                 Perl_croak(aTHX_ "Can't %s %s%s%s",
3594                       (xfailed ? "execute" : "find"),
3595                       (xfailed ? xfailed : scriptname),
3596                       (xfailed ? "" : " on PATH"),
3597                       (xfailed || seen_dot) ? "" : ", '.' not in PATH");
3598             }
3599             scriptname = NULL;
3600         }
3601         Safefree(xfailed);
3602         scriptname = xfound;
3603     }
3604     return (scriptname ? savepv(scriptname) : NULL);
3605 }
3606
3607 #ifndef PERL_GET_CONTEXT_DEFINED
3608
3609 void *
3610 Perl_get_context(void)
3611 {
3612     dVAR;
3613 #if defined(USE_ITHREADS)
3614 #  ifdef OLD_PTHREADS_API
3615     pthread_addr_t t;
3616     if (pthread_getspecific(PL_thr_key, &t))
3617         Perl_croak_nocontext("panic: pthread_getspecific");
3618     return (void*)t;
3619 #  else
3620 #    ifdef I_MACH_CTHREADS
3621     return (void*)cthread_data(cthread_self());
3622 #    else
3623     return (void*)PTHREAD_GETSPECIFIC(PL_thr_key);
3624 #    endif
3625 #  endif
3626 #else
3627     return (void*)NULL;
3628 #endif
3629 }
3630
3631 void
3632 Perl_set_context(void *t)
3633 {
3634     dVAR;
3635     PERL_ARGS_ASSERT_SET_CONTEXT;
3636 #if defined(USE_ITHREADS)
3637 #  ifdef I_MACH_CTHREADS
3638     cthread_set_data(cthread_self(), t);
3639 #  else
3640     if (pthread_setspecific(PL_thr_key, t))
3641         Perl_croak_nocontext("panic: pthread_setspecific");
3642 #  endif
3643 #else
3644     PERL_UNUSED_ARG(t);
3645 #endif
3646 }
3647
3648 #endif /* !PERL_GET_CONTEXT_DEFINED */
3649
3650 #if defined(PERL_GLOBAL_STRUCT) && !defined(PERL_GLOBAL_STRUCT_PRIVATE)
3651 struct perl_vars *
3652 Perl_GetVars(pTHX)
3653 {
3654  return &PL_Vars;
3655 }
3656 #endif
3657
3658 char **
3659 Perl_get_op_names(pTHX)
3660 {
3661     PERL_UNUSED_CONTEXT;
3662     return (char **)PL_op_name;
3663 }
3664
3665 char **
3666 Perl_get_op_descs(pTHX)
3667 {
3668     PERL_UNUSED_CONTEXT;
3669     return (char **)PL_op_desc;
3670 }
3671
3672 const char *
3673 Perl_get_no_modify(pTHX)
3674 {
3675     PERL_UNUSED_CONTEXT;
3676     return PL_no_modify;
3677 }
3678
3679 U32 *
3680 Perl_get_opargs(pTHX)
3681 {
3682     PERL_UNUSED_CONTEXT;
3683     return (U32 *)PL_opargs;
3684 }
3685
3686 PPADDR_t*
3687 Perl_get_ppaddr(pTHX)
3688 {
3689     dVAR;
3690     PERL_UNUSED_CONTEXT;
3691     return (PPADDR_t*)PL_ppaddr;
3692 }
3693
3694 #ifndef HAS_GETENV_LEN
3695 char *
3696 Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len)
3697 {
3698     char * const env_trans = PerlEnv_getenv(env_elem);
3699     PERL_UNUSED_CONTEXT;
3700     PERL_ARGS_ASSERT_GETENV_LEN;
3701     if (env_trans)
3702         *len = strlen(env_trans);
3703     return env_trans;
3704 }
3705 #endif
3706
3707
3708 MGVTBL*
3709 Perl_get_vtbl(pTHX_ int vtbl_id)
3710 {
3711     const MGVTBL* result;
3712     PERL_UNUSED_CONTEXT;
3713
3714     switch(vtbl_id) {
3715     case want_vtbl_sv:
3716         result = &PL_vtbl_sv;
3717         break;
3718     case want_vtbl_env:
3719         result = &PL_vtbl_env;
3720         break;
3721     case want_vtbl_envelem:
3722         result = &PL_vtbl_envelem;
3723         break;
3724     case want_vtbl_sig:
3725         result = &PL_vtbl_sig;
3726         break;
3727     case want_vtbl_sigelem:
3728         result = &PL_vtbl_sigelem;
3729         break;
3730     case want_vtbl_pack:
3731         result = &PL_vtbl_pack;
3732         break;
3733     case want_vtbl_packelem:
3734         result = &PL_vtbl_packelem;
3735         break;
3736     case want_vtbl_dbline:
3737         result = &PL_vtbl_dbline;
3738         break;
3739     case want_vtbl_isa:
3740         result = &PL_vtbl_isa;
3741         break;
3742     case want_vtbl_isaelem:
3743         result = &PL_vtbl_isaelem;
3744         break;
3745     case want_vtbl_arylen:
3746         result = &PL_vtbl_arylen;
3747         break;
3748     case want_vtbl_mglob:
3749         result = &PL_vtbl_mglob;
3750         break;
3751     case want_vtbl_nkeys:
3752         result = &PL_vtbl_nkeys;
3753         break;
3754     case want_vtbl_taint:
3755         result = &PL_vtbl_taint;
3756         break;
3757     case want_vtbl_substr:
3758         result = &PL_vtbl_substr;
3759         break;
3760     case want_vtbl_vec:
3761         result = &PL_vtbl_vec;
3762         break;
3763     case want_vtbl_pos:
3764         result = &PL_vtbl_pos;
3765         break;
3766     case want_vtbl_bm:
3767         result = &PL_vtbl_bm;
3768         break;
3769     case want_vtbl_fm:
3770         result = &PL_vtbl_fm;
3771         break;
3772     case want_vtbl_uvar:
3773         result = &PL_vtbl_uvar;
3774         break;
3775     case want_vtbl_defelem:
3776         result = &PL_vtbl_defelem;
3777         break;
3778     case want_vtbl_regexp:
3779         result = &PL_vtbl_regexp;
3780         break;
3781     case want_vtbl_regdata:
3782         result = &PL_vtbl_regdata;
3783         break;
3784     case want_vtbl_regdatum:
3785         result = &PL_vtbl_regdatum;
3786         break;
3787 #ifdef USE_LOCALE_COLLATE
3788     case want_vtbl_collxfrm:
3789         result = &PL_vtbl_collxfrm;
3790         break;
3791 #endif
3792     case want_vtbl_amagic:
3793         result = &PL_vtbl_amagic;
3794         break;
3795     case want_vtbl_amagicelem:
3796         result = &PL_vtbl_amagicelem;
3797         break;
3798     case want_vtbl_backref:
3799         result = &PL_vtbl_backref;
3800         break;
3801     case want_vtbl_utf8:
3802         result = &PL_vtbl_utf8;
3803         break;
3804     default:
3805         result = NULL;
3806         break;
3807     }
3808     return (MGVTBL*)result;
3809 }
3810
3811 I32
3812 Perl_my_fflush_all(pTHX)
3813 {
3814 #if defined(USE_PERLIO) || defined(FFLUSH_NULL) || defined(USE_SFIO)
3815     return PerlIO_flush(NULL);
3816 #else
3817 # if defined(HAS__FWALK)
3818     extern int fflush(FILE *);
3819     /* undocumented, unprototyped, but very useful BSDism */
3820     extern void _fwalk(int (*)(FILE *));
3821     _fwalk(&fflush);
3822     return 0;
3823 # else
3824 #  if defined(FFLUSH_ALL) && defined(HAS_STDIO_STREAM_ARRAY)
3825     long open_max = -1;
3826 #   ifdef PERL_FFLUSH_ALL_FOPEN_MAX
3827     open_max = PERL_FFLUSH_ALL_FOPEN_MAX;
3828 #   else
3829 #    if defined(HAS_SYSCONF) && defined(_SC_OPEN_MAX)
3830     open_max = sysconf(_SC_OPEN_MAX);
3831 #     else
3832 #      ifdef FOPEN_MAX
3833     open_max = FOPEN_MAX;
3834 #      else
3835 #       ifdef OPEN_MAX
3836     open_max = OPEN_MAX;
3837 #       else
3838 #        ifdef _NFILE
3839     open_max = _NFILE;
3840 #        endif
3841 #       endif
3842 #      endif
3843 #     endif
3844 #    endif
3845     if (open_max > 0) {
3846       long i;
3847       for (i = 0; i < open_max; i++)
3848             if (STDIO_STREAM_ARRAY[i]._file >= 0 &&
3849                 STDIO_STREAM_ARRAY[i]._file < open_max &&
3850                 STDIO_STREAM_ARRAY[i]._flag)
3851                 PerlIO_flush(&STDIO_STREAM_ARRAY[i]);
3852       return 0;
3853     }
3854 #  endif
3855     SETERRNO(EBADF,RMS_IFI);
3856     return EOF;
3857 # endif
3858 #endif
3859 }
3860
3861 void
3862 Perl_report_wrongway_fh(pTHX_ const GV *gv, const char have)
3863 {
3864     if (ckWARN(WARN_IO)) {
3865         const char * const name
3866             = gv && (isGV(gv) || isGV_with_GP(gv)) ? GvENAME(gv) : NULL;
3867         const char * const direction = have == '>' ? "out" : "in";
3868
3869         if (name && *name)
3870             Perl_warner(aTHX_ packWARN(WARN_IO),
3871                         "Filehandle %s opened only for %sput",
3872                         name, direction);
3873         else
3874             Perl_warner(aTHX_ packWARN(WARN_IO),
3875                         "Filehandle opened only for %sput", direction);
3876     }
3877 }
3878
3879 void
3880 Perl_report_evil_fh(pTHX_ const GV *gv)
3881 {
3882     const IO *io = gv ? GvIO(gv) : NULL;
3883     const PERL_BITFIELD16 op = PL_op->op_type;
3884     const char *vile;
3885     I32 warn_type;
3886
3887     if (io && IoTYPE(io) == IoTYPE_CLOSED) {
3888         vile = "closed";
3889         warn_type = WARN_CLOSED;
3890     }
3891     else {
3892         vile = "unopened";
3893         warn_type = WARN_UNOPENED;
3894     }
3895
3896     if (ckWARN(warn_type)) {
3897         const char * const name
3898             = gv && (isGV(gv) || isGV_with_GP(gv)) ? GvENAME(gv) : NULL;
3899         const char * const pars =
3900             (const char *)(OP_IS_FILETEST(op) ? "" : "()");
3901         const char * const func =
3902             (const char *)
3903             (op == OP_READLINE   ? "readline"  :        /* "<HANDLE>" not nice */
3904              op == OP_LEAVEWRITE ? "write" :            /* "write exit" not nice */
3905              PL_op_desc[op]);
3906         const char * const type =
3907             (const char *)
3908             (OP_IS_SOCKET(op) || (io && IoTYPE(io) == IoTYPE_SOCKET)
3909              ? "socket" : "filehandle");
3910         if (name && *name) {
3911             Perl_warner(aTHX_ packWARN(warn_type),
3912                         "%s%s on %s %s %s", func, pars, vile, type, name);
3913             if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3914                 Perl_warner(
3915                             aTHX_ packWARN(warn_type),
3916                             "\t(Are you trying to call %s%s on dirhandle %s?)\n",
3917                             func, pars, name
3918                             );
3919         }
3920         else {
3921             Perl_warner(aTHX_ packWARN(warn_type),
3922                         "%s%s on %s %s", func, pars, vile, type);
3923             if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3924                 Perl_warner(
3925                             aTHX_ packWARN(warn_type),
3926                             "\t(Are you trying to call %s%s on dirhandle?)\n",
3927                             func, pars
3928                             );
3929         }
3930     }
3931 }
3932
3933 /* To workaround core dumps from the uninitialised tm_zone we get the
3934  * system to give us a reasonable struct to copy.  This fix means that
3935  * strftime uses the tm_zone and tm_gmtoff values returned by
3936  * localtime(time()). That should give the desired result most of the
3937  * time. But probably not always!
3938  *
3939  * This does not address tzname aspects of NETaa14816.
3940  *
3941  */
3942
3943 #ifdef HAS_GNULIBC
3944 # ifndef STRUCT_TM_HASZONE
3945 #    define STRUCT_TM_HASZONE
3946 # endif
3947 #endif
3948
3949 #ifdef STRUCT_TM_HASZONE /* Backward compat */
3950 # ifndef HAS_TM_TM_ZONE
3951 #    define HAS_TM_TM_ZONE
3952 # endif
3953 #endif
3954
3955 void
3956 Perl_init_tm(pTHX_ struct tm *ptm)      /* see mktime, strftime and asctime */
3957 {
3958 #ifdef HAS_TM_TM_ZONE
3959     Time_t now;
3960     const struct tm* my_tm;
3961     PERL_ARGS_ASSERT_INIT_TM;
3962     (void)time(&now);
3963     my_tm = localtime(&now);
3964     if (my_tm)
3965         Copy(my_tm, ptm, 1, struct tm);
3966 #else
3967     PERL_ARGS_ASSERT_INIT_TM;
3968     PERL_UNUSED_ARG(ptm);
3969 #endif
3970 }
3971
3972 /*
3973  * mini_mktime - normalise struct tm values without the localtime()
3974  * semantics (and overhead) of mktime().
3975  */
3976 void
3977 Perl_mini_mktime(pTHX_ struct tm *ptm)
3978 {
3979     int yearday;
3980     int secs;
3981     int month, mday, year, jday;
3982     int odd_cent, odd_year;
3983     PERL_UNUSED_CONTEXT;
3984
3985     PERL_ARGS_ASSERT_MINI_MKTIME;
3986
3987 #define DAYS_PER_YEAR   365
3988 #define DAYS_PER_QYEAR  (4*DAYS_PER_YEAR+1)
3989 #define DAYS_PER_CENT   (25*DAYS_PER_QYEAR-1)
3990 #define DAYS_PER_QCENT  (4*DAYS_PER_CENT+1)
3991 #define SECS_PER_HOUR   (60*60)
3992 #define SECS_PER_DAY    (24*SECS_PER_HOUR)
3993 /* parentheses deliberately absent on these two, otherwise they don't work */
3994 #define MONTH_TO_DAYS   153/5
3995 #define DAYS_TO_MONTH   5/153
3996 /* offset to bias by March (month 4) 1st between month/mday & year finding */
3997 #define YEAR_ADJUST     (4*MONTH_TO_DAYS+1)
3998 /* as used here, the algorithm leaves Sunday as day 1 unless we adjust it */
3999 #define WEEKDAY_BIAS    6       /* (1+6)%7 makes Sunday 0 again */
4000
4001 /*
4002  * Year/day algorithm notes:
4003  *
4004  * With a suitable offset for numeric value of the month, one can find
4005  * an offset into the year by considering months to have 30.6 (153/5) days,
4006  * using integer arithmetic (i.e., with truncation).  To avoid too much
4007  * messing about with leap days, we consider January and February to be
4008  * the 13th and 14th month of the previous year.  After that transformation,
4009  * we need the month index we use to be high by 1 from 'normal human' usage,
4010  * so the month index values we use run from 4 through 15.
4011  *
4012  * Given that, and the rules for the Gregorian calendar (leap years are those
4013  * divisible by 4 unless also divisible by 100, when they must be divisible
4014  * by 400 instead), we can simply calculate the number of days since some
4015  * arbitrary 'beginning of time' by futzing with the (adjusted) year number,
4016  * the days we derive from our month index, and adding in the day of the
4017  * month.  The value used here is not adjusted for the actual origin which
4018  * it normally would use (1 January A.D. 1), since we're not exposing it.
4019  * We're only building the value so we can turn around and get the
4020  * normalised values for the year, month, day-of-month, and day-of-year.
4021  *
4022  * For going backward, we need to bias the value we're using so that we find
4023  * the right year value.  (Basically, we don't want the contribution of
4024  * March 1st to the number to apply while deriving the year).  Having done
4025  * that, we 'count up' the contribution to the year number by accounting for
4026  * full quadracenturies (400-year periods) with their extra leap days, plus
4027  * the contribution from full centuries (to avoid counting in the lost leap
4028  * days), plus the contribution from full quad-years (to count in the normal
4029  * leap days), plus the leftover contribution from any non-leap years.
4030  * At this point, if we were working with an actual leap day, we'll have 0
4031  * days left over.  This is also true for March 1st, however.  So, we have
4032  * to special-case that result, and (earlier) keep track of the 'odd'
4033  * century and year contributions.  If we got 4 extra centuries in a qcent,
4034  * or 4 extra years in a qyear, then it's a leap day and we call it 29 Feb.
4035  * Otherwise, we add back in the earlier bias we removed (the 123 from
4036  * figuring in March 1st), find the month index (integer division by 30.6),
4037  * and the remainder is the day-of-month.  We then have to convert back to
4038  * 'real' months (including fixing January and February from being 14/15 in
4039  * the previous year to being in the proper year).  After that, to get
4040  * tm_yday, we work with the normalised year and get a new yearday value for
4041  * January 1st, which we subtract from the yearday value we had earlier,
4042  * representing the date we've re-built.  This is done from January 1
4043  * because tm_yday is 0-origin.
4044  *
4045  * Since POSIX time routines are only guaranteed to work for times since the
4046  * UNIX epoch (00:00:00 1 Jan 1970 UTC), the fact that this algorithm
4047  * applies Gregorian calendar rules even to dates before the 16th century
4048  * doesn't bother me.  Besides, you'd need cultural context for a given
4049  * date to know whether it was Julian or Gregorian calendar, and that's
4050  * outside the scope for this routine.  Since we convert back based on the
4051  * same rules we used to build the yearday, you'll only get strange results
4052  * for input which needed normalising, or for the 'odd' century years which
4053  * were leap years in the Julian calendar but not in the Gregorian one.
4054  * I can live with that.
4055  *
4056  * This algorithm also fails to handle years before A.D. 1 gracefully, but
4057  * that's still outside the scope for POSIX time manipulation, so I don't
4058  * care.
4059  */
4060
4061     year = 1900 + ptm->tm_year;
4062     month = ptm->tm_mon;
4063     mday = ptm->tm_mday;
4064     /* allow given yday with no month & mday to dominate the result */
4065     if (ptm->tm_yday >= 0 && mday <= 0 && month <= 0) {
4066         month = 0;
4067         mday = 0;
4068         jday = 1 + ptm->tm_yday;
4069     }
4070     else {
4071         jday = 0;
4072     }
4073     if (month >= 2)
4074         month+=2;
4075     else
4076         month+=14, year--;
4077     yearday = DAYS_PER_YEAR * year + year/4 - year/100 + year/400;
4078     yearday += month*MONTH_TO_DAYS + mday + jday;
4079     /*
4080      * Note that we don't know when leap-seconds were or will be,
4081      * so we have to trust the user if we get something which looks
4082      * like a sensible leap-second.  Wild values for seconds will
4083      * be rationalised, however.
4084      */
4085     if ((unsigned) ptm->tm_sec <= 60) {
4086         secs = 0;
4087     }
4088     else {
4089         secs = ptm->tm_sec;
4090         ptm->tm_sec = 0;
4091     }
4092     secs += 60 * ptm->tm_min;
4093     secs += SECS_PER_HOUR * ptm->tm_hour;
4094     if (secs < 0) {
4095         if (secs-(secs/SECS_PER_DAY*SECS_PER_DAY) < 0) {
4096             /* got negative remainder, but need positive time */
4097             /* back off an extra day to compensate */
4098             yearday += (secs/SECS_PER_DAY)-1;
4099             secs -= SECS_PER_DAY * (secs/SECS_PER_DAY - 1);
4100         }
4101         else {
4102             yearday += (secs/SECS_PER_DAY);
4103             secs -= SECS_PER_DAY * (secs/SECS_PER_DAY);
4104         }
4105     }
4106     else if (secs >= SECS_PER_DAY) {
4107         yearday += (secs/SECS_PER_DAY);
4108         secs %= SECS_PER_DAY;
4109     }
4110     ptm->tm_hour = secs/SECS_PER_HOUR;
4111     secs %= SECS_PER_HOUR;
4112     ptm->tm_min = secs/60;
4113     secs %= 60;
4114     ptm->tm_sec += secs;
4115     /* done with time of day effects */
4116     /*
4117      * The algorithm for yearday has (so far) left it high by 428.
4118      * To avoid mistaking a legitimate Feb 29 as Mar 1, we need to
4119      * bias it by 123 while trying to figure out what year it
4120      * really represents.  Even with this tweak, the reverse
4121      * translation fails for years before A.D. 0001.
4122      * It would still fail for Feb 29, but we catch that one below.
4123      */
4124     jday = yearday;     /* save for later fixup vis-a-vis Jan 1 */
4125     yearday -= YEAR_ADJUST;
4126     year = (yearday / DAYS_PER_QCENT) * 400;
4127     yearday %= DAYS_PER_QCENT;
4128     odd_cent = yearday / DAYS_PER_CENT;
4129     year += odd_cent * 100;
4130     yearday %= DAYS_PER_CENT;
4131     year += (yearday / DAYS_PER_QYEAR) * 4;
4132     yearday %= DAYS_PER_QYEAR;
4133     odd_year = yearday / DAYS_PER_YEAR;
4134     year += odd_year;
4135     yearday %= DAYS_PER_YEAR;
4136     if (!yearday && (odd_cent==4 || odd_year==4)) { /* catch Feb 29 */
4137         month = 1;
4138         yearday = 29;
4139     }
4140     else {
4141         yearday += YEAR_ADJUST; /* recover March 1st crock */
4142         month = yearday*DAYS_TO_MONTH;
4143         yearday -= month*MONTH_TO_DAYS;
4144         /* recover other leap-year adjustment */
4145         if (month > 13) {
4146             month-=14;
4147             year++;
4148         }
4149         else {
4150             month-=2;
4151         }
4152     }
4153     ptm->tm_year = year - 1900;
4154     if (yearday) {
4155       ptm->tm_mday = yearday;
4156       ptm->tm_mon = month;
4157     }
4158     else {
4159       ptm->tm_mday = 31;
4160       ptm->tm_mon = month - 1;
4161     }
4162     /* re-build yearday based on Jan 1 to get tm_yday */
4163     year--;
4164     yearday = year*DAYS_PER_YEAR + year/4 - year/100 + year/400;
4165     yearday += 14*MONTH_TO_DAYS + 1;
4166     ptm->tm_yday = jday - yearday;
4167     /* fix tm_wday if not overridden by caller */
4168     if ((unsigned)ptm->tm_wday > 6)
4169         ptm->tm_wday = (jday + WEEKDAY_BIAS) % 7;
4170 }
4171
4172 char *
4173 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)
4174 {
4175 #ifdef HAS_STRFTIME
4176   char *buf;
4177   int buflen;
4178   struct tm mytm;
4179   int len;
4180
4181   PERL_ARGS_ASSERT_MY_STRFTIME;
4182
4183   init_tm(&mytm);       /* XXX workaround - see init_tm() above */
4184   mytm.tm_sec = sec;
4185   mytm.tm_min = min;
4186   mytm.tm_hour = hour;
4187   mytm.tm_mday = mday;
4188   mytm.tm_mon = mon;
4189   mytm.tm_year = year;
4190   mytm.tm_wday = wday;
4191   mytm.tm_yday = yday;
4192   mytm.tm_isdst = isdst;
4193   mini_mktime(&mytm);
4194   /* use libc to get the values for tm_gmtoff and tm_zone [perl #18238] */
4195 #if defined(HAS_MKTIME) && (defined(HAS_TM_TM_GMTOFF) || defined(HAS_TM_TM_ZONE))
4196   STMT_START {
4197     struct tm mytm2;
4198     mytm2 = mytm;
4199     mktime(&mytm2);
4200 #ifdef HAS_TM_TM_GMTOFF
4201     mytm.tm_gmtoff = mytm2.tm_gmtoff;
4202 #endif
4203 #ifdef HAS_TM_TM_ZONE
4204     mytm.tm_zone = mytm2.tm_zone;
4205 #endif
4206   } STMT_END;
4207 #endif
4208   buflen = 64;
4209   Newx(buf, buflen, char);
4210   len = strftime(buf, buflen, fmt, &mytm);
4211   /*
4212   ** The following is needed to handle to the situation where
4213   ** tmpbuf overflows.  Basically we want to allocate a buffer
4214   ** and try repeatedly.  The reason why it is so complicated
4215   ** is that getting a return value of 0 from strftime can indicate
4216   ** one of the following:
4217   ** 1. buffer overflowed,
4218   ** 2. illegal conversion specifier, or
4219   ** 3. the format string specifies nothing to be returned(not
4220   **      an error).  This could be because format is an empty string
4221   **    or it specifies %p that yields an empty string in some locale.
4222   ** If there is a better way to make it portable, go ahead by
4223   ** all means.
4224   */
4225   if ((len > 0 && len < buflen) || (len == 0 && *fmt == '\0'))
4226     return buf;
4227   else {
4228     /* Possibly buf overflowed - try again with a bigger buf */
4229     const int fmtlen = strlen(fmt);
4230     int bufsize = fmtlen + buflen;
4231
4232     Renew(buf, bufsize, char);
4233     while (buf) {
4234       buflen = strftime(buf, bufsize, fmt, &mytm);
4235       if (buflen > 0 && buflen < bufsize)
4236         break;
4237       /* heuristic to prevent out-of-memory errors */
4238       if (bufsize > 100*fmtlen) {
4239         Safefree(buf);
4240         buf = NULL;
4241         break;
4242       }
4243       bufsize *= 2;
4244       Renew(buf, bufsize, char);
4245     }
4246     return buf;
4247   }
4248 #else
4249   Perl_croak(aTHX_ "panic: no strftime");
4250   return NULL;
4251 #endif
4252 }
4253
4254
4255 #define SV_CWD_RETURN_UNDEF \
4256 sv_setsv(sv, &PL_sv_undef); \
4257 return FALSE
4258
4259 #define SV_CWD_ISDOT(dp) \
4260     (dp->d_name[0] == '.' && (dp->d_name[1] == '\0' || \
4261         (dp->d_name[1] == '.' && dp->d_name[2] == '\0')))
4262
4263 /*
4264 =head1 Miscellaneous Functions
4265
4266 =for apidoc getcwd_sv
4267
4268 Fill the sv with current working directory
4269
4270 =cut
4271 */
4272
4273 /* Originally written in Perl by John Bazik; rewritten in C by Ben Sugars.
4274  * rewritten again by dougm, optimized for use with xs TARG, and to prefer
4275  * getcwd(3) if available
4276  * Comments from the orignal:
4277  *     This is a faster version of getcwd.  It's also more dangerous
4278  *     because you might chdir out of a directory that you can't chdir
4279  *     back into. */
4280
4281 int
4282 Perl_getcwd_sv(pTHX_ register SV *sv)
4283 {
4284 #ifndef PERL_MICRO
4285     dVAR;
4286 #ifndef INCOMPLETE_TAINTS
4287     SvTAINTED_on(sv);
4288 #endif
4289
4290     PERL_ARGS_ASSERT_GETCWD_SV;
4291
4292 #ifdef HAS_GETCWD
4293     {
4294         char buf[MAXPATHLEN];
4295
4296         /* Some getcwd()s automatically allocate a buffer of the given
4297          * size from the heap if they are given a NULL buffer pointer.
4298          * The problem is that this behaviour is not portable. */
4299         if (getcwd(buf, sizeof(buf) - 1)) {
4300             sv_setpv(sv, buf);
4301             return TRUE;
4302         }
4303         else {
4304             sv_setsv(sv, &PL_sv_undef);
4305             return FALSE;
4306         }
4307     }
4308
4309 #else
4310
4311     Stat_t statbuf;
4312     int orig_cdev, orig_cino, cdev, cino, odev, oino, tdev, tino;
4313     int pathlen=0;
4314     Direntry_t *dp;
4315
4316     SvUPGRADE(sv, SVt_PV);
4317
4318     if (PerlLIO_lstat(".", &statbuf) < 0) {
4319         SV_CWD_RETURN_UNDEF;
4320     }
4321
4322     orig_cdev = statbuf.st_dev;
4323     orig_cino = statbuf.st_ino;
4324     cdev = orig_cdev;
4325     cino = orig_cino;
4326
4327     for (;;) {
4328         DIR *dir;
4329         int namelen;
4330         odev = cdev;
4331         oino = cino;
4332
4333         if (PerlDir_chdir("..") < 0) {
4334             SV_CWD_RETURN_UNDEF;
4335         }
4336         if (PerlLIO_stat(".", &statbuf) < 0) {
4337             SV_CWD_RETURN_UNDEF;
4338         }
4339
4340         cdev = statbuf.st_dev;
4341         cino = statbuf.st_ino;
4342
4343         if (odev == cdev && oino == cino) {
4344             break;
4345         }
4346         if (!(dir = PerlDir_open("."))) {
4347             SV_CWD_RETURN_UNDEF;
4348         }
4349
4350         while ((dp = PerlDir_read(dir)) != NULL) {
4351 #ifdef DIRNAMLEN
4352             namelen = dp->d_namlen;
4353 #else
4354             namelen = strlen(dp->d_name);
4355 #endif
4356             /* skip . and .. */
4357             if (SV_CWD_ISDOT(dp)) {
4358                 continue;
4359             }
4360
4361             if (PerlLIO_lstat(dp->d_name, &statbuf) < 0) {
4362                 SV_CWD_RETURN_UNDEF;
4363             }
4364
4365             tdev = statbuf.st_dev;
4366             tino = statbuf.st_ino;
4367             if (tino == oino && tdev == odev) {
4368                 break;
4369             }
4370         }
4371
4372         if (!dp) {
4373             SV_CWD_RETURN_UNDEF;
4374         }
4375
4376         if (pathlen + namelen + 1 >= MAXPATHLEN) {
4377             SV_CWD_RETURN_UNDEF;
4378         }
4379
4380         SvGROW(sv, pathlen + namelen + 1);
4381
4382         if (pathlen) {
4383             /* shift down */
4384             Move(SvPVX_const(sv), SvPVX(sv) + namelen + 1, pathlen, char);
4385         }
4386
4387         /* prepend current directory to the front */
4388         *SvPVX(sv) = '/';
4389         Move(dp->d_name, SvPVX(sv)+1, namelen, char);
4390         pathlen += (namelen + 1);
4391
4392 #ifdef VOID_CLOSEDIR
4393         PerlDir_close(dir);
4394 #else
4395         if (PerlDir_close(dir) < 0) {
4396             SV_CWD_RETURN_UNDEF;
4397         }
4398 #endif
4399     }
4400
4401     if (pathlen) {
4402         SvCUR_set(sv, pathlen);
4403         *SvEND(sv) = '\0';
4404         SvPOK_only(sv);
4405
4406         if (PerlDir_chdir(SvPVX_const(sv)) < 0) {
4407             SV_CWD_RETURN_UNDEF;
4408         }
4409     }
4410     if (PerlLIO_stat(".", &statbuf) < 0) {
4411         SV_CWD_RETURN_UNDEF;
4412     }
4413
4414     cdev = statbuf.st_dev;
4415     cino = statbuf.st_ino;
4416
4417     if (cdev != orig_cdev || cino != orig_cino) {
4418         Perl_croak(aTHX_ "Unstable directory path, "
4419                    "current directory changed unexpectedly");
4420     }
4421
4422     return TRUE;
4423 #endif
4424
4425 #else
4426     return FALSE;
4427 #endif
4428 }
4429
4430 #define VERSION_MAX 0x7FFFFFFF
4431
4432 /*
4433 =for apidoc prescan_version
4434
4435 Validate that a given string can be parsed as a version object, but doesn't
4436 actually perform the parsing.  Can use either strict or lax validation rules.
4437 Can optionally set a number of hint variables to save the parsing code
4438 some time when tokenizing.
4439
4440 =cut
4441 */
4442 const char *
4443 Perl_prescan_version(pTHX_ const char *s, bool strict,
4444                      const char **errstr,
4445                      bool *sqv, int *ssaw_decimal, int *swidth, bool *salpha) {
4446     bool qv = (sqv ? *sqv : FALSE);
4447     int width = 3;
4448     int saw_decimal = 0;
4449     bool alpha = FALSE;
4450     const char *d = s;
4451
4452     PERL_ARGS_ASSERT_PRESCAN_VERSION;
4453
4454     if (qv && isDIGIT(*d))
4455         goto dotted_decimal_version;
4456
4457     if (*d == 'v') { /* explicit v-string */
4458         d++;
4459         if (isDIGIT(*d)) {
4460             qv = TRUE;
4461         }
4462         else { /* degenerate v-string */
4463             /* requires v1.2.3 */
4464             BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
4465         }
4466
4467 dotted_decimal_version:
4468         if (strict && d[0] == '0' && isDIGIT(d[1])) {
4469             /* no leading zeros allowed */
4470             BADVERSION(s,errstr,"Invalid version format (no leading zeros)");
4471         }
4472
4473         while (isDIGIT(*d))     /* integer part */
4474             d++;
4475
4476         if (*d == '.')
4477         {
4478             saw_decimal++;
4479             d++;                /* decimal point */
4480         }
4481         else
4482         {
4483             if (strict) {
4484                 /* require v1.2.3 */
4485                 BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
4486             }
4487             else {
4488                 goto version_prescan_finish;
4489             }
4490         }
4491
4492         {
4493             int i = 0;
4494             int j = 0;
4495             while (isDIGIT(*d)) {       /* just keep reading */
4496                 i++;
4497                 while (isDIGIT(*d)) {
4498                     d++; j++;
4499                     /* maximum 3 digits between decimal */
4500                     if (strict && j > 3) {
4501                         BADVERSION(s,errstr,"Invalid version format (maximum 3 digits between decimals)");
4502                     }
4503                 }
4504                 if (*d == '_') {
4505                     if (strict) {
4506                         BADVERSION(s,errstr,"Invalid version format (no underscores)");
4507                     }
4508                     if ( alpha ) {
4509                         BADVERSION(s,errstr,"Invalid version format (multiple underscores)");
4510                     }
4511                     d++;
4512                     alpha = TRUE;
4513                 }
4514                 else if (*d == '.') {
4515                     if (alpha) {
4516                         BADVERSION(s,errstr,"Invalid version format (underscores before decimal)");
4517                     }
4518                     saw_decimal++;
4519                     d++;
4520                 }
4521                 else if (!isDIGIT(*d)) {
4522                     break;
4523                 }
4524                 j = 0;
4525             }
4526
4527             if (strict && i < 2) {
4528                 /* requires v1.2.3 */
4529                 BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
4530             }
4531         }
4532     }                                   /* end if dotted-decimal */
4533     else
4534     {                                   /* decimal versions */
4535         /* special strict case for leading '.' or '0' */
4536         if (strict) {
4537             if (*d == '.') {
4538                 BADVERSION(s,errstr,"Invalid version format (0 before decimal required)");
4539             }
4540             if (*d == '0' && isDIGIT(d[1])) {
4541                 BADVERSION(s,errstr,"Invalid version format (no leading zeros)");
4542             }
4543         }
4544
4545         /* consume all of the integer part */
4546         while (isDIGIT(*d))
4547             d++;
4548
4549         /* look for a fractional part */
4550         if (*d == '.') {
4551             /* we found it, so consume it */
4552             saw_decimal++;
4553             d++;
4554         }
4555         else if (!*d || *d == ';' || isSPACE(*d) || *d == '{' || *d == '}') {
4556             if ( d == s ) {
4557                 /* found nothing */
4558                 BADVERSION(s,errstr,"Invalid version format (version required)");
4559             }
4560             /* found just an integer */
4561             goto version_prescan_finish;
4562         }
4563         else if ( d == s ) {
4564             /* didn't find either integer or period */
4565             BADVERSION(s,errstr,"Invalid version format (non-numeric data)");
4566         }
4567         else if (*d == '_') {
4568             /* underscore can't come after integer part */
4569             if (strict) {
4570                 BADVERSION(s,errstr,"Invalid version format (no underscores)");
4571             }
4572             else if (isDIGIT(d[1])) {
4573                 BADVERSION(s,errstr,"Invalid version format (alpha without decimal)");
4574             }
4575             else {
4576                 BADVERSION(s,errstr,"Invalid version format (misplaced underscore)");
4577             }
4578         }
4579         else {
4580             /* anything else after integer part is just invalid data */
4581             BADVERSION(s,errstr,"Invalid version format (non-numeric data)");
4582         }
4583
4584         /* scan the fractional part after the decimal point*/
4585
4586         if (!isDIGIT(*d) && (strict || ! (!*d || *d == ';' || isSPACE(*d) || *d == '{' || *d == '}') )) {
4587                 /* strict or lax-but-not-the-end */
4588                 BADVERSION(s,errstr,"Invalid version format (fractional part required)");
4589         }
4590
4591         while (isDIGIT(*d)) {
4592             d++;
4593             if (*d == '.' && isDIGIT(d[-1])) {
4594                 if (alpha) {
4595                     BADVERSION(s,errstr,"Invalid version format (underscores before decimal)");
4596                 }
4597                 if (strict) {
4598                     BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions must begin with 'v')");
4599                 }
4600                 d = (char *)s;          /* start all over again */
4601                 qv = TRUE;
4602                 goto dotted_decimal_version;
4603             }
4604             if (*d == '_') {
4605                 if (strict) {
4606                     BADVERSION(s,errstr,"Invalid version format (no underscores)");
4607                 }
4608                 if ( alpha ) {
4609                     BADVERSION(s,errstr,"Invalid version format (multiple underscores)");
4610                 }
4611                 if ( ! isDIGIT(d[1]) ) {
4612                     BADVERSION(s,errstr,"Invalid version format (misplaced underscore)");
4613                 }
4614                 d++;
4615                 alpha = TRUE;
4616             }
4617         }
4618     }
4619
4620 version_prescan_finish:
4621     while (isSPACE(*d))
4622         d++;
4623
4624     if (!isDIGIT(*d) && (! (!*d || *d == ';' || *d == '{' || *d == '}') )) {
4625         /* trailing non-numeric data */
4626         BADVERSION(s,errstr,"Invalid version format (non-numeric data)");
4627     }
4628
4629     if (sqv)
4630         *sqv = qv;
4631     if (swidth)
4632         *swidth = width;
4633     if (ssaw_decimal)
4634         *ssaw_decimal = saw_decimal;
4635     if (salpha)
4636         *salpha = alpha;
4637     return d;
4638 }
4639
4640 /*
4641 =for apidoc scan_version
4642
4643 Returns a pointer to the next character after the parsed
4644 version string, as well as upgrading the passed in SV to
4645 an RV.
4646
4647 Function must be called with an already existing SV like
4648
4649     sv = newSV(0);
4650     s = scan_version(s, SV *sv, bool qv);
4651
4652 Performs some preprocessing to the string to ensure that
4653 it has the correct characteristics of a version.  Flags the
4654 object if it contains an underscore (which denotes this
4655 is an alpha version).  The boolean qv denotes that the version
4656 should be interpreted as if it had multiple decimals, even if
4657 it doesn't.
4658
4659 =cut
4660 */
4661
4662 const char *
4663 Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
4664 {
4665     const char *start;
4666     const char *pos;
4667     const char *last;
4668     const char *errstr = NULL;
4669     int saw_decimal = 0;
4670     int width = 3;
4671     bool alpha = FALSE;
4672     bool vinf = FALSE;
4673     AV * const av = newAV();
4674     SV * const hv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */
4675
4676     PERL_ARGS_ASSERT_SCAN_VERSION;
4677
4678     (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
4679
4680 #ifndef NODEFAULT_SHAREKEYS
4681     HvSHAREKEYS_on(hv);         /* key-sharing on by default */
4682 #endif
4683
4684     while (isSPACE(*s)) /* leading whitespace is OK */
4685         s++;
4686
4687     last = prescan_version(s, FALSE, &errstr, &qv, &saw_decimal, &width, &alpha);
4688     if (errstr) {
4689         /* "undef" is a special case and not an error */
4690         if ( ! ( *s == 'u' && strEQ(s,"undef")) ) {
4691             Perl_croak(aTHX_ "%s", errstr);
4692         }
4693     }
4694
4695     start = s;
4696     if (*s == 'v')
4697         s++;
4698     pos = s;
4699
4700     if ( qv )
4701         (void)hv_stores(MUTABLE_HV(hv), "qv", newSViv(qv));
4702     if ( alpha )
4703         (void)hv_stores(MUTABLE_HV(hv), "alpha", newSViv(alpha));
4704     if ( !qv && width < 3 )
4705         (void)hv_stores(MUTABLE_HV(hv), "width", newSViv(width));
4706
4707     while (isDIGIT(*pos))
4708         pos++;
4709     if (!isALPHA(*pos)) {
4710         I32 rev;
4711
4712         for (;;) {
4713             rev = 0;
4714             {
4715                 /* this is atoi() that delimits on underscores */
4716                 const char *end = pos;
4717                 I32 mult = 1;
4718                 I32 orev;
4719
4720                 /* the following if() will only be true after the decimal
4721                  * point of a version originally created with a bare
4722                  * floating point number, i.e. not quoted in any way
4723                  */
4724                 if ( !qv && s > start && saw_decimal == 1 ) {
4725                     mult *= 100;
4726                     while ( s < end ) {
4727                         orev = rev;
4728                         rev += (*s - '0') * mult;
4729                         mult /= 10;
4730                         if (   (PERL_ABS(orev) > PERL_ABS(rev))
4731                             || (PERL_ABS(rev) > VERSION_MAX )) {
4732                             Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4733                                            "Integer overflow in version %d",VERSION_MAX);
4734                             s = end - 1;
4735                             rev = VERSION_MAX;
4736                             vinf = 1;
4737                         }
4738                         s++;
4739                         if ( *s == '_' )
4740                             s++;
4741                     }
4742                 }
4743                 else {
4744                     while (--end >= s) {
4745                         orev = rev;
4746                         rev += (*end - '0') * mult;
4747                         mult *= 10;
4748                         if (   (PERL_ABS(orev) > PERL_ABS(rev))
4749                             || (PERL_ABS(rev) > VERSION_MAX )) {
4750                             Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4751                                            "Integer overflow in version");
4752                             end = s - 1;
4753                             rev = VERSION_MAX;
4754                             vinf = 1;
4755                         }
4756                     }
4757                 }
4758             }
4759
4760             /* Append revision */
4761             av_push(av, newSViv(rev));
4762             if ( vinf ) {
4763                 s = last;
4764                 break;
4765             }
4766             else if ( *pos == '.' )
4767                 s = ++pos;
4768             else if ( *pos == '_' && isDIGIT(pos[1]) )
4769                 s = ++pos;
4770             else if ( *pos == ',' && isDIGIT(pos[1]) )
4771                 s = ++pos;
4772             else if ( isDIGIT(*pos) )
4773                 s = pos;
4774             else {
4775                 s = pos;
4776                 break;
4777             }
4778             if ( qv ) {
4779                 while ( isDIGIT(*pos) )
4780                     pos++;
4781             }
4782             else {
4783                 int digits = 0;
4784                 while ( ( isDIGIT(*pos) || *pos == '_' ) && digits < 3 ) {
4785                     if ( *pos != '_' )
4786                         digits++;
4787                     pos++;
4788                 }
4789             }
4790         }
4791     }
4792     if ( qv ) { /* quoted versions always get at least three terms*/
4793         I32 len = av_len(av);
4794         /* This for loop appears to trigger a compiler bug on OS X, as it
4795            loops infinitely. Yes, len is negative. No, it makes no sense.
4796            Compiler in question is:
4797            gcc version 3.3 20030304 (Apple Computer, Inc. build 1640)
4798            for ( len = 2 - len; len > 0; len-- )
4799            av_push(MUTABLE_AV(sv), newSViv(0));
4800         */
4801         len = 2 - len;
4802         while (len-- > 0)
4803             av_push(av, newSViv(0));
4804     }
4805
4806     /* need to save off the current version string for later */
4807     if ( vinf ) {
4808         SV * orig = newSVpvn("v.Inf", sizeof("v.Inf")-1);
4809         (void)hv_stores(MUTABLE_HV(hv), "original", orig);
4810         (void)hv_stores(MUTABLE_HV(hv), "vinf", newSViv(1));
4811     }
4812     else if ( s > start ) {
4813         SV * orig = newSVpvn(start,s-start);
4814         if ( qv && saw_decimal == 1 && *start != 'v' ) {
4815             /* need to insert a v to be consistent */
4816             sv_insert(orig, 0, 0, "v", 1);
4817         }
4818         (void)hv_stores(MUTABLE_HV(hv), "original", orig);
4819     }
4820     else {
4821         (void)hv_stores(MUTABLE_HV(hv), "original", newSVpvs("0"));
4822         av_push(av, newSViv(0));
4823     }
4824
4825     /* And finally, store the AV in the hash */
4826     (void)hv_stores(MUTABLE_HV(hv), "version", newRV_noinc(MUTABLE_SV(av)));
4827
4828     /* fix RT#19517 - special case 'undef' as string */
4829     if ( *s == 'u' && strEQ(s,"undef") ) {
4830         s += 5;
4831     }
4832
4833     return s;
4834 }
4835
4836 /*
4837 =for apidoc new_version
4838
4839 Returns a new version object based on the passed in SV:
4840
4841     SV *sv = new_version(SV *ver);
4842
4843 Does not alter the passed in ver SV.  See "upg_version" if you
4844 want to upgrade the SV.
4845
4846 =cut
4847 */
4848
4849 SV *
4850 Perl_new_version(pTHX_ SV *ver)
4851 {
4852     dVAR;
4853     SV * const rv = newSV(0);
4854     PERL_ARGS_ASSERT_NEW_VERSION;
4855     if ( sv_derived_from(ver,"version") ) /* can just copy directly */
4856     {
4857         I32 key;
4858         AV * const av = newAV();
4859         AV *sav;
4860         /* This will get reblessed later if a derived class*/
4861         SV * const hv = newSVrv(rv, "version");
4862         (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
4863 #ifndef NODEFAULT_SHAREKEYS
4864         HvSHAREKEYS_on(hv);         /* key-sharing on by default */
4865 #endif
4866
4867         if ( SvROK(ver) )
4868             ver = SvRV(ver);
4869
4870         /* Begin copying all of the elements */
4871         if ( hv_exists(MUTABLE_HV(ver), "qv", 2) )
4872             (void)hv_stores(MUTABLE_HV(hv), "qv", newSViv(1));
4873
4874         if ( hv_exists(MUTABLE_HV(ver), "alpha", 5) )
4875             (void)hv_stores(MUTABLE_HV(hv), "alpha", newSViv(1));
4876
4877         if ( hv_exists(MUTABLE_HV(ver), "width", 5 ) )
4878         {
4879             const I32 width = SvIV(*hv_fetchs(MUTABLE_HV(ver), "width", FALSE));
4880             (void)hv_stores(MUTABLE_HV(hv), "width", newSViv(width));
4881         }
4882
4883         if ( hv_exists(MUTABLE_HV(ver), "original", 8 ) )
4884         {
4885             SV * pv = *hv_fetchs(MUTABLE_HV(ver), "original", FALSE);
4886             (void)hv_stores(MUTABLE_HV(hv), "original", newSVsv(pv));
4887         }
4888
4889         sav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(ver), "version", FALSE)));
4890         /* This will get reblessed later if a derived class*/
4891         for ( key = 0; key <= av_len(sav); key++ )
4892         {
4893             const I32 rev = SvIV(*av_fetch(sav, key, FALSE));
4894             av_push(av, newSViv(rev));
4895         }
4896
4897         (void)hv_stores(MUTABLE_HV(hv), "version", newRV_noinc(MUTABLE_SV(av)));
4898         return rv;
4899     }
4900 #ifdef SvVOK
4901     {
4902         const MAGIC* const mg = SvVSTRING_mg(ver);
4903         if ( mg ) { /* already a v-string */
4904             const STRLEN len = mg->mg_len;
4905             char * const version = savepvn( (const char*)mg->mg_ptr, len);
4906             sv_setpvn(rv,version,len);
4907             /* this is for consistency with the pure Perl class */
4908             if ( isDIGIT(*version) )
4909                 sv_insert(rv, 0, 0, "v", 1);
4910             Safefree(version);
4911         }
4912         else {
4913 #endif
4914         sv_setsv(rv,ver); /* make a duplicate */
4915 #ifdef SvVOK
4916         }
4917     }
4918 #endif
4919     return upg_version(rv, FALSE);
4920 }
4921
4922 /*
4923 =for apidoc upg_version
4924
4925 In-place upgrade of the supplied SV to a version object.
4926
4927     SV *sv = upg_version(SV *sv, bool qv);
4928
4929 Returns a pointer to the upgraded SV.  Set the boolean qv if you want
4930 to force this SV to be interpreted as an "extended" version.
4931
4932 =cut
4933 */
4934
4935 SV *
4936 Perl_upg_version(pTHX_ SV *ver, bool qv)
4937 {
4938     const char *version, *s;
4939 #ifdef SvVOK
4940     const MAGIC *mg;
4941 #endif
4942
4943     PERL_ARGS_ASSERT_UPG_VERSION;
4944
4945     if ( SvNOK(ver) && !( SvPOK(ver) && sv_len(ver) == 3 ) )
4946     {
4947         /* may get too much accuracy */
4948         char tbuf[64];
4949 #ifdef USE_LOCALE_NUMERIC
4950         char *loc = setlocale(LC_NUMERIC, "C");
4951 #endif
4952         STRLEN len = my_snprintf(tbuf, sizeof(tbuf), "%.9"NVff, SvNVX(ver));
4953 #ifdef USE_LOCALE_NUMERIC
4954         setlocale(LC_NUMERIC, loc);
4955 #endif
4956         while (tbuf[len-1] == '0' && len > 0) len--;
4957         if ( tbuf[len-1] == '.' ) len--; /* eat the trailing decimal */
4958         version = savepvn(tbuf, len);
4959     }
4960 #ifdef SvVOK
4961     else if ( (mg = SvVSTRING_mg(ver)) ) { /* already a v-string */
4962         version = savepvn( (const char*)mg->mg_ptr,mg->mg_len );
4963         qv = TRUE;
4964     }
4965 #endif
4966     else /* must be a string or something like a string */
4967     {
4968         STRLEN len;
4969         version = savepv(SvPV(ver,len));
4970 #ifndef SvVOK
4971 #  if PERL_VERSION > 5
4972         /* This will only be executed for 5.6.0 - 5.8.0 inclusive */
4973         if ( len >= 3 && !instr(version,".") && !instr(version,"_")) {
4974             /* may be a v-string */
4975             char *testv = (char *)version;
4976             STRLEN tlen = len;
4977             for (tlen=0; tlen < len; tlen++, testv++) {
4978                 /* if one of the characters is non-text assume v-string */
4979                 if (testv[0] < ' ') {
4980                     SV * const nsv = sv_newmortal();
4981                     const char *nver;
4982                     const char *pos;
4983                     int saw_decimal = 0;
4984                     sv_setpvf(nsv,"v%vd",ver);
4985                     pos = nver = savepv(SvPV_nolen(nsv));
4986
4987                     /* scan the resulting formatted string */
4988                     pos++; /* skip the leading 'v' */
4989                     while ( *pos == '.' || isDIGIT(*pos) ) {
4990                         if ( *pos == '.' )
4991                             saw_decimal++ ;
4992                         pos++;
4993                     }
4994
4995                     /* is definitely a v-string */
4996                     if ( saw_decimal >= 2 ) {
4997                         Safefree(version);
4998                         version = nver;
4999                     }
5000                     break;
5001                 }
5002             }
5003         }
5004 #  endif
5005 #endif
5006     }
5007
5008     s = scan_version(version, ver, qv);
5009     if ( *s != '\0' )
5010         Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
5011                        "Version string '%s' contains invalid data; "
5012                        "ignoring: '%s'", version, s);
5013     Safefree(version);
5014     return ver;
5015 }
5016
5017 /*
5018 =for apidoc vverify
5019
5020 Validates that the SV contains valid internal structure for a version object.
5021 It may be passed either the version object (RV) or the hash itself (HV).  If
5022 the structure is valid, it returns the HV.  If the structure is invalid,
5023 it returns NULL.
5024
5025     SV *hv = vverify(sv);
5026
5027 Note that it only confirms the bare minimum structure (so as not to get
5028 confused by derived classes which may contain additional hash entries):
5029
5030 =over 4
5031
5032 =item * The SV is an HV or a reference to an HV
5033
5034 =item * The hash contains a "version" key
5035
5036 =item *&n