util.c

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