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