util.c

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