util.c

   1 /*    util.c
   2  *
   3  *    Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001,
   4  *    2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
   5  *
   6  *    You may distribute under the terms of either the GNU General Public
   7  *    License or the Artistic License, as specified in the README file.
   8  *
   9  */
  10
  11 /*
  12  * 'Very useful, no doubt, that was to Saruman; yet it seems that he was
  13  *  not content.'                                    --Gandalf to Pippin
  14  *
  15  *     [p.598 of _The Lord of the Rings_, III/xi: "The Palantír"]
  16  */
  17
  18 /* This file contains assorted utility routines.
  19  * Which is a polite way of saying any stuff that people couldn't think of
  20  * a better place for. Amongst other things, it includes the warning and
  21  * dieing stuff, plus wrappers for malloc code.
  22  */
  23
  24 #include "EXTERN.h"
  25 #define PERL_IN_UTIL_C
  26 #include "perl.h"
  27
  28 #ifndef PERL_MICRO
  29 #include <signal.h>
  30 #ifndef SIG_ERR
  31 # define SIG_ERR ((Sighandler_t) -1)
  32 #endif
  33 #endif
  34
  35 #ifdef __Lynx__
  36 /* Missing protos on LynxOS */
  37 int putenv(char *);
  38 #endif
  39
  40 #ifdef I_SYS_WAIT
  41 #  include <sys/wait.h>
  42 #endif
  43
  44 #ifdef HAS_SELECT
  45 # ifdef I_SYS_SELECT
  46 #  include <sys/select.h>
  47 # endif
  48 #endif
  49
  50 #define FLUSH
  51
  52 #if defined(HAS_FCNTL) && defined(F_SETFD) && !defined(FD_CLOEXEC)
  53 #  define FD_CLOEXEC 1                  /* NeXT needs this */
  54 #endif
  55
  56 /* NOTE:  Do not call the next three routines directly.  Use the macros
  57  * in handy.h, so that we can easily redefine everything to do tracking of
  58  * allocated hunks back to the original New to track down any memory leaks.
  59  * XXX This advice seems to be widely ignored :-(   --AD  August 1996.
  60  */
  61
  62 static char *
  63 S_write_no_mem(pTHX)
  64 {
  65     dVAR;
  66     /* Can't use PerlIO to write as it allocates memory */
  67     PerlLIO_write(PerlIO_fileno(Perl_error_log),
  68                   PL_no_mem, strlen(PL_no_mem));
  69     my_exit(1);
  70     NORETURN_FUNCTION_END;
  71 }
  72
  73 /* paranoid version of system's malloc() */
  74
  75 Malloc_t
  76 Perl_safesysmalloc(MEM_SIZE size)
  77 {
  78 #ifdef DEBUGGING
  79     dTHX;
  80 #endif
  81     Malloc_t ptr;
  82 #ifdef HAS_64K_LIMIT
  83         if (size > 0xffff) {
  84             PerlIO_printf(Perl_error_log,
  85                           "Allocation too large: %lx\n", size) FLUSH;
  86             my_exit(1);
  87         }
  88 #endif /* HAS_64K_LIMIT */
  89 #ifdef PERL_TRACK_MEMPOOL
  90     size += sTHX;
  91 #endif
  92 #ifdef DEBUGGING
  93     if ((long)size < 0)
  94         Perl_croak_nocontext("panic: malloc");
  95 #endif
  96     ptr = (Malloc_t)PerlMem_malloc(size?size:1);        /* malloc(0) is NASTY on our system */
  97     PERL_ALLOC_CHECK(ptr);
  98     DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) malloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
  99     if (ptr != NULL) {
 100 #ifdef PERL_TRACK_MEMPOOL
 101         struct perl_memory_debug_header *const header
 102             = (struct perl_memory_debug_header *)ptr;
 103 #endif
 104
 105 #ifdef PERL_POISON
 106         PoisonNew(((char *)ptr), size, char);
 107 #endif
 108
 109 #ifdef PERL_TRACK_MEMPOOL
 110         header->interpreter = aTHX;
 111         /* Link us into the list.  */
 112         header->prev = &PL_memory_debug_header;
 113         header->next = PL_memory_debug_header.next;
 114         PL_memory_debug_header.next = header;
 115         header->next->prev = header;
 116 #  ifdef PERL_POISON
 117         header->size = size;
 118 #  endif
 119         ptr = (Malloc_t)((char*)ptr+sTHX);
 120 #endif
 121         return ptr;
 122 }
 123     else {
 124 #ifndef DEBUGGING
 125         dTHX;
 126 #endif
 127         if (PL_nomemok)
 128             return NULL;
 129         else {
 130             return write_no_mem();
 131         }
 132     }
 133     /*NOTREACHED*/
 134 }
 135
 136 /* paranoid version of system's realloc() */
 137
 138 Malloc_t
 139 Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
 140 {
 141 #ifdef DEBUGGING
 142     dTHX;
 143 #endif
 144     Malloc_t ptr;
 145 #if !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) && !defined(PERL_MICRO)
 146     Malloc_t PerlMem_realloc();
 147 #endif /* !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) */
 148
 149 #ifdef HAS_64K_LIMIT
 150     if (size > 0xffff) {
 151         PerlIO_printf(Perl_error_log,
 152                       "Reallocation too large: %lx\n", size) FLUSH;
 153         my_exit(1);
 154     }
 155 #endif /* HAS_64K_LIMIT */
 156     if (!size) {
 157         safesysfree(where);
 158         return NULL;
 159     }
 160
 161     if (!where)
 162         return safesysmalloc(size);
 163 #ifdef PERL_TRACK_MEMPOOL
 164     where = (Malloc_t)((char*)where-sTHX);
 165     size += sTHX;
 166     {
 167         struct perl_memory_debug_header *const header
 168             = (struct perl_memory_debug_header *)where;
 169
 170         if (header->interpreter != aTHX) {
 171             Perl_croak_nocontext("panic: realloc from wrong pool");
 172         }
 173         assert(header->next->prev == header);
 174         assert(header->prev->next == header);
 175 #  ifdef PERL_POISON
 176         if (header->size > size) {
 177             const MEM_SIZE freed_up = header->size - size;
 178             char *start_of_freed = ((char *)where) + size;
 179             PoisonFree(start_of_freed, freed_up, char);
 180         }
 181         header->size = size;
 182 #  endif
 183     }
 184 #endif
 185 #ifdef DEBUGGING
 186     if ((long)size < 0)
 187         Perl_croak_nocontext("panic: realloc");
 188 #endif
 189     ptr = (Malloc_t)PerlMem_realloc(where,size);
 190     PERL_ALLOC_CHECK(ptr);
 191
 192     /* MUST do this fixup first, before doing ANYTHING else, as anything else
 193        might allocate memory/free/move memory, and until we do the fixup, it
 194        may well be chasing (and writing to) free memory.  */
 195 #ifdef PERL_TRACK_MEMPOOL
 196     if (ptr != NULL) {
 197         struct perl_memory_debug_header *const header
 198             = (struct perl_memory_debug_header *)ptr;
 199
 200 #  ifdef PERL_POISON
 201         if (header->size < size) {
 202             const MEM_SIZE fresh = size - header->size;
 203             char *start_of_fresh = ((char *)ptr) + size;
 204             PoisonNew(start_of_fresh, fresh, char);
 205         }
 206 #  endif
 207
 208         header->next->prev = header;
 209         header->prev->next = header;
 210
 211         ptr = (Malloc_t)((char*)ptr+sTHX);
 212     }
 213 #endif
 214
 215     /* In particular, must do that fixup above before logging anything via
 216      *printf(), as it can reallocate memory, which can cause SEGVs.  */
 217
 218     DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) rfree\n",PTR2UV(where),(long)PL_an++));
 219     DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) realloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
 220
 221
 222     if (ptr != NULL) {
 223         return ptr;
 224     }
 225     else {
 226 #ifndef DEBUGGING
 227         dTHX;
 228 #endif
 229         if (PL_nomemok)
 230             return NULL;
 231         else {
 232             return write_no_mem();
 233         }
 234     }
 235     /*NOTREACHED*/
 236 }
 237
 238 /* safe version of system's free() */
 239
 240 Free_t
 241 Perl_safesysfree(Malloc_t where)
 242 {
 243 #if defined(DEBUGGING) && (defined(PERL_IMPLICIT_SYS) || defined(PERL_TRACK_MEMPOOL))
 244     dTHX;
 245 #else
 246     dVAR;
 247 #endif
 248     DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) free\n",PTR2UV(where),(long)PL_an++));
 249     if (where) {
 250 #ifdef PERL_TRACK_MEMPOOL
 251         where = (Malloc_t)((char*)where-sTHX);
 252         {
 253             struct perl_memory_debug_header *const header
 254                 = (struct perl_memory_debug_header *)where;
 255
 256             if (header->interpreter != aTHX) {
 257                 Perl_croak_nocontext("panic: free from wrong pool");
 258             }
 259             if (!header->prev) {
 260                 Perl_croak_nocontext("panic: duplicate free");
 261             }
 262             if (!(header->next) || header->next->prev != header
 263                 || header->prev->next != header) {
 264                 Perl_croak_nocontext("panic: bad free");
 265             }
 266             /* Unlink us from the chain.  */
 267             header->next->prev = header->prev;
 268             header->prev->next = header->next;
 269 #  ifdef PERL_POISON
 270             PoisonNew(where, header->size, char);
 271 #  endif
 272             /* Trigger the duplicate free warning.  */
 273             header->next = NULL;
 274         }
 275 #endif
 276         PerlMem_free(where);
 277     }
 278 }
 279
 280 /* safe version of system's calloc() */
 281
 282 Malloc_t
 283 Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size)
 284 {
 285 #ifdef DEBUGGING
 286     dTHX;
 287 #endif
 288     Malloc_t ptr;
 289     MEM_SIZE total_size = 0;
 290
 291     /* Even though calloc() for zero bytes is strange, be robust. */
 292     if (size && (count <= MEM_SIZE_MAX / size))
 293         total_size = size * count;
 294     else
 295         Perl_croak_nocontext("%s", PL_memory_wrap);
 296 #ifdef PERL_TRACK_MEMPOOL
 297     if (sTHX <= MEM_SIZE_MAX - (MEM_SIZE)total_size)
 298         total_size += sTHX;
 299     else
 300         Perl_croak_nocontext("%s", PL_memory_wrap);
 301 #endif
 302 #ifdef HAS_64K_LIMIT
 303     if (total_size > 0xffff) {
 304         PerlIO_printf(Perl_error_log,
 305                       "Allocation too large: %lx\n", total_size) FLUSH;
 306         my_exit(1);
 307     }
 308 #endif /* HAS_64K_LIMIT */
 309 #ifdef DEBUGGING
 310     if ((long)size < 0 || (long)count < 0)
 311         Perl_croak_nocontext("panic: calloc");
 312 #endif
 313 #ifdef PERL_TRACK_MEMPOOL
 314     /* Have to use malloc() because we've added some space for our tracking
 315        header.  */
 316     /* malloc(0) is non-portable. */
 317     ptr = (Malloc_t)PerlMem_malloc(total_size ? total_size : 1);
 318 #else
 319     /* Use calloc() because it might save a memset() if the memory is fresh
 320        and clean from the OS.  */
 321     if (count && size)
 322         ptr = (Malloc_t)PerlMem_calloc(count, size);
 323     else /* calloc(0) is non-portable. */
 324         ptr = (Malloc_t)PerlMem_calloc(count ? count : 1, size ? size : 1);
 325 #endif
 326     PERL_ALLOC_CHECK(ptr);
 327     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));
 328     if (ptr != NULL) {
 329 #ifdef PERL_TRACK_MEMPOOL
 330         {
 331             struct perl_memory_debug_header *const header
 332                 = (struct perl_memory_debug_header *)ptr;
 333
 334             memset((void*)ptr, 0, total_size);
 335             header->interpreter = aTHX;
 336             /* Link us into the list.  */
 337             header->prev = &PL_memory_debug_header;
 338             header->next = PL_memory_debug_header.next;
 339             PL_memory_debug_header.next = header;
 340             header->next->prev = header;
 341 #  ifdef PERL_POISON
 342             header->size = total_size;
 343 #  endif
 344             ptr = (Malloc_t)((char*)ptr+sTHX);
 345         }
 346 #endif
 347         return ptr;
 348     }
 349     else {
 350 #ifndef DEBUGGING
 351         dTHX;
 352 #endif
 353         if (PL_nomemok)
 354             return NULL;
 355         return write_no_mem();
 356     }
 357 }
 358
 359 /* These must be defined when not using Perl's malloc for binary
 360  * compatibility */
 361
 362 #ifndef MYMALLOC
 363
 364 Malloc_t Perl_malloc (MEM_SIZE nbytes)
 365 {
 366     dTHXs;
 367     return (Malloc_t)PerlMem_malloc(nbytes);
 368 }
 369
 370 Malloc_t Perl_calloc (MEM_SIZE elements, MEM_SIZE size)
 371 {
 372     dTHXs;
 373     return (Malloc_t)PerlMem_calloc(elements, size);
 374 }
 375
 376 Malloc_t Perl_realloc (Malloc_t where, MEM_SIZE nbytes)
 377 {
 378     dTHXs;
 379     return (Malloc_t)PerlMem_realloc(where, nbytes);
 380 }
 381
 382 Free_t   Perl_mfree (Malloc_t where)
 383 {
 384     dTHXs;
 385     PerlMem_free(where);
 386 }
 387
 388 #endif
 389
 390 /* copy a string up to some (non-backslashed) delimiter, if any */
 391
 392 char *
 393 Perl_delimcpy(register char *to, register const char *toend, register const char *from, register const char *fromend, register int delim, I32 *retlen)
 394 {
 395     register I32 tolen;
 396
 397     PERL_ARGS_ASSERT_DELIMCPY;
 398
 399     for (tolen = 0; from < fromend; from++, tolen++) {
 400         if (*from == '\\') {
 401             if (from[1] != delim) {
 402                 if (to < toend)
 403                     *to++ = *from;
 404                 tolen++;
 405             }
 406             from++;
 407         }
 408         else if (*from == delim)
 409             break;
 410         if (to < toend)
 411             *to++ = *from;
 412     }
 413     if (to < toend)
 414         *to = '\0';
 415     *retlen = tolen;
 416     return (char *)from;
 417 }
 418
 419 /* return ptr to little string in big string, NULL if not found */
 420 /* This routine was donated by Corey Satten. */
 421
 422 char *
 423 Perl_instr(register const char *big, register const char *little)
 424 {
 425     register I32 first;
 426
 427     PERL_ARGS_ASSERT_INSTR;
 428
 429     if (!little)
 430         return (char*)big;
 431     first = *little++;
 432     if (!first)
 433         return (char*)big;
 434     while (*big) {
 435         register const char *s, *x;
 436         if (*big++ != first)
 437             continue;
 438         for (x=big,s=little; *s; /**/ ) {
 439             if (!*x)
 440                 return NULL;
 441             if (*s != *x)
 442                 break;
 443             else {
 444                 s++;
 445                 x++;
 446             }
 447         }
 448         if (!*s)
 449             return (char*)(big-1);
 450     }
 451     return NULL;
 452 }
 453
 454 /* same as instr but allow embedded nulls */
 455
 456 char *
 457 Perl_ninstr(const char *big, const char *bigend, const char *little, const char *lend)
 458 {
 459     PERL_ARGS_ASSERT_NINSTR;
 460     if (little >= lend)
 461         return (char*)big;
 462     {
 463         const char first = *little;
 464         const char *s, *x;
 465         bigend -= lend - little++;
 466     OUTER:
 467         while (big <= bigend) {
 468             if (*big++ == first) {
 469                 for (x=big,s=little; s < lend; x++,s++) {
 470                     if (*s != *x)
 471                         goto OUTER;
 472                 }
 473                 return (char*)(big-1);
 474             }
 475         }
 476     }
 477     return NULL;
 478 }
 479
 480 /* reverse of the above--find last substring */
 481
 482 char *
 483 Perl_rninstr(register const char *big, const char *bigend, const char *little, const char *lend)
 484 {
 485     register const char *bigbeg;
 486     register const I32 first = *little;
 487     register const char * const littleend = lend;
 488
 489     PERL_ARGS_ASSERT_RNINSTR;
 490
 491     if (little >= littleend)
 492         return (char*)bigend;
 493     bigbeg = big;
 494     big = bigend - (littleend - little++);
 495     while (big >= bigbeg) {
 496         register const char *s, *x;
 497         if (*big-- != first)
 498             continue;
 499         for (x=big+2,s=little; s < littleend; /**/ ) {
 500             if (*s != *x)
 501                 break;
 502             else {
 503                 x++;
 504                 s++;
 505             }
 506         }
 507         if (s >= littleend)
 508             return (char*)(big+1);
 509     }
 510     return NULL;
 511 }
 512
 513 /* As a space optimization, we do not compile tables for strings of length
 514    0 and 1, and for strings of length 2 unless FBMcf_TAIL.  These are
 515    special-cased in fbm_instr().
 516
 517    If FBMcf_TAIL, the table is created as if the string has a trailing \n. */
 518
 519 /*
 520 =head1 Miscellaneous Functions
 521
 522 =for apidoc fbm_compile
 523
 524 Analyses the string in order to make fast searches on it using fbm_instr()
 525 -- the Boyer-Moore algorithm.
 526
 527 =cut
 528 */
 529
 530 void
 531 Perl_fbm_compile(pTHX_ SV *sv, U32 flags)
 532 {
 533     dVAR;
 534     register const U8 *s;
 535     register U32 i;
 536     STRLEN len;
 537     U32 rarest = 0;
 538     U32 frequency = 256;
 539
 540     PERL_ARGS_ASSERT_FBM_COMPILE;
 541
 542     if (flags & FBMcf_TAIL) {
 543         MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL;
 544         sv_catpvs(sv, "\n");            /* Taken into account in fbm_instr() */
 545         if (mg && mg->mg_len >= 0)
 546             mg->mg_len++;
 547     }
 548     s = (U8*)SvPV_force_mutable(sv, len);
 549     if (len == 0)               /* TAIL might be on a zero-length string. */
 550         return;
 551     SvUPGRADE(sv, SVt_PVGV);
 552     SvIOK_off(sv);
 553     SvNOK_off(sv);
 554     SvVALID_on(sv);
 555     if (len > 2) {
 556         const unsigned char *sb;
 557         const U8 mlen = (len>255) ? 255 : (U8)len;
 558         register U8 *table;
 559
 560         Sv_Grow(sv, len + 256 + PERL_FBM_TABLE_OFFSET);
 561         table
 562             = (unsigned char*)(SvPVX_mutable(sv) + len + PERL_FBM_TABLE_OFFSET);
 563         s = table - 1 - PERL_FBM_TABLE_OFFSET;  /* last char */
 564         memset((void*)table, mlen, 256);
 565         i = 0;
 566         sb = s - mlen + 1;                      /* first char (maybe) */
 567         while (s >= sb) {
 568             if (table[*s] == mlen)
 569                 table[*s] = (U8)i;
 570             s--, i++;
 571         }
 572     } else {
 573         Sv_Grow(sv, len + PERL_FBM_TABLE_OFFSET);
 574     }
 575     sv_magic(sv, NULL, PERL_MAGIC_bm, NULL, 0); /* deep magic */
 576
 577     s = (const unsigned char*)(SvPVX_const(sv));        /* deeper magic */
 578     for (i = 0; i < len; i++) {
 579         if (PL_freq[s[i]] < frequency) {
 580             rarest = i;
 581             frequency = PL_freq[s[i]];
 582         }
 583     }
 584     BmFLAGS(sv) = (U8)flags;
 585     BmRARE(sv) = s[rarest];
 586     BmPREVIOUS(sv) = rarest;
 587     BmUSEFUL(sv) = 100;                 /* Initial value */
 588     if (flags & FBMcf_TAIL)
 589         SvTAIL_on(sv);
 590     DEBUG_r(PerlIO_printf(Perl_debug_log, "rarest char %c at %lu\n",
 591                           BmRARE(sv),(unsigned long)BmPREVIOUS(sv)));
 592 }
 593
 594 /* If SvTAIL(littlestr), it has a fake '\n' at end. */
 595 /* If SvTAIL is actually due to \Z or \z, this gives false positives
 596    if multiline */
 597
 598 /*
 599 =for apidoc fbm_instr
 600
 601 Returns the location of the SV in the string delimited by C<str> and
 602 C<strend>.  It returns C<NULL> if the string can't be found.  The C<sv>
 603 does not have to be fbm_compiled, but the search will not be as fast
 604 then.
 605
 606 =cut
 607 */
 608
 609 char *
 610 Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *littlestr, U32 flags)
 611 {
 612     register unsigned char *s;
 613     STRLEN l;
 614     register const unsigned char *little
 615         = (const unsigned char *)SvPV_const(littlestr,l);
 616     register STRLEN littlelen = l;
 617     register const I32 multiline = flags & FBMrf_MULTILINE;
 618
 619     PERL_ARGS_ASSERT_FBM_INSTR;
 620
 621     if ((STRLEN)(bigend - big) < littlelen) {
 622         if ( SvTAIL(littlestr)
 623              && ((STRLEN)(bigend - big) == littlelen - 1)
 624              && (littlelen == 1
 625                  || (*big == *little &&
 626                      memEQ((char *)big, (char *)little, littlelen - 1))))
 627             return (char*)big;
 628         return NULL;
 629     }
 630
 631     if (littlelen <= 2) {               /* Special-cased */
 632
 633         if (littlelen == 1) {
 634             if (SvTAIL(littlestr) && !multiline) { /* Anchor only! */
 635                 /* Know that bigend != big.  */
 636                 if (bigend[-1] == '\n')
 637                     return (char *)(bigend - 1);
 638                 return (char *) bigend;
 639             }
 640             s = big;
 641             while (s < bigend) {
 642                 if (*s == *little)
 643                     return (char *)s;
 644                 s++;
 645             }
 646             if (SvTAIL(littlestr))
 647                 return (char *) bigend;
 648             return NULL;
 649         }
 650         if (!littlelen)
 651             return (char*)big;          /* Cannot be SvTAIL! */
 652
 653         /* littlelen is 2 */
 654         if (SvTAIL(littlestr) && !multiline) {
 655             if (bigend[-1] == '\n' && bigend[-2] == *little)
 656                 return (char*)bigend - 2;
 657             if (bigend[-1] == *little)
 658                 return (char*)bigend - 1;
 659             return NULL;
 660         }
 661         {
 662             /* This should be better than FBM if c1 == c2, and almost
 663                as good otherwise: maybe better since we do less indirection.
 664                And we save a lot of memory by caching no table. */
 665             const unsigned char c1 = little[0];
 666             const unsigned char c2 = little[1];
 667
 668             s = big + 1;
 669             bigend--;
 670             if (c1 != c2) {
 671                 while (s <= bigend) {
 672                     if (s[0] == c2) {
 673                         if (s[-1] == c1)
 674                             return (char*)s - 1;
 675                         s += 2;
 676                         continue;
 677                     }
 678                   next_chars:
 679                     if (s[0] == c1) {
 680                         if (s == bigend)
 681                             goto check_1char_anchor;
 682                         if (s[1] == c2)
 683                             return (char*)s;
 684                         else {
 685                             s++;
 686                             goto next_chars;
 687                         }
 688                     }
 689                     else
 690                         s += 2;
 691                 }
 692                 goto check_1char_anchor;
 693             }
 694             /* Now c1 == c2 */
 695             while (s <= bigend) {
 696                 if (s[0] == c1) {
 697                     if (s[-1] == c1)
 698                         return (char*)s - 1;
 699                     if (s == bigend)
 700                         goto check_1char_anchor;
 701                     if (s[1] == c1)
 702                         return (char*)s;
 703                     s += 3;
 704                 }
 705                 else
 706                     s += 2;
 707             }
 708         }
 709       check_1char_anchor:               /* One char and anchor! */
 710         if (SvTAIL(littlestr) && (*bigend == *little))
 711             return (char *)bigend;      /* bigend is already decremented. */
 712         return NULL;
 713     }
 714     if (SvTAIL(littlestr) && !multiline) {      /* tail anchored? */
 715         s = bigend - littlelen;
 716         if (s >= big && bigend[-1] == '\n' && *s == *little
 717             /* Automatically of length > 2 */
 718             && memEQ((char*)s + 1, (char*)little + 1, littlelen - 2))
 719         {
 720             return (char*)s;            /* how sweet it is */
 721         }
 722         if (s[1] == *little
 723             && memEQ((char*)s + 2, (char*)little + 1, littlelen - 2))
 724         {
 725             return (char*)s + 1;        /* how sweet it is */
 726         }
 727         return NULL;
 728     }
 729     if (!SvVALID(littlestr)) {
 730         char * const b = ninstr((char*)big,(char*)bigend,
 731                          (char*)little, (char*)little + littlelen);
 732
 733         if (!b && SvTAIL(littlestr)) {  /* Automatically multiline!  */
 734             /* Chop \n from littlestr: */
 735             s = bigend - littlelen + 1;
 736             if (*s == *little
 737                 && memEQ((char*)s + 1, (char*)little + 1, littlelen - 2))
 738             {
 739                 return (char*)s;
 740             }
 741             return NULL;
 742         }
 743         return b;
 744     }
 745
 746     /* Do actual FBM.  */
 747     if (littlelen > (STRLEN)(bigend - big))
 748         return NULL;
 749
 750     {
 751         register const unsigned char * const table
 752             = little + littlelen + PERL_FBM_TABLE_OFFSET;
 753         register const unsigned char *oldlittle;
 754
 755         --littlelen;                    /* Last char found by table lookup */
 756
 757         s = big + littlelen;
 758         little += littlelen;            /* last char */
 759         oldlittle = little;
 760         if (s < bigend) {
 761             register I32 tmp;
 762
 763           top2:
 764             if ((tmp = table[*s])) {
 765                 if ((s += tmp) < bigend)
 766                     goto top2;
 767                 goto check_end;
 768             }
 769             else {              /* less expensive than calling strncmp() */
 770                 register unsigned char * const olds = s;
 771
 772                 tmp = littlelen;
 773
 774                 while (tmp--) {
 775                     if (*--s == *--little)
 776                         continue;
 777                     s = olds + 1;       /* here we pay the price for failure */
 778                     little = oldlittle;
 779                     if (s < bigend)     /* fake up continue to outer loop */
 780                         goto top2;
 781                     goto check_end;
 782                 }
 783                 return (char *)s;
 784             }
 785         }
 786       check_end:
 787         if ( s == bigend
 788              && (BmFLAGS(littlestr) & FBMcf_TAIL)
 789              && memEQ((char *)(bigend - littlelen),
 790                       (char *)(oldlittle - littlelen), littlelen) )
 791             return (char*)bigend - littlelen;
 792         return NULL;
 793     }
 794 }
 795
 796 /* start_shift, end_shift are positive quantities which give offsets
 797    of ends of some substring of bigstr.
 798    If "last" we want the last occurrence.
 799    old_posp is the way of communication between consequent calls if
 800    the next call needs to find the .
 801    The initial *old_posp should be -1.
 802
 803    Note that we take into account SvTAIL, so one can get extra
 804    optimizations if _ALL flag is set.
 805  */
 806
 807 /* If SvTAIL is actually due to \Z or \z, this gives false positives
 808    if PL_multiline.  In fact if !PL_multiline the authoritative answer
 809    is not supported yet. */
 810
 811 char *
 812 Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift, I32 *old_posp, I32 last)
 813 {
 814     dVAR;
 815     register const unsigned char *big;
 816     register I32 pos;
 817     register I32 previous;
 818     register I32 first;
 819     register const unsigned char *little;
 820     register I32 stop_pos;
 821     register const unsigned char *littleend;
 822     I32 found = 0;
 823
 824     PERL_ARGS_ASSERT_SCREAMINSTR;
 825
 826     assert(SvTYPE(littlestr) == SVt_PVGV);
 827     assert(SvVALID(littlestr));
 828
 829     if (*old_posp == -1
 830         ? (pos = PL_screamfirst[BmRARE(littlestr)]) < 0
 831         : (((pos = *old_posp), pos += PL_screamnext[pos]) == 0)) {
 832       cant_find:
 833         if ( BmRARE(littlestr) == '\n'
 834              && BmPREVIOUS(littlestr) == SvCUR(littlestr) - 1) {
 835             little = (const unsigned char *)(SvPVX_const(littlestr));
 836             littleend = little + SvCUR(littlestr);
 837             first = *little++;
 838             goto check_tail;
 839         }
 840         return NULL;
 841     }
 842
 843     little = (const unsigned char *)(SvPVX_const(littlestr));
 844     littleend = little + SvCUR(littlestr);
 845     first = *little++;
 846     /* The value of pos we can start at: */
 847     previous = BmPREVIOUS(littlestr);
 848     big = (const unsigned char *)(SvPVX_const(bigstr));
 849     /* The value of pos we can stop at: */
 850     stop_pos = SvCUR(bigstr) - end_shift - (SvCUR(littlestr) - 1 - previous);
 851     if (previous + start_shift > stop_pos) {
 852 /*
 853   stop_pos does not include SvTAIL in the count, so this check is incorrect
 854   (I think) - see [ID 20010618.006] and t/op/study.t. HVDS 2001/06/19
 855 */
 856 #if 0
 857         if (previous + start_shift == stop_pos + 1) /* A fake '\n'? */
 858             goto check_tail;
 859 #endif
 860         return NULL;
 861     }
 862     while (pos < previous + start_shift) {
 863         if (!(pos += PL_screamnext[pos]))
 864             goto cant_find;
 865     }
 866     big -= previous;
 867     do {
 868         register const unsigned char *s, *x;
 869         if (pos >= stop_pos) break;
 870         if (big[pos] != first)
 871             continue;
 872         for (x=big+pos+1,s=little; s < littleend; /**/ ) {
 873             if (*s++ != *x++) {
 874                 s--;
 875                 break;
 876             }
 877         }
 878         if (s == littleend) {
 879             *old_posp = pos;
 880             if (!last) return (char *)(big+pos);
 881             found = 1;
 882         }
 883     } while ( pos += PL_screamnext[pos] );
 884     if (last && found)
 885         return (char *)(big+(*old_posp));
 886   check_tail:
 887     if (!SvTAIL(littlestr) || (end_shift > 0))
 888         return NULL;
 889     /* Ignore the trailing "\n".  This code is not microoptimized */
 890     big = (const unsigned char *)(SvPVX_const(bigstr) + SvCUR(bigstr));
 891     stop_pos = littleend - little;      /* Actual littlestr len */
 892     if (stop_pos == 0)
 893         return (char*)big;
 894     big -= stop_pos;
 895     if (*big == first
 896         && ((stop_pos == 1) ||
 897             memEQ((char *)(big + 1), (char *)little, stop_pos - 1)))
 898         return (char*)big;
 899     return NULL;
 900 }
 901
 902 /*
 903 =for apidoc foldEQ
 904
 905 Returns true if the leading len bytes of the strings s1 and s2 are the same
 906 case-insensitively; false otherwise.  Uppercase and lowercase ASCII range bytes
 907 match themselves and their opposite case counterparts.  Non-cased and non-ASCII
 908 range bytes match only themselves.
 909
 910 =cut
 911 */
 912
 913
 914 I32
 915 Perl_foldEQ(const char *s1, const char *s2, register I32 len)
 916 {
 917     register const U8 *a = (const U8 *)s1;
 918     register const U8 *b = (const U8 *)s2;
 919
 920     PERL_ARGS_ASSERT_FOLDEQ;
 921
 922     while (len--) {
 923         if (*a != *b && *a != PL_fold[*b])
 924             return 0;
 925         a++,b++;
 926     }
 927     return 1;
 928 }
 929
 930 /*
 931 =for apidoc foldEQ_locale
 932
 933 Returns true if the leading len bytes of the strings s1 and s2 are the same
 934 case-insensitively in the current locale; false otherwise.
 935
 936 =cut
 937 */
 938
 939 I32
 940 Perl_foldEQ_locale(const char *s1, const char *s2, register I32 len)
 941 {
 942     dVAR;
 943     register const U8 *a = (const U8 *)s1;
 944     register const U8 *b = (const U8 *)s2;
 945
 946     PERL_ARGS_ASSERT_FOLDEQ_LOCALE;
 947
 948     while (len--) {
 949         if (*a != *b && *a != PL_fold_locale[*b])
 950             return 0;
 951         a++,b++;
 952     }
 953     return 1;
 954 }
 955
 956 /* copy a string to a safe spot */
 957
 958 /*
 959 =head1 Memory Management
 960
 961 =for apidoc savepv
 962
 963 Perl's version of C<strdup()>. Returns a pointer to a newly allocated
 964 string which is a duplicate of C<pv>. The size of the string is
 965 determined by C<strlen()>. The memory allocated for the new string can
 966 be freed with the C<Safefree()> function.
 967
 968 =cut
 969 */
 970
 971 char *
 972 Perl_savepv(pTHX_ const char *pv)
 973 {
 974     PERL_UNUSED_CONTEXT;
 975     if (!pv)
 976         return NULL;
 977     else {
 978         char *newaddr;
 979         const STRLEN pvlen = strlen(pv)+1;
 980         Newx(newaddr, pvlen, char);
 981         return (char*)memcpy(newaddr, pv, pvlen);
 982     }
 983 }
 984
 985 /* same thing but with a known length */
 986
 987 /*
 988 =for apidoc savepvn
 989
 990 Perl's version of what C<strndup()> would be if it existed. Returns a
 991 pointer to a newly allocated string which is a duplicate of the first
 992 C<len> bytes from C<pv>, plus a trailing NUL byte. The memory allocated for
 993 the new string can be freed with the C<Safefree()> function.
 994
 995 =cut
 996 */
 997
 998 char *
 999 Perl_savepvn(pTHX_ const char *pv, register I32 len)
1000 {
1001     register char *newaddr;
1002     PERL_UNUSED_CONTEXT;
1003
1004     Newx(newaddr,len+1,char);
1005     /* Give a meaning to NULL pointer mainly for the use in sv_magic() */
1006     if (pv) {
1007         /* might not be null terminated */
1008         newaddr[len] = '\0';
1009         return (char *) CopyD(pv,newaddr,len,char);
1010     }
1011     else {
1012         return (char *) ZeroD(newaddr,len+1,char);
1013     }
1014 }
1015
1016 /*
1017 =for apidoc savesharedpv
1018
1019 A version of C<savepv()> which allocates the duplicate string in memory
1020 which is shared between threads.
1021
1022 =cut
1023 */
1024 char *
1025 Perl_savesharedpv(pTHX_ const char *pv)
1026 {
1027     register char *newaddr;
1028     STRLEN pvlen;
1029     if (!pv)
1030         return NULL;
1031
1032     pvlen = strlen(pv)+1;
1033     newaddr = (char*)PerlMemShared_malloc(pvlen);
1034     if (!newaddr) {
1035         return write_no_mem();
1036     }
1037     return (char*)memcpy(newaddr, pv, pvlen);
1038 }
1039
1040 /*
1041 =for apidoc savesharedpvn
1042
1043 A version of C<savepvn()> which allocates the duplicate string in memory
1044 which is shared between threads. (With the specific difference that a NULL
1045 pointer is not acceptable)
1046
1047 =cut
1048 */
1049 char *
1050 Perl_savesharedpvn(pTHX_ const char *const pv, const STRLEN len)
1051 {
1052     char *const newaddr = (char*)PerlMemShared_malloc(len + 1);
1053
1054     PERL_ARGS_ASSERT_SAVESHAREDPVN;
1055
1056     if (!newaddr) {
1057         return write_no_mem();
1058     }
1059     newaddr[len] = '\0';
1060     return (char*)memcpy(newaddr, pv, len);
1061 }
1062
1063 /*
1064 =for apidoc savesvpv
1065
1066 A version of C<savepv()>/C<savepvn()> which gets the string to duplicate from
1067 the passed in SV using C<SvPV()>
1068
1069 =cut
1070 */
1071
1072 char *
1073 Perl_savesvpv(pTHX_ SV *sv)
1074 {
1075     STRLEN len;
1076     const char * const pv = SvPV_const(sv, len);
1077     register char *newaddr;
1078
1079     PERL_ARGS_ASSERT_SAVESVPV;
1080
1081     ++len;
1082     Newx(newaddr,len,char);
1083     return (char *) CopyD(pv,newaddr,len,char);
1084 }
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_dirty)
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             const bool line_mode = (RsSIMPLE(PL_rs) &&
1317                               SvCUR(PL_rs) == 1 && *SvPVX_const(PL_rs) == '\n');
1318             Perl_sv_catpvf(aTHX_ sv, ", <%s> %s %"IVdf,
1319                            PL_last_in_gv == PL_argvgv ? "" : GvNAME(PL_last_in_gv),
1320                            line_mode ? "line" : "chunk",
1321                            (IV)IoLINES(GvIOp(PL_last_in_gv)));
1322         }
1323         if (PL_dirty)
1324             sv_catpvs(sv, " during global destruction");
1325         sv_catpvs(sv, ".\n");
1326     }
1327     return sv;
1328 }
1329
1330 /*
1331 =for apidoc Am|SV *|vmess|const char *pat|va_list *args
1332
1333 C<pat> and C<args> are a sprintf-style format pattern and encapsulated
1334 argument list.  These are used to generate a string message.  If the
1335 message does not end with a newline, then it will be extended with
1336 some indication of the current location in the code, as described for
1337 L</mess_sv>.
1338
1339 Normally, the resulting message is returned in a new mortal SV.
1340 During global destruction a single SV may be shared between uses of
1341 this function.
1342
1343 =cut
1344 */
1345
1346 SV *
1347 Perl_vmess(pTHX_ const char *pat, va_list *args)
1348 {
1349     dVAR;
1350     SV * const sv = mess_alloc();
1351
1352     PERL_ARGS_ASSERT_VMESS;
1353
1354     sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
1355     return mess_sv(sv, 1);
1356 }
1357
1358 void
1359 Perl_write_to_stderr(pTHX_ SV* msv)
1360 {
1361     dVAR;
1362     IO *io;
1363     MAGIC *mg;
1364
1365     PERL_ARGS_ASSERT_WRITE_TO_STDERR;
1366
1367     if (PL_stderrgv && SvREFCNT(PL_stderrgv)
1368         && (io = GvIO(PL_stderrgv))
1369         && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
1370     {
1371         dSP;
1372         ENTER;
1373         SAVETMPS;
1374
1375         save_re_context();
1376         SAVESPTR(PL_stderrgv);
1377         PL_stderrgv = NULL;
1378
1379         PUSHSTACKi(PERLSI_MAGIC);
1380
1381         PUSHMARK(SP);
1382         EXTEND(SP,2);
1383         PUSHs(SvTIED_obj(MUTABLE_SV(io), mg));
1384         PUSHs(msv);
1385         PUTBACK;
1386         call_method("PRINT", G_SCALAR);
1387
1388         POPSTACK;
1389         FREETMPS;
1390         LEAVE;
1391     }
1392     else {
1393 #ifdef USE_SFIO
1394         /* SFIO can really mess with your errno */
1395         dSAVED_ERRNO;
1396 #endif
1397         PerlIO * const serr = Perl_error_log;
1398         STRLEN msglen;
1399         const char* message = SvPVx_const(msv, msglen);
1400
1401         PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen);
1402         (void)PerlIO_flush(serr);
1403 #ifdef USE_SFIO
1404         RESTORE_ERRNO;
1405 #endif
1406     }
1407 }
1408
1409 /*
1410 =head1 Warning and Dieing
1411 */
1412
1413 /* Common code used in dieing and warning */
1414
1415 STATIC SV *
1416 S_with_queued_errors(pTHX_ SV *ex)
1417 {
1418     PERL_ARGS_ASSERT_WITH_QUEUED_ERRORS;
1419     if (PL_errors && SvCUR(PL_errors) && !SvROK(ex)) {
1420         sv_catsv(PL_errors, ex);
1421         ex = sv_mortalcopy(PL_errors);
1422         SvCUR_set(PL_errors, 0);
1423     }
1424     return ex;
1425 }
1426
1427 STATIC bool
1428 S_invoke_exception_hook(pTHX_ SV *ex, bool warn)
1429 {
1430     dVAR;
1431     HV *stash;
1432     GV *gv;
1433     CV *cv;
1434     SV **const hook = warn ? &PL_warnhook : &PL_diehook;
1435     /* sv_2cv might call Perl_croak() or Perl_warner() */
1436     SV * const oldhook = *hook;
1437
1438     if (!oldhook)
1439         return FALSE;
1440
1441     ENTER;
1442     SAVESPTR(*hook);
1443     *hook = NULL;
1444     cv = sv_2cv(oldhook, &stash, &gv, 0);
1445     LEAVE;
1446     if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
1447         dSP;
1448         SV *exarg;
1449
1450         ENTER;
1451         save_re_context();
1452         if (warn) {
1453             SAVESPTR(*hook);
1454             *hook = NULL;
1455         }
1456         exarg = newSVsv(ex);
1457         SvREADONLY_on(exarg);
1458         SAVEFREESV(exarg);
1459
1460         PUSHSTACKi(warn ? PERLSI_WARNHOOK : PERLSI_DIEHOOK);
1461         PUSHMARK(SP);
1462         XPUSHs(exarg);
1463         PUTBACK;
1464         call_sv(MUTABLE_SV(cv), G_DISCARD);
1465         POPSTACK;
1466         LEAVE;
1467         return TRUE;
1468     }
1469     return FALSE;
1470 }
1471
1472 /*
1473 =for apidoc Am|OP *|die_sv|SV *baseex
1474
1475 Behaves the same as L</croak_sv>, 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 OP *
1483 Perl_die_sv(pTHX_ SV *baseex)
1484 {
1485     PERL_ARGS_ASSERT_DIE_SV;
1486     croak_sv(baseex);
1487     /* NOTREACHED */
1488     return NULL;
1489 }
1490
1491 /*
1492 =for apidoc Am|OP *|die|const char *pat|...
1493
1494 Behaves the same as L</croak>, except for the return type.
1495 It should be used only where the C<OP *> return type is required.
1496 The function never actually returns.
1497
1498 =cut
1499 */
1500
1501 #if defined(PERL_IMPLICIT_CONTEXT)
1502 OP *
1503 Perl_die_nocontext(const char* pat, ...)
1504 {
1505     dTHX;
1506     va_list args;
1507     va_start(args, pat);
1508     vcroak(pat, &args);
1509     /* NOTREACHED */
1510     va_end(args);
1511     return NULL;
1512 }
1513 #endif /* PERL_IMPLICIT_CONTEXT */
1514
1515 OP *
1516 Perl_die(pTHX_ const char* pat, ...)
1517 {
1518     va_list args;
1519     va_start(args, pat);
1520     vcroak(pat, &args);
1521     /* NOTREACHED */
1522     va_end(args);
1523     return NULL;
1524 }
1525
1526 /*
1527 =for apidoc Am|void|croak_sv|SV *baseex
1528
1529 This is an XS interface to Perl's C<die> function.
1530
1531 C<baseex> is the error message or object.  If it is a reference, it
1532 will be used as-is.  Otherwise it is used as a string, and if it does
1533 not end with a newline then it will be extended with some indication of
1534 the current location in the code, as described for L</mess_sv>.
1535
1536 The error message or object will be used as an exception, by default
1537 returning control to the nearest enclosing C<eval>, but subject to
1538 modification by a C<$SIG{__DIE__}> handler.  In any case, the C<croak_sv>
1539 function never returns normally.
1540
1541 To die with a simple string message, the L</croak> function may be
1542 more convenient.
1543
1544 =cut
1545 */
1546
1547 void
1548 Perl_croak_sv(pTHX_ SV *baseex)
1549 {
1550     SV *ex = with_queued_errors(mess_sv(baseex, 0));
1551     PERL_ARGS_ASSERT_CROAK_SV;
1552     invoke_exception_hook(ex, FALSE);
1553     die_unwind(ex);
1554 }
1555
1556 /*
1557 =for apidoc Am|void|vcroak|const char *pat|va_list *args
1558
1559 This is an XS interface to Perl's C<die> function.
1560
1561 C<pat> and C<args> are a sprintf-style format pattern and encapsulated
1562 argument list.  These are used to generate a string message.  If the
1563 message does not end with a newline, then it will be extended with
1564 some indication of the current location in the code, as described for
1565 L</mess_sv>.
1566
1567 The error message will be used as an exception, by default
1568 returning control to the nearest enclosing C<eval>, but subject to
1569 modification by a C<$SIG{__DIE__}> handler.  In any case, the C<croak>
1570 function never returns normally.
1571
1572 For historical reasons, if C<pat> is null then the contents of C<ERRSV>
1573 (C<$@>) will be used as an error message or object instead of building an
1574 error message from arguments.  If you want to throw a non-string object,
1575 or build an error message in an SV yourself, it is preferable to use
1576 the L</croak_sv> function, which does not involve clobbering C<ERRSV>.
1577
1578 =cut
1579 */
1580
1581 void
1582 Perl_vcroak(pTHX_ const char* pat, va_list *args)
1583 {
1584     SV *ex = with_queued_errors(pat ? vmess(pat, args) : mess_sv(ERRSV, 0));
1585     invoke_exception_hook(ex, FALSE);
1586     die_unwind(ex);
1587 }
1588
1589 /*
1590 =for apidoc Am|void|croak|const char *pat|...
1591
1592 This is an XS interface to Perl's C<die> function.
1593
1594 Take a sprintf-style format pattern and argument list.  These are used to
1595 generate a string message.  If the message does not end with a newline,
1596 then it will be extended with some indication of the current location
1597 in the code, as described for L</mess_sv>.
1598
1599 The error message will be used as an exception, by default
1600 returning control to the nearest enclosing C<eval>, but subject to
1601 modification by a C<$SIG{__DIE__}> handler.  In any case, the C<croak>
1602 function never returns normally.
1603
1604 For historical reasons, if C<pat> is null then the contents of C<ERRSV>
1605 (C<$@>) will be used as an error message or object instead of building an
1606 error message from arguments.  If you want to throw a non-string object,
1607 or build an error message in an SV yourself, it is preferable to use
1608 the L</croak_sv> function, which does not involve clobbering C<ERRSV>.
1609
1610 =cut
1611 */
1612
1613 #if defined(PERL_IMPLICIT_CONTEXT)
1614 void
1615 Perl_croak_nocontext(const char *pat, ...)
1616 {
1617     dTHX;
1618     va_list args;
1619     va_start(args, pat);
1620     vcroak(pat, &args);
1621     /* NOTREACHED */
1622     va_end(args);
1623 }
1624 #endif /* PERL_IMPLICIT_CONTEXT */
1625
1626 void
1627 Perl_croak(pTHX_ const char *pat, ...)
1628 {
1629     va_list args;
1630     va_start(args, pat);
1631     vcroak(pat, &args);
1632     /* NOTREACHED */
1633     va_end(args);
1634 }
1635
1636 /*
1637 =for apidoc Am|void|warn_sv|SV *baseex
1638
1639 This is an XS interface to Perl's C<warn> function.
1640
1641 C<baseex> is the error message or object.  If it is a reference, it
1642 will be used as-is.  Otherwise it is used as a string, and if it does
1643 not end with a newline then it will be extended with some indication of
1644 the current location in the code, as described for L</mess_sv>.
1645
1646 The error message or object will by default be written to standard error,
1647 but this is subject to modification by a C<$SIG{__WARN__}> handler.
1648
1649 To warn with a simple string message, the L</warn> function may be
1650 more convenient.
1651
1652 =cut
1653 */
1654
1655 void
1656 Perl_warn_sv(pTHX_ SV *baseex)
1657 {
1658     SV *ex = mess_sv(baseex, 0);
1659     PERL_ARGS_ASSERT_WARN_SV;
1660     if (!invoke_exception_hook(ex, TRUE))
1661         write_to_stderr(ex);
1662 }
1663
1664 /*
1665 =for apidoc Am|void|vwarn|const char *pat|va_list *args
1666
1667 This is an XS interface to Perl's C<warn> function.
1668
1669 C<pat> and C<args> are a sprintf-style format pattern and encapsulated
1670 argument list.  These are used to generate a string message.  If the
1671 message does not end with a newline, then it will be extended with
1672 some indication of the current location in the code, as described for
1673 L</mess_sv>.
1674
1675 The error message or object will by default be written to standard error,
1676 but this is subject to modification by a C<$SIG{__WARN__}> handler.
1677
1678 Unlike with L</vcroak>, C<pat> is not permitted to be null.
1679
1680 =cut
1681 */
1682
1683 void
1684 Perl_vwarn(pTHX_ const char* pat, va_list *args)
1685 {
1686     SV *ex = vmess(pat, args);
1687     PERL_ARGS_ASSERT_VWARN;
1688     if (!invoke_exception_hook(ex, TRUE))
1689         write_to_stderr(ex);
1690 }
1691
1692 /*
1693 =for apidoc Am|void|warn|const char *pat|...
1694
1695 This is an XS interface to Perl's C<warn> function.
1696
1697 Take a sprintf-style format pattern and argument list.  These are used to
1698 generate a string message.  If the message does not end with a newline,
1699 then it will be extended with some indication of the current location
1700 in the code, as described for L</mess_sv>.
1701
1702 The error message or object will by default be written to standard error,
1703 but this is subject to modification by a C<$SIG{__WARN__}> handler.
1704
1705 Unlike with L</croak>, C<pat> is not permitted to be null.
1706
1707 =cut
1708 */
1709
1710 #if defined(PERL_IMPLICIT_CONTEXT)
1711 void
1712 Perl_warn_nocontext(const char *pat, ...)
1713 {
1714     dTHX;
1715     va_list args;
1716     PERL_ARGS_ASSERT_WARN_NOCONTEXT;
1717     va_start(args, pat);
1718     vwarn(pat, &args);
1719     va_end(args);
1720 }
1721 #endif /* PERL_IMPLICIT_CONTEXT */
1722
1723 void
1724 Perl_warn(pTHX_ const char *pat, ...)
1725 {
1726     va_list args;
1727     PERL_ARGS_ASSERT_WARN;
1728     va_start(args, pat);
1729     vwarn(pat, &args);
1730     va_end(args);
1731 }
1732
1733 #if defined(PERL_IMPLICIT_CONTEXT)
1734 void
1735 Perl_warner_nocontext(U32 err, const char *pat, ...)
1736 {
1737     dTHX;
1738     va_list args;
1739     PERL_ARGS_ASSERT_WARNER_NOCONTEXT;
1740     va_start(args, pat);
1741     vwarner(err, pat, &args);
1742     va_end(args);
1743 }
1744 #endif /* PERL_IMPLICIT_CONTEXT */
1745
1746 void
1747 Perl_ck_warner_d(pTHX_ U32 err, const char* pat, ...)
1748 {
1749     PERL_ARGS_ASSERT_CK_WARNER_D;
1750
1751     if (Perl_ckwarn_d(aTHX_ err)) {
1752         va_list args;
1753         va_start(args, pat);
1754         vwarner(err, pat, &args);
1755         va_end(args);
1756     }
1757 }
1758
1759 void
1760 Perl_ck_warner(pTHX_ U32 err, const char* pat, ...)
1761 {
1762     PERL_ARGS_ASSERT_CK_WARNER;
1763
1764     if (Perl_ckwarn(aTHX_ err)) {
1765         va_list args;
1766         va_start(args, pat);
1767         vwarner(err, pat, &args);
1768         va_end(args);
1769     }
1770 }
1771
1772 void
1773 Perl_warner(pTHX_ U32  err, const char* pat,...)
1774 {
1775     va_list args;
1776     PERL_ARGS_ASSERT_WARNER;
1777     va_start(args, pat);
1778     vwarner(err, pat, &args);
1779     va_end(args);
1780 }
1781
1782 void
1783 Perl_vwarner(pTHX_ U32  err, const char* pat, va_list* args)
1784 {
1785     dVAR;
1786     PERL_ARGS_ASSERT_VWARNER;
1787     if (PL_warnhook == PERL_WARNHOOK_FATAL || ckDEAD(err)) {
1788         SV * const msv = vmess(pat, args);
1789
1790         invoke_exception_hook(msv, FALSE);
1791         die_unwind(msv);
1792     }
1793     else {
1794         Perl_vwarn(aTHX_ pat, args);
1795     }
1796 }
1797
1798 /* implements the ckWARN? macros */
1799
1800 bool
1801 Perl_ckwarn(pTHX_ U32 w)
1802 {
1803     dVAR;
1804     /* If lexical warnings have not been set, use $^W.  */
1805     if (isLEXWARN_off)
1806         return PL_dowarn & G_WARN_ON;
1807
1808     return ckwarn_common(w);
1809 }
1810
1811 /* implements the ckWARN?_d macro */
1812
1813 bool
1814 Perl_ckwarn_d(pTHX_ U32 w)
1815 {
1816     dVAR;
1817     /* If lexical warnings have not been set then default classes warn.  */
1818     if (isLEXWARN_off)
1819         return TRUE;
1820
1821     return ckwarn_common(w);
1822 }
1823
1824 static bool
1825 S_ckwarn_common(pTHX_ U32 w)
1826 {
1827     if (PL_curcop->cop_warnings == pWARN_ALL)
1828         return TRUE;
1829
1830     if (PL_curcop->cop_warnings == pWARN_NONE)
1831         return FALSE;
1832
1833     /* Check the assumption that at least the first slot is non-zero.  */
1834     assert(unpackWARN1(w));
1835
1836     /* Check the assumption that it is valid to stop as soon as a zero slot is
1837        seen.  */
1838     if (!unpackWARN2(w)) {
1839         assert(!unpackWARN3(w));
1840         assert(!unpackWARN4(w));
1841     } else if (!unpackWARN3(w)) {
1842         assert(!unpackWARN4(w));
1843     }
1844
1845     /* Right, dealt with all the special cases, which are implemented as non-
1846        pointers, so there is a pointer to a real warnings mask.  */
1847     do {
1848         if (isWARN_on(PL_curcop->cop_warnings, unpackWARN1(w)))
1849             return TRUE;
1850     } while (w >>= WARNshift);
1851
1852     return FALSE;
1853 }
1854
1855 /* Set buffer=NULL to get a new one.  */
1856 STRLEN *
1857 Perl_new_warnings_bitfield(pTHX_ STRLEN *buffer, const char *const bits,
1858                            STRLEN size) {
1859     const MEM_SIZE len_wanted = sizeof(STRLEN) + size;
1860     PERL_UNUSED_CONTEXT;
1861     PERL_ARGS_ASSERT_NEW_WARNINGS_BITFIELD;
1862
1863     buffer = (STRLEN*)
1864         (specialWARN(buffer) ?
1865          PerlMemShared_malloc(len_wanted) :
1866          PerlMemShared_realloc(buffer, len_wanted));
1867     buffer[0] = size;
1868     Copy(bits, (buffer + 1), 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     register I32 i;
1898     register 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     register 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     if (from - to >= 0) {
2036         while (len--)
2037             *to++ = *from++;
2038     }
2039     else {
2040         to += len;
2041         from += len;
2042         while (len--)
2043             *(--to) = *(--from);
2044     }
2045     return retval;
2046 }
2047 #endif
2048
2049 /* this is a drop-in replacement for memset() */
2050 #ifndef HAS_MEMSET
2051 void *
2052 Perl_my_memset(register char *loc, register I32 ch, register I32 len)
2053 {
2054     char * const retval = loc;
2055
2056     PERL_ARGS_ASSERT_MY_MEMSET;
2057
2058     while (len--)
2059         *loc++ = ch;
2060     return retval;
2061 }
2062 #endif
2063
2064 /* this is a drop-in replacement for bzero() */
2065 #if !defined(HAS_BZERO) && !defined(HAS_MEMSET)
2066 char *
2067 Perl_my_bzero(register char *loc, register I32 len)
2068 {
2069     char * const retval = loc;
2070
2071     PERL_ARGS_ASSERT_MY_BZERO;
2072
2073     while (len--)
2074         *loc++ = 0;
2075     return retval;
2076 }
2077 #endif
2078
2079 /* this is a drop-in replacement for memcmp() */
2080 #if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP)
2081 I32
2082 Perl_my_memcmp(const char *s1, const char *s2, register I32 len)
2083 {
2084     register const U8 *a = (const U8 *)s1;
2085     register const U8 *b = (const U8 *)s2;
2086     register I32 tmp;
2087
2088     PERL_ARGS_ASSERT_MY_MEMCMP;
2089
2090     while (len--) {
2091         if ((tmp = *a++ - *b++))
2092             return tmp;
2093     }
2094     return 0;
2095 }
2096 #endif /* !HAS_MEMCMP || !HAS_SANE_MEMCMP */
2097
2098 #ifndef HAS_VPRINTF
2099 /* This vsprintf replacement should generally never get used, since
2100    vsprintf was available in both System V and BSD 2.11.  (There may
2101    be some cross-compilation or embedded set-ups where it is needed,
2102    however.)
2103
2104    If you encounter a problem in this function, it's probably a symptom
2105    that Configure failed to detect your system's vprintf() function.
2106    See the section on "item vsprintf" in the INSTALL file.
2107
2108    This version may compile on systems with BSD-ish <stdio.h>,
2109    but probably won't on others.
2110 */
2111
2112 #ifdef USE_CHAR_VSPRINTF
2113 char *
2114 #else
2115 int
2116 #endif
2117 vsprintf(char *dest, const char *pat, void *args)
2118 {
2119     FILE fakebuf;
2120
2121 #if defined(STDIO_PTR_LVALUE) && defined(STDIO_CNT_LVALUE)
2122     FILE_ptr(&fakebuf) = (STDCHAR *) dest;
2123     FILE_cnt(&fakebuf) = 32767;
2124 #else
2125     /* These probably won't compile -- If you really need
2126        this, you'll have to figure out some other method. */
2127     fakebuf._ptr = dest;
2128     fakebuf._cnt = 32767;
2129 #endif
2130 #ifndef _IOSTRG
2131 #define _IOSTRG 0
2132 #endif
2133     fakebuf._flag = _IOWRT|_IOSTRG;
2134     _doprnt(pat, args, &fakebuf);       /* what a kludge */
2135 #if defined(STDIO_PTR_LVALUE)
2136     *(FILE_ptr(&fakebuf)++) = '\0';
2137 #else
2138     /* PerlIO has probably #defined away fputc, but we want it here. */
2139 #  ifdef fputc
2140 #    undef fputc  /* XXX Should really restore it later */
2141 #  endif
2142     (void)fputc('\0', &fakebuf);
2143 #endif
2144 #ifdef USE_CHAR_VSPRINTF
2145     return(dest);
2146 #else
2147     return 0;           /* perl doesn't use return value */
2148 #endif
2149 }
2150
2151 #endif /* HAS_VPRINTF */
2152
2153 #ifdef MYSWAP
2154 #if BYTEORDER != 0x4321
2155 short
2156 Perl_my_swap(pTHX_ short s)
2157 {
2158 #if (BYTEORDER & 1) == 0
2159     short result;
2160
2161     result = ((s & 255) << 8) + ((s >> 8) & 255);
2162     return result;
2163 #else
2164     return s;
2165 #endif
2166 }
2167
2168 long
2169 Perl_my_htonl(pTHX_ long l)
2170 {
2171     union {
2172         long result;
2173         char c[sizeof(long)];
2174     } u;
2175
2176 #if BYTEORDER == 0x1234 || BYTEORDER == 0x12345678
2177 #if BYTEORDER == 0x12345678
2178     u.result = 0;
2179 #endif
2180     u.c[0] = (l >> 24) & 255;
2181     u.c[1] = (l >> 16) & 255;
2182     u.c[2] = (l >> 8) & 255;
2183     u.c[3] = l & 255;
2184     return u.result;
2185 #else
2186 #if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
2187     Perl_croak(aTHX_ "Unknown BYTEORDER\n");
2188 #else
2189     register I32 o;
2190     register I32 s;
2191
2192     for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
2193         u.c[o & 0xf] = (l >> s) & 255;
2194     }
2195     return u.result;
2196 #endif
2197 #endif
2198 }
2199
2200 long
2201 Perl_my_ntohl(pTHX_ long l)
2202 {
2203     union {
2204         long l;
2205         char c[sizeof(long)];
2206     } u;
2207
2208 #if BYTEORDER == 0x1234
2209     u.c[0] = (l >> 24) & 255;
2210     u.c[1] = (l >> 16) & 255;
2211     u.c[2] = (l >> 8) & 255;
2212     u.c[3] = l & 255;
2213     return u.l;
2214 #else
2215 #if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
2216     Perl_croak(aTHX_ "Unknown BYTEORDER\n");
2217 #else
2218     register I32 o;
2219     register I32 s;
2220
2221     u.l = l;
2222     l = 0;
2223     for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
2224         l |= (u.c[o & 0xf] & 255) << s;
2225     }
2226     return l;
2227 #endif
2228 #endif
2229 }
2230
2231 #endif /* BYTEORDER != 0x4321 */
2232 #endif /* MYSWAP */
2233
2234 /*
2235  * Little-endian byte order functions - 'v' for 'VAX', or 'reVerse'.
2236  * If these functions are defined,
2237  * the BYTEORDER is neither 0x1234 nor 0x4321.
2238  * However, this is not assumed.
2239  * -DWS
2240  */
2241
2242 #define HTOLE(name,type)                                        \
2243         type                                                    \
2244         name (register type n)                                  \
2245         {                                                       \
2246             union {                                             \
2247                 type value;                                     \
2248                 char c[sizeof(type)];                           \
2249             } u;                                                \
2250             register U32 i;                                     \
2251             register U32 s = 0;                                 \
2252             for (i = 0; i < sizeof(u.c); i++, s += 8) {         \
2253                 u.c[i] = (n >> s) & 0xFF;                       \
2254             }                                                   \
2255             return u.value;                                     \
2256         }
2257
2258 #define LETOH(name,type)                                        \
2259         type                                                    \
2260         name (register type n)                                  \
2261         {                                                       \
2262             union {                                             \
2263                 type value;                                     \
2264                 char c[sizeof(type)];                           \
2265             } u;                                                \
2266             register U32 i;                                     \
2267             register U32 s = 0;                                 \
2268             u.value = n;                                        \
2269             n = 0;                                              \
2270             for (i = 0; i < sizeof(u.c); i++, s += 8) {         \
2271                 n |= ((type)(u.c[i] & 0xFF)) << s;              \
2272             }                                                   \
2273             return n;                                           \
2274         }
2275
2276 /*
2277  * Big-endian byte order functions.
2278  */
2279
2280 #define HTOBE(name,type)                                        \
2281         type                                                    \
2282         name (register type n)                                  \
2283         {                                                       \
2284             union {                                             \
2285                 type value;                                     \
2286                 char c[sizeof(type)];                           \
2287             } u;                                                \
2288             register U32 i;                                     \
2289             register U32 s = 8*(sizeof(u.c)-1);                 \
2290             for (i = 0; i < sizeof(u.c); i++, s -= 8) {         \
2291                 u.c[i] = (n >> s) & 0xFF;                       \
2292             }                                                   \
2293             return u.value;                                     \
2294         }
2295
2296 #define BETOH(name,type)                                        \
2297         type                                                    \
2298         name (register type n)                                  \
2299         {                                                       \
2300             union {                                             \
2301                 type value;                                     \
2302                 char c[sizeof(type)];                           \
2303             } u;                                                \
2304             register U32 i;                                     \
2305             register U32 s = 8*(sizeof(u.c)-1);                 \
2306             u.value = n;                                        \
2307             n = 0;                                              \
2308             for (i = 0; i < sizeof(u.c); i++, s -= 8) {         \
2309                 n |= ((type)(u.c[i] & 0xFF)) << s;              \
2310             }                                                   \
2311             return n;                                           \
2312         }
2313
2314 /*
2315  * If we just can't do it...
2316  */
2317
2318 #define NOT_AVAIL(name,type)                                    \
2319         type                                                    \
2320         name (register type n)                                  \
2321         {                                                       \
2322             Perl_croak_nocontext(#name "() not available");     \
2323             return n; /* not reached */                         \
2324         }
2325
2326
2327 #if defined(HAS_HTOVS) && !defined(htovs)
2328 HTOLE(htovs,short)
2329 #endif
2330 #if defined(HAS_HTOVL) && !defined(htovl)
2331 HTOLE(htovl,long)
2332 #endif
2333 #if defined(HAS_VTOHS) && !defined(vtohs)
2334 LETOH(vtohs,short)
2335 #endif
2336 #if defined(HAS_VTOHL) && !defined(vtohl)
2337 LETOH(vtohl,long)
2338 #endif
2339
2340 #ifdef PERL_NEED_MY_HTOLE16
2341 # if U16SIZE == 2
2342 HTOLE(Perl_my_htole16,U16)
2343 # else
2344 NOT_AVAIL(Perl_my_htole16,U16)
2345 # endif
2346 #endif
2347 #ifdef PERL_NEED_MY_LETOH16
2348 # if U16SIZE == 2
2349 LETOH(Perl_my_letoh16,U16)
2350 # else
2351 NOT_AVAIL(Perl_my_letoh16,U16)
2352 # endif
2353 #endif
2354 #ifdef PERL_NEED_MY_HTOBE16
2355 # if U16SIZE == 2
2356 HTOBE(Perl_my_htobe16,U16)
2357 # else
2358 NOT_AVAIL(Perl_my_htobe16,U16)
2359 # endif
2360 #endif
2361 #ifdef PERL_NEED_MY_BETOH16
2362 # if U16SIZE == 2
2363 BETOH(Perl_my_betoh16,U16)
2364 # else
2365 NOT_AVAIL(Perl_my_betoh16,U16)
2366 # endif
2367 #endif
2368
2369 #ifdef PERL_NEED_MY_HTOLE32
2370 # if U32SIZE == 4
2371 HTOLE(Perl_my_htole32,U32)
2372 # else
2373 NOT_AVAIL(Perl_my_htole32,U32)
2374 # endif
2375 #endif
2376 #ifdef PERL_NEED_MY_LETOH32
2377 # if U32SIZE == 4
2378 LETOH(Perl_my_letoh32,U32)
2379 # else
2380 NOT_AVAIL(Perl_my_letoh32,U32)
2381 # endif
2382 #endif
2383 #ifdef PERL_NEED_MY_HTOBE32
2384 # if U32SIZE == 4
2385 HTOBE(Perl_my_htobe32,U32)
2386 # else
2387 NOT_AVAIL(Perl_my_htobe32,U32)
2388 # endif
2389 #endif
2390 #ifdef PERL_NEED_MY_BETOH32
2391 # if U32SIZE == 4
2392 BETOH(Perl_my_betoh32,U32)
2393 # else
2394 NOT_AVAIL(Perl_my_betoh32,U32)
2395 # endif
2396 #endif
2397
2398 #ifdef PERL_NEED_MY_HTOLE64
2399 # if U64SIZE == 8
2400 HTOLE(Perl_my_htole64,U64)
2401 # else
2402 NOT_AVAIL(Perl_my_htole64,U64)
2403 # endif
2404 #endif
2405 #ifdef PERL_NEED_MY_LETOH64
2406 # if U64SIZE == 8
2407 LETOH(Perl_my_letoh64,U64)
2408 # else
2409 NOT_AVAIL(Perl_my_letoh64,U64)
2410 # endif
2411 #endif
2412 #ifdef PERL_NEED_MY_HTOBE64
2413 # if U64SIZE == 8
2414 HTOBE(Perl_my_htobe64,U64)
2415 # else
2416 NOT_AVAIL(Perl_my_htobe64,U64)
2417 # endif
2418 #endif
2419 #ifdef PERL_NEED_MY_BETOH64
2420 # if U64SIZE == 8
2421 BETOH(Perl_my_betoh64,U64)
2422 # else
2423 NOT_AVAIL(Perl_my_betoh64,U64)
2424 # endif
2425 #endif
2426
2427 #ifdef PERL_NEED_MY_HTOLES
2428 HTOLE(Perl_my_htoles,short)
2429 #endif
2430 #ifdef PERL_NEED_MY_LETOHS
2431 LETOH(Perl_my_letohs,short)
2432 #endif
2433 #ifdef PERL_NEED_MY_HTOBES
2434 HTOBE(Perl_my_htobes,short)
2435 #endif
2436 #ifdef PERL_NEED_MY_BETOHS
2437 BETOH(Perl_my_betohs,short)
2438 #endif
2439
2440 #ifdef PERL_NEED_MY_HTOLEI
2441 HTOLE(Perl_my_htolei,int)
2442 #endif
2443 #ifdef PERL_NEED_MY_LETOHI
2444 LETOH(Perl_my_letohi,int)
2445 #endif
2446 #ifdef PERL_NEED_MY_HTOBEI
2447 HTOBE(Perl_my_htobei,int)
2448 #endif
2449 #ifdef PERL_NEED_MY_BETOHI
2450 BETOH(Perl_my_betohi,int)
2451 #endif
2452
2453 #ifdef PERL_NEED_MY_HTOLEL
2454 HTOLE(Perl_my_htolel,long)
2455 #endif
2456 #ifdef PERL_NEED_MY_LETOHL
2457 LETOH(Perl_my_letohl,long)
2458 #endif
2459 #ifdef PERL_NEED_MY_HTOBEL
2460 HTOBE(Perl_my_htobel,long)
2461 #endif
2462 #ifdef PERL_NEED_MY_BETOHL
2463 BETOH(Perl_my_betohl,long)
2464 #endif
2465
2466 void
2467 Perl_my_swabn(void *ptr, int n)
2468 {
2469     register char *s = (char *)ptr;
2470     register char *e = s + (n-1);
2471     register char tc;
2472
2473     PERL_ARGS_ASSERT_MY_SWABN;
2474
2475     for (n /= 2; n > 0; s++, e--, n--) {
2476       tc = *s;
2477       *s = *e;
2478       *e = tc;
2479     }
2480 }
2481
2482 PerlIO *
2483 Perl_my_popen_list(pTHX_ const char *mode, int n, SV **args)
2484 {
2485 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(OS2) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(NETWARE) && !defined(__LIBCATAMOUNT__)
2486     dVAR;
2487     int p[2];
2488     register I32 This, that;
2489     register Pid_t pid;
2490     SV *sv;
2491     I32 did_pipes = 0;
2492     int pp[2];
2493
2494     PERL_ARGS_ASSERT_MY_POPEN_LIST;
2495
2496     PERL_FLUSHALL_FOR_CHILD;
2497     This = (*mode == 'w');
2498     that = !This;
2499     if (PL_tainting) {
2500         taint_env();
2501         taint_proper("Insecure %s%s", "EXEC");
2502     }
2503     if (PerlProc_pipe(p) < 0)
2504         return NULL;
2505     /* Try for another pipe pair for error return */
2506     if (PerlProc_pipe(pp) >= 0)
2507         did_pipes = 1;
2508     while ((pid = PerlProc_fork()) < 0) {
2509         if (errno != EAGAIN) {
2510             PerlLIO_close(p[This]);
2511             PerlLIO_close(p[that]);
2512             if (did_pipes) {
2513                 PerlLIO_close(pp[0]);
2514                 PerlLIO_close(pp[1]);
2515             }
2516             return NULL;
2517         }
2518         Perl_ck_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds");
2519         sleep(5);
2520     }
2521     if (pid == 0) {
2522         /* Child */
2523 #undef THIS
2524 #undef THAT
2525 #define THIS that
2526 #define THAT This
2527         /* Close parent's end of error status pipe (if any) */
2528         if (did_pipes) {
2529             PerlLIO_close(pp[0]);
2530 #if defined(HAS_FCNTL) && defined(F_SETFD)
2531             /* Close error pipe automatically if exec works */
2532             fcntl(pp[1], F_SETFD, FD_CLOEXEC);
2533 #endif
2534         }
2535         /* Now dup our end of _the_ pipe to right position */
2536         if (p[THIS] != (*mode == 'r')) {
2537             PerlLIO_dup2(p[THIS], *mode == 'r');
2538             PerlLIO_close(p[THIS]);
2539             if (p[THAT] != (*mode == 'r'))      /* if dup2() didn't close it */
2540                 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
2541         }
2542         else
2543             PerlLIO_close(p[THAT]);     /* close parent's end of _the_ pipe */
2544 #if !defined(HAS_FCNTL) || !defined(F_SETFD)
2545         /* No automatic close - do it by hand */
2546 #  ifndef NOFILE
2547 #  define NOFILE 20
2548 #  endif
2549         {
2550             int fd;
2551
2552             for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++) {
2553                 if (fd != pp[1])
2554                     PerlLIO_close(fd);
2555             }
2556         }
2557 #endif
2558         do_aexec5(NULL, args-1, args-1+n, pp[1], did_pipes);
2559         PerlProc__exit(1);
2560 #undef THIS
2561 #undef THAT
2562     }
2563     /* Parent */
2564     do_execfree();      /* free any memory malloced by child on fork */
2565     if (did_pipes)
2566         PerlLIO_close(pp[1]);
2567     /* Keep the lower of the two fd numbers */
2568     if (p[that] < p[This]) {
2569         PerlLIO_dup2(p[This], p[that]);
2570         PerlLIO_close(p[This]);
2571         p[This] = p[that];
2572     }
2573     else
2574         PerlLIO_close(p[that]);         /* close child's end of pipe */
2575
2576     sv = *av_fetch(PL_fdpid,p[This],TRUE);
2577     SvUPGRADE(sv,SVt_IV);
2578     SvIV_set(sv, pid);
2579     PL_forkprocess = pid;
2580     /* If we managed to get status pipe check for exec fail */
2581     if (did_pipes && pid > 0) {
2582         int errkid;
2583         unsigned n = 0;
2584         SSize_t n1;
2585
2586         while (n < sizeof(int)) {
2587             n1 = PerlLIO_read(pp[0],
2588                               (void*)(((char*)&errkid)+n),
2589                               (sizeof(int)) - n);
2590             if (n1 <= 0)
2591                 break;
2592             n += n1;
2593         }
2594         PerlLIO_close(pp[0]);
2595         did_pipes = 0;
2596         if (n) {                        /* Error */
2597             int pid2, status;
2598             PerlLIO_close(p[This]);
2599             if (n != sizeof(int))
2600                 Perl_croak(aTHX_ "panic: kid popen errno read");
2601             do {
2602                 pid2 = wait4pid(pid, &status, 0);
2603             } while (pid2 == -1 && errno == EINTR);
2604             errno = errkid;             /* Propagate errno from kid */
2605             return NULL;
2606         }
2607     }
2608     if (did_pipes)
2609          PerlLIO_close(pp[0]);
2610     return PerlIO_fdopen(p[This], mode);
2611 #else
2612 #  ifdef OS2    /* Same, without fork()ing and all extra overhead... */
2613     return my_syspopen4(aTHX_ NULL, mode, n, args);
2614 #  else
2615     Perl_croak(aTHX_ "List form of piped open not implemented");
2616     return (PerlIO *) NULL;
2617 #  endif
2618 #endif
2619 }
2620
2621     /* VMS' my_popen() is in VMS.c, same with OS/2. */
2622 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(__LIBCATAMOUNT__)
2623 PerlIO *
2624 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2625 {
2626     dVAR;
2627     int p[2];
2628     register I32 This, that;
2629     register Pid_t pid;
2630     SV *sv;
2631     const I32 doexec = !(*cmd == '-' && cmd[1] == '\0');
2632     I32 did_pipes = 0;
2633     int pp[2];
2634
2635     PERL_ARGS_ASSERT_MY_POPEN;
2636
2637     PERL_FLUSHALL_FOR_CHILD;
2638 #ifdef OS2
2639     if (doexec) {
2640         return my_syspopen(aTHX_ cmd,mode);
2641     }
2642 #endif
2643     This = (*mode == 'w');
2644     that = !This;
2645     if (doexec && PL_tainting) {
2646         taint_env();
2647         taint_proper("Insecure %s%s", "EXEC");
2648     }
2649     if (PerlProc_pipe(p) < 0)
2650         return NULL;
2651     if (doexec && PerlProc_pipe(pp) >= 0)
2652         did_pipes = 1;
2653     while ((pid = PerlProc_fork()) < 0) {
2654         if (errno != EAGAIN) {
2655             PerlLIO_close(p[This]);
2656             PerlLIO_close(p[that]);
2657             if (did_pipes) {
2658                 PerlLIO_close(pp[0]);
2659                 PerlLIO_close(pp[1]);
2660             }
2661             if (!doexec)
2662                 Perl_croak(aTHX_ "Can't fork: %s", Strerror(errno));
2663             return NULL;
2664         }
2665         Perl_ck_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds");
2666         sleep(5);
2667     }
2668     if (pid == 0) {
2669         GV* tmpgv;
2670
2671 #undef THIS
2672 #undef THAT
2673 #define THIS that
2674 #define THAT This
2675         if (did_pipes) {
2676             PerlLIO_close(pp[0]);
2677 #if defined(HAS_FCNTL) && defined(F_SETFD)
2678             fcntl(pp[1], F_SETFD, FD_CLOEXEC);
2679 #endif
2680         }
2681         if (p[THIS] != (*mode == 'r')) {
2682             PerlLIO_dup2(p[THIS], *mode == 'r');
2683             PerlLIO_close(p[THIS]);
2684             if (p[THAT] != (*mode == 'r'))      /* if dup2() didn't close it */
2685                 PerlLIO_close(p[THAT]);
2686         }
2687         else
2688             PerlLIO_close(p[THAT]);
2689 #ifndef OS2
2690         if (doexec) {
2691 #if !defined(HAS_FCNTL) || !defined(F_SETFD)
2692 #ifndef NOFILE
2693 #define NOFILE 20
2694 #endif
2695             {
2696                 int fd;
2697
2698                 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++)
2699                     if (fd != pp[1])
2700                         PerlLIO_close(fd);
2701             }
2702 #endif
2703             /* may or may not use the shell */
2704             do_exec3(cmd, pp[1], did_pipes);
2705             PerlProc__exit(1);
2706         }
2707 #endif  /* defined OS2 */
2708
2709 #ifdef PERLIO_USING_CRLF
2710    /* Since we circumvent IO layers when we manipulate low-level
2711       filedescriptors directly, need to manually switch to the
2712       default, binary, low-level mode; see PerlIOBuf_open(). */
2713    PerlLIO_setmode((*mode == 'r'), O_BINARY);
2714 #endif
2715
2716         if ((tmpgv = gv_fetchpvs("$", GV_ADD|GV_NOTQUAL, SVt_PV))) {
2717             SvREADONLY_off(GvSV(tmpgv));
2718             sv_setiv(GvSV(tmpgv), PerlProc_getpid());
2719             SvREADONLY_on(GvSV(tmpgv));
2720         }
2721 #ifdef THREADS_HAVE_PIDS
2722         PL_ppid = (IV)getppid();
2723 #endif
2724         PL_forkprocess = 0;
2725 #ifdef PERL_USES_PL_PIDSTATUS
2726         hv_clear(PL_pidstatus); /* we have no children */
2727 #endif
2728         return NULL;
2729 #undef THIS
2730 #undef THAT
2731     }
2732     do_execfree();      /* free any memory malloced by child on vfork */
2733     if (did_pipes)
2734         PerlLIO_close(pp[1]);
2735     if (p[that] < p[This]) {
2736         PerlLIO_dup2(p[This], p[that]);
2737         PerlLIO_close(p[This]);
2738         p[This] = p[that];
2739     }
2740     else
2741         PerlLIO_close(p[that]);
2742
2743     sv = *av_fetch(PL_fdpid,p[This],TRUE);
2744     SvUPGRADE(sv,SVt_IV);
2745     SvIV_set(sv, pid);
2746     PL_forkprocess = pid;
2747     if (did_pipes && pid > 0) {
2748         int errkid;
2749         unsigned n = 0;
2750         SSize_t n1;
2751
2752         while (n < sizeof(int)) {
2753             n1 = PerlLIO_read(pp[0],
2754                               (void*)(((char*)&errkid)+n),
2755                               (sizeof(int)) - n);
2756             if (n1 <= 0)
2757                 break;
2758             n += n1;
2759         }
2760         PerlLIO_close(pp[0]);
2761         did_pipes = 0;
2762         if (n) {                        /* Error */
2763             int pid2, status;
2764             PerlLIO_close(p[This]);
2765             if (n != sizeof(int))
2766                 Perl_croak(aTHX_ "panic: kid popen errno read");
2767             do {
2768                 pid2 = wait4pid(pid, &status, 0);
2769             } while (pid2 == -1 && errno == EINTR);
2770             errno = errkid;             /* Propagate errno from kid */
2771             return NULL;
2772         }
2773     }
2774     if (did_pipes)
2775          PerlLIO_close(pp[0]);
2776     return PerlIO_fdopen(p[This], mode);
2777 }
2778 #else
2779 #if defined(atarist) || defined(EPOC)
2780 FILE *popen();
2781 PerlIO *
2782 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2783 {
2784     PERL_ARGS_ASSERT_MY_POPEN;
2785     PERL_FLUSHALL_FOR_CHILD;
2786     /* Call system's popen() to get a FILE *, then import it.
2787        used 0 for 2nd parameter to PerlIO_importFILE;
2788        apparently not used
2789     */
2790     return PerlIO_importFILE(popen(cmd, mode), 0);
2791 }
2792 #else
2793 #if defined(DJGPP)
2794 FILE *djgpp_popen();
2795 PerlIO *
2796 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2797 {
2798     PERL_FLUSHALL_FOR_CHILD;
2799     /* Call system's popen() to get a FILE *, then import it.
2800        used 0 for 2nd parameter to PerlIO_importFILE;
2801        apparently not used
2802     */
2803     return PerlIO_importFILE(djgpp_popen(cmd, mode), 0);
2804 }
2805 #else
2806 #if defined(__LIBCATAMOUNT__)
2807 PerlIO *
2808 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2809 {
2810     return NULL;
2811 }
2812 #endif
2813 #endif
2814 #endif
2815
2816 #endif /* !DOSISH */
2817
2818 /* this is called in parent before the fork() */
2819 void
2820 Perl_atfork_lock(void)
2821 {
2822    dVAR;
2823 #if defined(USE_ITHREADS)
2824     /* locks must be held in locking order (if any) */
2825 #  ifdef MYMALLOC
2826     MUTEX_LOCK(&PL_malloc_mutex);
2827 #  endif
2828     OP_REFCNT_LOCK;
2829 #endif
2830 }
2831
2832 /* this is called in both parent and child after the fork() */
2833 void
2834 Perl_atfork_unlock(void)
2835 {
2836     dVAR;
2837 #if defined(USE_ITHREADS)
2838     /* locks must be released in same order as in atfork_lock() */
2839 #  ifdef MYMALLOC
2840     MUTEX_UNLOCK(&PL_malloc_mutex);
2841 #  endif
2842     OP_REFCNT_UNLOCK;
2843 #endif
2844 }
2845
2846 Pid_t
2847 Perl_my_fork(void)
2848 {
2849 #if defined(HAS_FORK)
2850     Pid_t pid;
2851 #if defined(USE_ITHREADS) && !defined(HAS_PTHREAD_ATFORK)
2852     atfork_lock();
2853     pid = fork();
2854     atfork_unlock();
2855 #else
2856     /* atfork_lock() and atfork_unlock() are installed as pthread_atfork()
2857      * handlers elsewhere in the code */
2858     pid = fork();
2859 #endif
2860     return pid;
2861 #else
2862     /* this "canna happen" since nothing should be calling here if !HAS_FORK */
2863     Perl_croak_nocontext("fork() not available");
2864     return 0;
2865 #endif /* HAS_FORK */
2866 }
2867
2868 #ifdef DUMP_FDS
2869 void
2870 Perl_dump_fds(pTHX_ const char *const s)
2871 {
2872     int fd;
2873     Stat_t tmpstatbuf;
2874
2875     PERL_ARGS_ASSERT_DUMP_FDS;
2876
2877     PerlIO_printf(Perl_debug_log,"%s", s);
2878     for (fd = 0; fd < 32; fd++) {
2879         if (PerlLIO_fstat(fd,&tmpstatbuf) >= 0)
2880             PerlIO_printf(Perl_debug_log," %d",fd);
2881     }
2882     PerlIO_printf(Perl_debug_log,"\n");
2883     return;
2884 }
2885 #endif  /* DUMP_FDS */
2886
2887 #ifndef HAS_DUP2
2888 int
2889 dup2(int oldfd, int newfd)
2890 {
2891 #if defined(HAS_FCNTL) && defined(F_DUPFD)
2892     if (oldfd == newfd)
2893         return oldfd;
2894     PerlLIO_close(newfd);
2895     return fcntl(oldfd, F_DUPFD, newfd);
2896 #else
2897 #define DUP2_MAX_FDS 256
2898     int fdtmp[DUP2_MAX_FDS];
2899     I32 fdx = 0;
2900     int fd;
2901
2902     if (oldfd == newfd)
2903         return oldfd;
2904     PerlLIO_close(newfd);
2905     /* good enough for low fd's... */
2906     while ((fd = PerlLIO_dup(oldfd)) != newfd && fd >= 0) {
2907         if (fdx >= DUP2_MAX_FDS) {
2908             PerlLIO_close(fd);
2909             fd = -1;
2910             break;
2911         }
2912         fdtmp[fdx++] = fd;
2913     }
2914     while (fdx > 0)
2915         PerlLIO_close(fdtmp[--fdx]);
2916     return fd;
2917 #endif
2918 }
2919 #endif
2920
2921 #ifndef PERL_MICRO
2922 #ifdef HAS_SIGACTION
2923
2924 Sighandler_t
2925 Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
2926 {
2927     dVAR;
2928     struct sigaction act, oact;
2929
2930 #ifdef USE_ITHREADS
2931     /* only "parent" interpreter can diddle signals */
2932     if (PL_curinterp != aTHX)
2933         return (Sighandler_t) SIG_ERR;
2934 #endif
2935
2936     act.sa_handler = (void(*)(int))handler;
2937     sigemptyset(&act.sa_mask);
2938     act.sa_flags = 0;
2939 #ifdef SA_RESTART
2940     if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2941         act.sa_flags |= SA_RESTART;     /* SVR4, 4.3+BSD */
2942 #endif
2943 #if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
2944     if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
2945         act.sa_flags |= SA_NOCLDWAIT;
2946 #endif
2947     if (sigaction(signo, &act, &oact) == -1)
2948         return (Sighandler_t) SIG_ERR;
2949     else
2950         return (Sighandler_t) oact.sa_handler;
2951 }
2952
2953 Sighandler_t
2954 Perl_rsignal_state(pTHX_ int signo)
2955 {
2956     struct sigaction oact;
2957     PERL_UNUSED_CONTEXT;
2958
2959     if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1)
2960         return (Sighandler_t) SIG_ERR;
2961     else
2962         return (Sighandler_t) oact.sa_handler;
2963 }
2964
2965 int
2966 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
2967 {
2968     dVAR;
2969     struct sigaction act;
2970
2971     PERL_ARGS_ASSERT_RSIGNAL_SAVE;
2972
2973 #ifdef USE_ITHREADS
2974     /* only "parent" interpreter can diddle signals */
2975     if (PL_curinterp != aTHX)
2976         return -1;
2977 #endif
2978
2979     act.sa_handler = (void(*)(int))handler;
2980     sigemptyset(&act.sa_mask);
2981     act.sa_flags = 0;
2982 #ifdef SA_RESTART
2983     if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2984         act.sa_flags |= SA_RESTART;     /* SVR4, 4.3+BSD */
2985 #endif
2986 #if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
2987     if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
2988         act.sa_flags |= SA_NOCLDWAIT;
2989 #endif
2990     return sigaction(signo, &act, save);
2991 }
2992
2993 int
2994 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
2995 {
2996     dVAR;
2997 #ifdef USE_ITHREADS
2998     /* only "parent" interpreter can diddle signals */
2999     if (PL_curinterp != aTHX)
3000         return -1;
3001 #endif
3002
3003     return sigaction(signo, save, (struct sigaction *)NULL);
3004 }
3005
3006 #else /* !HAS_SIGACTION */
3007
3008 Sighandler_t
3009 Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
3010 {
3011 #if defined(USE_ITHREADS) && !defined(WIN32)
3012     /* only "parent" interpreter can diddle signals */
3013     if (PL_curinterp != aTHX)
3014         return (Sighandler_t) SIG_ERR;
3015 #endif
3016
3017     return PerlProc_signal(signo, handler);
3018 }
3019
3020 static Signal_t
3021 sig_trap(int signo)
3022 {
3023     dVAR;
3024     PL_sig_trapped++;
3025 }
3026
3027 Sighandler_t
3028 Perl_rsignal_state(pTHX_ int signo)
3029 {
3030     dVAR;
3031     Sighandler_t oldsig;
3032
3033 #if defined(USE_ITHREADS) && !defined(WIN32)
3034     /* only "parent" interpreter can diddle signals */
3035     if (PL_curinterp != aTHX)
3036         return (Sighandler_t) SIG_ERR;
3037 #endif
3038
3039     PL_sig_trapped = 0;
3040     oldsig = PerlProc_signal(signo, sig_trap);
3041     PerlProc_signal(signo, oldsig);
3042     if (PL_sig_trapped)
3043         PerlProc_kill(PerlProc_getpid(), signo);
3044     return oldsig;
3045 }
3046
3047 int
3048 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
3049 {
3050 #if defined(USE_ITHREADS) && !defined(WIN32)
3051     /* only "parent" interpreter can diddle signals */
3052     if (PL_curinterp != aTHX)
3053         return -1;
3054 #endif
3055     *save = PerlProc_signal(signo, handler);
3056     return (*save == (Sighandler_t) SIG_ERR) ? -1 : 0;
3057 }
3058
3059 int
3060 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
3061 {
3062 #if defined(USE_ITHREADS) && !defined(WIN32)
3063     /* only "parent" interpreter can diddle signals */
3064     if (PL_curinterp != aTHX)
3065         return -1;
3066 #endif
3067     return (PerlProc_signal(signo, *save) == (Sighandler_t) SIG_ERR) ? -1 : 0;
3068 }
3069
3070 #endif /* !HAS_SIGACTION */
3071 #endif /* !PERL_MICRO */
3072
3073     /* VMS' my_pclose() is in VMS.c; same with OS/2 */
3074 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(__LIBCATAMOUNT__)
3075 I32
3076 Perl_my_pclose(pTHX_ PerlIO *ptr)
3077 {
3078     dVAR;
3079     Sigsave_t hstat, istat, qstat;
3080     int status;
3081     SV **svp;
3082     Pid_t pid;
3083     Pid_t pid2;
3084     bool close_failed;
3085     dSAVEDERRNO;
3086
3087     svp = av_fetch(PL_fdpid,PerlIO_fileno(ptr),TRUE);
3088     pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1;
3089     SvREFCNT_dec(*svp);
3090     *svp = &PL_sv_undef;
3091 #ifdef OS2
3092     if (pid == -1) {                    /* Opened by popen. */
3093         return my_syspclose(ptr);
3094     }
3095 #endif
3096     close_failed = (PerlIO_close(ptr) == EOF);
3097     SAVE_ERRNO;
3098 #ifdef UTS
3099     if(PerlProc_kill(pid, 0) < 0) { return(pid); }   /* HOM 12/23/91 */
3100 #endif
3101 #ifndef PERL_MICRO
3102     rsignal_save(SIGHUP,  (Sighandler_t) SIG_IGN, &hstat);
3103     rsignal_save(SIGINT,  (Sighandler_t) SIG_IGN, &istat);
3104     rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qstat);
3105 #endif
3106     do {
3107         pid2 = wait4pid(pid, &status, 0);
3108     } while (pid2 == -1 && errno == EINTR);
3109 #ifndef PERL_MICRO
3110     rsignal_restore(SIGHUP, &hstat);
3111     rsignal_restore(SIGINT, &istat);
3112     rsignal_restore(SIGQUIT, &qstat);
3113 #endif
3114     if (close_failed) {
3115         RESTORE_ERRNO;
3116         return -1;
3117     }
3118     return(pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status));
3119 }
3120 #else
3121 #if defined(__LIBCATAMOUNT__)
3122 I32
3123 Perl_my_pclose(pTHX_ PerlIO *ptr)
3124 {
3125     return -1;
3126 }
3127 #endif
3128 #endif /* !DOSISH */
3129
3130 #if  (!defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(NETWARE)) && !defined(__LIBCATAMOUNT__)
3131 I32
3132 Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
3133 {
3134     dVAR;
3135     I32 result = 0;
3136     PERL_ARGS_ASSERT_WAIT4PID;
3137     if (!pid)
3138         return -1;
3139 #ifdef PERL_USES_PL_PIDSTATUS
3140     {
3141         if (pid > 0) {
3142             /* The keys in PL_pidstatus are now the raw 4 (or 8) bytes of the
3143                pid, rather than a string form.  */
3144             SV * const * const svp = hv_fetch(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),FALSE);
3145             if (svp && *svp != &PL_sv_undef) {
3146                 *statusp = SvIVX(*svp);
3147                 (void)hv_delete(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),
3148                                 G_DISCARD);
3149                 return pid;
3150             }
3151         }
3152         else {
3153             HE *entry;
3154
3155             hv_iterinit(PL_pidstatus);
3156             if ((entry = hv_iternext(PL_pidstatus))) {
3157                 SV * const sv = hv_iterval(PL_pidstatus,entry);
3158                 I32 len;
3159                 const char * const spid = hv_iterkey(entry,&len);
3160
3161                 assert (len == sizeof(Pid_t));
3162                 memcpy((char *)&pid, spid, len);
3163                 *statusp = SvIVX(sv);
3164                 /* The hash iterator is currently on this entry, so simply
3165                    calling hv_delete would trigger the lazy delete, which on
3166                    aggregate does more work, beacuse next call to hv_iterinit()
3167                    would spot the flag, and have to call the delete routine,
3168                    while in the meantime any new entries can't re-use that
3169                    memory.  */
3170                 hv_iterinit(PL_pidstatus);
3171                 (void)hv_delete(PL_pidstatus,spid,len,G_DISCARD);
3172                 return pid;
3173             }
3174         }
3175     }
3176 #endif
3177 #ifdef HAS_WAITPID
3178 #  ifdef HAS_WAITPID_RUNTIME
3179     if (!HAS_WAITPID_RUNTIME)
3180         goto hard_way;
3181 #  endif
3182     result = PerlProc_waitpid(pid,statusp,flags);
3183     goto finish;
3184 #endif
3185 #if !defined(HAS_WAITPID) && defined(HAS_WAIT4)
3186     result = wait4((pid==-1)?0:pid,statusp,flags,NULL);
3187     goto finish;
3188 #endif
3189 #ifdef PERL_USES_PL_PIDSTATUS
3190 #if defined(HAS_WAITPID) && defined(HAS_WAITPID_RUNTIME)
3191   hard_way:
3192 #endif
3193     {
3194         if (flags)
3195             Perl_croak(aTHX_ "Can't do waitpid with flags");
3196         else {
3197             while ((result = PerlProc_wait(statusp)) != pid && pid > 0 && result >= 0)
3198                 pidgone(result,*statusp);
3199             if (result < 0)
3200                 *statusp = -1;
3201         }
3202     }
3203 #endif
3204 #if defined(HAS_WAITPID) || defined(HAS_WAIT4)
3205   finish:
3206 #endif
3207     if (result < 0 && errno == EINTR) {
3208         PERL_ASYNC_CHECK();
3209         errno = EINTR; /* reset in case a signal handler changed $! */
3210     }
3211     return result;
3212 }
3213 #endif /* !DOSISH || OS2 || WIN32 || NETWARE */
3214
3215 #ifdef PERL_USES_PL_PIDSTATUS
3216 void
3217 S_pidgone(pTHX_ Pid_t pid, int status)
3218 {
3219     register SV *sv;
3220
3221     sv = *hv_fetch(PL_pidstatus,(const char*)&pid,sizeof(Pid_t),TRUE);
3222     SvUPGRADE(sv,SVt_IV);
3223     SvIV_set(sv, status);
3224     return;
3225 }
3226 #endif
3227
3228 #if defined(atarist) || defined(OS2) || defined(EPOC)
3229 int pclose();
3230 #ifdef HAS_FORK
3231 int                                     /* Cannot prototype with I32
3232                                            in os2ish.h. */
3233 my_syspclose(PerlIO *ptr)
3234 #else
3235 I32
3236 Perl_my_pclose(pTHX_ PerlIO *ptr)
3237 #endif
3238 {
3239     /* Needs work for PerlIO ! */
3240     FILE * const f = PerlIO_findFILE(ptr);
3241     const I32 result = pclose(f);
3242     PerlIO_releaseFILE(ptr,f);
3243     return result;
3244 }
3245 #endif
3246
3247 #if defined(DJGPP)
3248 int djgpp_pclose();
3249 I32
3250 Perl_my_pclose(pTHX_ PerlIO *ptr)
3251 {
3252     /* Needs work for PerlIO ! */
3253     FILE * const f = PerlIO_findFILE(ptr);
3254     I32 result = djgpp_pclose(f);
3255     result = (result << 8) & 0xff00;
3256     PerlIO_releaseFILE(ptr,f);
3257     return result;
3258 }
3259 #endif
3260
3261 #define PERL_REPEATCPY_LINEAR 4
3262 void
3263 Perl_repeatcpy(register char *to, register const char *from, I32 len, register I32 count)
3264 {
3265     PERL_ARGS_ASSERT_REPEATCPY;
3266
3267     if (len == 1)
3268         memset(to, *from, count);
3269     else if (count) {
3270         register char *p = to;
3271         I32 items, linear, half;
3272
3273         linear = count < PERL_REPEATCPY_LINEAR ? count : PERL_REPEATCPY_LINEAR;
3274         for (items = 0; items < linear; ++items) {
3275             register const char *q = from;
3276             I32 todo;
3277             for (todo = len; todo > 0; todo--)
3278                 *p++ = *q++;
3279         }
3280
3281         half = count / 2;
3282         while (items <= half) {
3283             I32 size = items * len;
3284             memcpy(p, to, size);
3285             p     += size;
3286             items *= 2;
3287         }
3288
3289         if (count > items)
3290             memcpy(p, to, (count - items) * len);
3291     }
3292 }
3293
3294 #ifndef HAS_RENAME
3295 I32
3296 Perl_same_dirent(pTHX_ const char *a, const char *b)
3297 {
3298     char *fa = strrchr(a,'/');
3299     char *fb = strrchr(b,'/');
3300     Stat_t tmpstatbuf1;
3301     Stat_t tmpstatbuf2;
3302     SV * const tmpsv = sv_newmortal();
3303
3304     PERL_ARGS_ASSERT_SAME_DIRENT;
3305
3306     if (fa)
3307         fa++;
3308     else
3309         fa = a;
3310     if (fb)
3311         fb++;
3312     else
3313         fb = b;
3314     if (strNE(a,b))
3315         return FALSE;
3316     if (fa == a)
3317         sv_setpvs(tmpsv, ".");
3318     else
3319         sv_setpvn(tmpsv, a, fa - a);
3320     if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf1) < 0)
3321         return FALSE;
3322     if (fb == b)
3323         sv_setpvs(tmpsv, ".");
3324     else
3325         sv_setpvn(tmpsv, b, fb - b);
3326     if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf2) < 0)
3327         return FALSE;
3328     return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev &&
3329            tmpstatbuf1.st_ino == tmpstatbuf2.st_ino;
3330 }
3331 #endif /* !HAS_RENAME */
3332
3333 char*
3334 Perl_find_script(pTHX_ const char *scriptname, bool dosearch,
3335                  const char *const *const search_ext, I32 flags)
3336 {
3337     dVAR;
3338     const char *xfound = NULL;
3339     char *xfailed = NULL;
3340     char tmpbuf[MAXPATHLEN];
3341     register char *s;
3342     I32 len = 0;
3343     int retval;
3344     char *bufend;
3345 #if defined(DOSISH) && !defined(OS2) && !defined(atarist)
3346 #  define SEARCH_EXTS ".bat", ".cmd", NULL
3347 #  define MAX_EXT_LEN 4
3348 #endif
3349 #ifdef OS2
3350 #  define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
3351 #  define MAX_EXT_LEN 4
3352 #endif
3353 #ifdef VMS
3354 #  define SEARCH_EXTS ".pl", ".com", NULL
3355 #  define MAX_EXT_LEN 4
3356 #endif
3357     /* additional extensions to try in each dir if scriptname not found */
3358 #ifdef SEARCH_EXTS
3359     static const char *const exts[] = { SEARCH_EXTS };
3360     const char *const *const ext = search_ext ? search_ext : exts;
3361     int extidx = 0, i = 0;
3362     const char *curext = NULL;
3363 #else
3364     PERL_UNUSED_ARG(search_ext);
3365 #  define MAX_EXT_LEN 0
3366 #endif
3367
3368     PERL_ARGS_ASSERT_FIND_SCRIPT;
3369
3370     /*
3371      * If dosearch is true and if scriptname does not contain path
3372      * delimiters, search the PATH for scriptname.
3373      *
3374      * If SEARCH_EXTS is also defined, will look for each
3375      * scriptname{SEARCH_EXTS} whenever scriptname is not found
3376      * while searching the PATH.
3377      *
3378      * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
3379      * proceeds as follows:
3380      *   If DOSISH or VMSISH:
3381      *     + look for ./scriptname{,.foo,.bar}
3382      *     + search the PATH for scriptname{,.foo,.bar}
3383      *
3384      *   If !DOSISH:
3385      *     + look *only* in the PATH for scriptname{,.foo,.bar} (note
3386      *       this will not look in '.' if it's not in the PATH)
3387      */
3388     tmpbuf[0] = '\0';
3389
3390 #ifdef VMS
3391 #  ifdef ALWAYS_DEFTYPES
3392     len = strlen(scriptname);
3393     if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') {
3394         int idx = 0, deftypes = 1;
3395         bool seen_dot = 1;
3396
3397         const int hasdir = !dosearch || (strpbrk(scriptname,":[</") != NULL);
3398 #  else
3399     if (dosearch) {
3400         int idx = 0, deftypes = 1;
3401         bool seen_dot = 1;
3402
3403         const int hasdir = (strpbrk(scriptname,":[</") != NULL);
3404 #  endif
3405         /* The first time through, just add SEARCH_EXTS to whatever we
3406          * already have, so we can check for default file types. */
3407         while (deftypes ||
3408                (!hasdir && my_trnlnm("DCL$PATH",tmpbuf,idx++)) )
3409         {
3410             if (deftypes) {
3411                 deftypes = 0;
3412                 *tmpbuf = '\0';
3413             }
3414             if ((strlen(tmpbuf) + strlen(scriptname)
3415                  + MAX_EXT_LEN) >= sizeof tmpbuf)
3416                 continue;       /* don't search dir with too-long name */
3417             my_strlcat(tmpbuf, scriptname, sizeof(tmpbuf));
3418 #else  /* !VMS */
3419
3420 #ifdef DOSISH
3421     if (strEQ(scriptname, "-"))
3422         dosearch = 0;
3423     if (dosearch) {             /* Look in '.' first. */
3424         const char *cur = scriptname;
3425 #ifdef SEARCH_EXTS
3426         if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
3427             while (ext[i])
3428                 if (strEQ(ext[i++],curext)) {
3429                     extidx = -1;                /* already has an ext */
3430                     break;
3431                 }
3432         do {
3433 #endif
3434             DEBUG_p(PerlIO_printf(Perl_debug_log,
3435                                   "Looking for %s\n",cur));
3436             if (PerlLIO_stat(cur,&PL_statbuf) >= 0
3437                 && !S_ISDIR(PL_statbuf.st_mode)) {
3438                 dosearch = 0;
3439                 scriptname = cur;
3440 #ifdef SEARCH_EXTS
3441                 break;
3442 #endif
3443             }
3444 #ifdef SEARCH_EXTS
3445             if (cur == scriptname) {
3446                 len = strlen(scriptname);
3447                 if (len+MAX_EXT_LEN+1 >= sizeof(tmpbuf))
3448                     break;
3449                 my_strlcpy(tmpbuf, scriptname, sizeof(tmpbuf));
3450                 cur = tmpbuf;
3451             }
3452         } while (extidx >= 0 && ext[extidx]     /* try an extension? */
3453                  && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len));
3454 #endif
3455     }
3456 #endif
3457
3458     if (dosearch && !strchr(scriptname, '/')
3459 #ifdef DOSISH
3460                  && !strchr(scriptname, '\\')
3461 #endif
3462                  && (s = PerlEnv_getenv("PATH")))
3463     {
3464         bool seen_dot = 0;
3465
3466         bufend = s + strlen(s);
3467         while (s < bufend) {
3468 #if defined(atarist) || defined(DOSISH)
3469             for (len = 0; *s
3470 #  ifdef atarist
3471                     && *s != ','
3472 #  endif
3473                     && *s != ';'; len++, s++) {
3474                 if (len < sizeof tmpbuf)
3475                     tmpbuf[len] = *s;
3476             }
3477             if (len < sizeof tmpbuf)
3478                 tmpbuf[len] = '\0';
3479 #else  /* ! (atarist || DOSISH) */
3480             s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, bufend,
3481                         ':',
3482                         &len);
3483 #endif /* ! (atarist || DOSISH) */
3484             if (s < bufend)
3485                 s++;
3486             if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf)
3487                 continue;       /* don't search dir with too-long name */
3488             if (len
3489 #  if defined(atarist) || defined(DOSISH)
3490                 && tmpbuf[len - 1] != '/'
3491                 && tmpbuf[len - 1] != '\\'
3492 #  endif
3493                )
3494                 tmpbuf[len++] = '/';
3495             if (len == 2 && tmpbuf[0] == '.')
3496                 seen_dot = 1;
3497             (void)my_strlcpy(tmpbuf + len, scriptname, sizeof(tmpbuf) - len);
3498 #endif  /* !VMS */
3499
3500 #ifdef SEARCH_EXTS
3501             len = strlen(tmpbuf);
3502             if (extidx > 0)     /* reset after previous loop */
3503                 extidx = 0;
3504             do {
3505 #endif
3506                 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tmpbuf));
3507                 retval = PerlLIO_stat(tmpbuf,&PL_statbuf);
3508                 if (S_ISDIR(PL_statbuf.st_mode)) {
3509                     retval = -1;
3510                 }
3511 #ifdef SEARCH_EXTS
3512             } while (  retval < 0               /* not there */
3513                     && extidx>=0 && ext[extidx] /* try an extension? */
3514                     && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len)
3515                 );
3516 #endif
3517             if (retval < 0)
3518                 continue;
3519             if (S_ISREG(PL_statbuf.st_mode)
3520                 && cando(S_IRUSR,TRUE,&PL_statbuf)
3521 #if !defined(DOSISH)
3522                 && cando(S_IXUSR,TRUE,&PL_statbuf)
3523 #endif
3524                 )
3525             {
3526                 xfound = tmpbuf;                /* bingo! */
3527                 break;
3528             }
3529             if (!xfailed)
3530                 xfailed = savepv(tmpbuf);
3531         }
3532 #ifndef DOSISH
3533         if (!xfound && !seen_dot && !xfailed &&
3534             (PerlLIO_stat(scriptname,&PL_statbuf) < 0
3535              || S_ISDIR(PL_statbuf.st_mode)))
3536 #endif
3537             seen_dot = 1;                       /* Disable message. */
3538         if (!xfound) {
3539             if (flags & 1) {                    /* do or die? */
3540                 Perl_croak(aTHX_ "Can't %s %s%s%s",
3541                       (xfailed ? "execute" : "find"),
3542                       (xfailed ? xfailed : scriptname),
3543                       (xfailed ? "" : " on PATH"),
3544                       (xfailed || seen_dot) ? "" : ", '.' not in PATH");
3545             }
3546             scriptname = NULL;
3547         }
3548         Safefree(xfailed);
3549         scriptname = xfound;
3550     }
3551     return (scriptname ? savepv(scriptname) : NULL);
3552 }
3553
3554 #ifndef PERL_GET_CONTEXT_DEFINED
3555
3556 void *
3557 Perl_get_context(void)
3558 {
3559     dVAR;
3560 #if defined(USE_ITHREADS)
3561 #  ifdef OLD_PTHREADS_API
3562     pthread_addr_t t;
3563     if (pthread_getspecific(PL_thr_key, &t))
3564         Perl_croak_nocontext("panic: pthread_getspecific");
3565     return (void*)t;
3566 #  else
3567 #    ifdef I_MACH_CTHREADS
3568     return (void*)cthread_data(cthread_self());
3569 #    else
3570     return (void*)PTHREAD_GETSPECIFIC(PL_thr_key);
3571 #    endif
3572 #  endif
3573 #else
3574     return (void*)NULL;
3575 #endif
3576 }
3577
3578 void
3579 Perl_set_context(void *t)
3580 {
3581     dVAR;
3582     PERL_ARGS_ASSERT_SET_CONTEXT;
3583 #if defined(USE_ITHREADS)
3584 #  ifdef I_MACH_CTHREADS
3585     cthread_set_data(cthread_self(), t);
3586 #  else
3587     if (pthread_setspecific(PL_thr_key, t))
3588         Perl_croak_nocontext("panic: pthread_setspecific");
3589 #  endif
3590 #else
3591     PERL_UNUSED_ARG(t);
3592 #endif
3593 }
3594
3595 #endif /* !PERL_GET_CONTEXT_DEFINED */
3596
3597 #if defined(PERL_GLOBAL_STRUCT) && !defined(PERL_GLOBAL_STRUCT_PRIVATE)
3598 struct perl_vars *
3599 Perl_GetVars(pTHX)
3600 {
3601  return &PL_Vars;
3602 }
3603 #endif
3604
3605 char **
3606 Perl_get_op_names(pTHX)
3607 {
3608     PERL_UNUSED_CONTEXT;
3609     return (char **)PL_op_name;
3610 }
3611
3612 char **
3613 Perl_get_op_descs(pTHX)
3614 {
3615     PERL_UNUSED_CONTEXT;
3616     return (char **)PL_op_desc;
3617 }
3618
3619 const char *
3620 Perl_get_no_modify(pTHX)
3621 {
3622     PERL_UNUSED_CONTEXT;
3623     return PL_no_modify;
3624 }
3625
3626 U32 *
3627 Perl_get_opargs(pTHX)
3628 {
3629     PERL_UNUSED_CONTEXT;
3630     return (U32 *)PL_opargs;
3631 }
3632
3633 PPADDR_t*
3634 Perl_get_ppaddr(pTHX)
3635 {
3636     dVAR;
3637     PERL_UNUSED_CONTEXT;
3638     return (PPADDR_t*)PL_ppaddr;
3639 }
3640
3641 #ifndef HAS_GETENV_LEN
3642 char *
3643 Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len)
3644 {
3645     char * const env_trans = PerlEnv_getenv(env_elem);
3646     PERL_UNUSED_CONTEXT;
3647     PERL_ARGS_ASSERT_GETENV_LEN;
3648     if (env_trans)
3649         *len = strlen(env_trans);
3650     return env_trans;
3651 }
3652 #endif
3653
3654
3655 MGVTBL*
3656 Perl_get_vtbl(pTHX_ int vtbl_id)
3657 {
3658     const MGVTBL* result;
3659     PERL_UNUSED_CONTEXT;
3660
3661     switch(vtbl_id) {
3662     case want_vtbl_sv:
3663         result = &PL_vtbl_sv;
3664         break;
3665     case want_vtbl_env:
3666         result = &PL_vtbl_env;
3667         break;
3668     case want_vtbl_envelem:
3669         result = &PL_vtbl_envelem;
3670         break;
3671     case want_vtbl_sig:
3672         result = &PL_vtbl_sig;
3673         break;
3674     case want_vtbl_sigelem:
3675         result = &PL_vtbl_sigelem;
3676         break;
3677     case want_vtbl_pack:
3678         result = &PL_vtbl_pack;
3679         break;
3680     case want_vtbl_packelem:
3681         result = &PL_vtbl_packelem;
3682         break;
3683     case want_vtbl_dbline:
3684         result = &PL_vtbl_dbline;
3685         break;
3686     case want_vtbl_isa:
3687         result = &PL_vtbl_isa;
3688         break;
3689     case want_vtbl_isaelem:
3690         result = &PL_vtbl_isaelem;
3691         break;
3692     case want_vtbl_arylen:
3693         result = &PL_vtbl_arylen;
3694         break;
3695     case want_vtbl_mglob:
3696         result = &PL_vtbl_mglob;
3697         break;
3698     case want_vtbl_nkeys:
3699         result = &PL_vtbl_nkeys;
3700         break;
3701     case want_vtbl_taint:
3702         result = &PL_vtbl_taint;
3703         break;
3704     case want_vtbl_substr:
3705         result = &PL_vtbl_substr;
3706         break;
3707     case want_vtbl_vec:
3708         result = &PL_vtbl_vec;
3709         break;
3710     case want_vtbl_pos:
3711         result = &PL_vtbl_pos;
3712         break;
3713     case want_vtbl_bm:
3714         result = &PL_vtbl_bm;
3715         break;
3716     case want_vtbl_fm:
3717         result = &PL_vtbl_fm;
3718         break;
3719     case want_vtbl_uvar:
3720         result = &PL_vtbl_uvar;
3721         break;
3722     case want_vtbl_defelem:
3723         result = &PL_vtbl_defelem;
3724         break;
3725     case want_vtbl_regexp:
3726         result = &PL_vtbl_regexp;
3727         break;
3728     case want_vtbl_regdata:
3729         result = &PL_vtbl_regdata;
3730         break;
3731     case want_vtbl_regdatum:
3732         result = &PL_vtbl_regdatum;
3733         break;
3734 #ifdef USE_LOCALE_COLLATE
3735     case want_vtbl_collxfrm:
3736         result = &PL_vtbl_collxfrm;
3737         break;
3738 #endif
3739     case want_vtbl_amagic:
3740         result = &PL_vtbl_amagic;
3741         break;
3742     case want_vtbl_amagicelem:
3743         result = &PL_vtbl_amagicelem;
3744         break;
3745     case want_vtbl_backref:
3746         result = &PL_vtbl_backref;
3747         break;
3748     case want_vtbl_utf8:
3749         result = &PL_vtbl_utf8;
3750         break;
3751     default:
3752         result = NULL;
3753         break;
3754     }
3755     return (MGVTBL*)result;
3756 }
3757
3758 I32
3759 Perl_my_fflush_all(pTHX)
3760 {
3761 #if defined(USE_PERLIO) || defined(FFLUSH_NULL) || defined(USE_SFIO)
3762     return PerlIO_flush(NULL);
3763 #else
3764 # if defined(HAS__FWALK)
3765     extern int fflush(FILE *);
3766     /* undocumented, unprototyped, but very useful BSDism */
3767     extern void _fwalk(int (*)(FILE *));
3768     _fwalk(&fflush);
3769     return 0;
3770 # else
3771 #  if defined(FFLUSH_ALL) && defined(HAS_STDIO_STREAM_ARRAY)
3772     long open_max = -1;
3773 #   ifdef PERL_FFLUSH_ALL_FOPEN_MAX
3774     open_max = PERL_FFLUSH_ALL_FOPEN_MAX;
3775 #   else
3776 #    if defined(HAS_SYSCONF) && defined(_SC_OPEN_MAX)
3777     open_max = sysconf(_SC_OPEN_MAX);
3778 #     else
3779 #      ifdef FOPEN_MAX
3780     open_max = FOPEN_MAX;
3781 #      else
3782 #       ifdef OPEN_MAX
3783     open_max = OPEN_MAX;
3784 #       else
3785 #        ifdef _NFILE
3786     open_max = _NFILE;
3787 #        endif
3788 #       endif
3789 #      endif
3790 #     endif
3791 #    endif
3792     if (open_max > 0) {
3793       long i;
3794       for (i = 0; i < open_max; i++)
3795             if (STDIO_STREAM_ARRAY[i]._file >= 0 &&
3796                 STDIO_STREAM_ARRAY[i]._file < open_max &&
3797                 STDIO_STREAM_ARRAY[i]._flag)
3798                 PerlIO_flush(&STDIO_STREAM_ARRAY[i]);
3799       return 0;
3800     }
3801 #  endif
3802     SETERRNO(EBADF,RMS_IFI);
3803     return EOF;
3804 # endif
3805 #endif
3806 }
3807
3808 void
3809 Perl_report_evil_fh(pTHX_ const GV *gv, const IO *io, I32 op)
3810 {
3811     const char * const name = gv && isGV(gv) ? GvENAME(gv) : NULL;
3812
3813     if (op == OP_phoney_OUTPUT_ONLY || op == OP_phoney_INPUT_ONLY) {
3814         if (ckWARN(WARN_IO)) {
3815             const char * const direction =
3816                 (const char *)((op == OP_phoney_INPUT_ONLY) ? "in" : "out");
3817             if (name && *name)
3818                 Perl_warner(aTHX_ packWARN(WARN_IO),
3819                             "Filehandle %s opened only for %sput",
3820                             name, direction);
3821             else
3822                 Perl_warner(aTHX_ packWARN(WARN_IO),
3823                             "Filehandle opened only for %sput", direction);
3824         }
3825     }
3826     else {
3827         const char *vile;
3828         I32   warn_type;
3829
3830         if (gv && io && IoTYPE(io) == IoTYPE_CLOSED) {
3831             vile = "closed";
3832             warn_type = WARN_CLOSED;
3833         }
3834         else {
3835             vile = "unopened";
3836             warn_type = WARN_UNOPENED;
3837         }
3838
3839         if (ckWARN(warn_type)) {
3840             const char * const pars =
3841                 (const char *)(OP_IS_FILETEST(op) ? "" : "()");
3842             const char * const func =
3843                 (const char *)
3844                 (op == OP_READLINE   ? "readline"  :    /* "<HANDLE>" not nice */
3845                  op == OP_LEAVEWRITE ? "write" :                /* "write exit" not nice */
3846                  op < 0              ? "" :              /* handle phoney cases */
3847                  PL_op_desc[op]);
3848             const char * const type =
3849                 (const char *)
3850                 (OP_IS_SOCKET(op) ||
3851                  (gv && io && IoTYPE(io) == IoTYPE_SOCKET) ?
3852                  "socket" : "filehandle");
3853             if (name && *name) {
3854                 Perl_warner(aTHX_ packWARN(warn_type),
3855                             "%s%s on %s %s %s", func, pars, vile, type, name);
3856                 if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3857                     Perl_warner(
3858                         aTHX_ packWARN(warn_type),
3859                         "\t(Are you trying to call %s%s on dirhandle %s?)\n",
3860                         func, pars, name
3861                     );
3862             }
3863             else {
3864                 Perl_warner(aTHX_ packWARN(warn_type),
3865                             "%s%s on %s %s", func, pars, vile, type);
3866                 if (gv && io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3867                     Perl_warner(
3868                         aTHX_ packWARN(warn_type),
3869                         "\t(Are you trying to call %s%s on dirhandle?)\n",
3870                         func, pars
3871                     );
3872             }
3873         }
3874     }
3875 }
3876
3877 /* XXX Add documentation after final interface and behavior is decided */
3878 /* May want to show context for error, so would pass Perl_bslash_c(pTHX_ const char* current, const char* start, const bool output_warning)
3879     U8 source = *current;
3880
3881     May want to add eg, WARN_REGEX
3882 */
3883
3884 char
3885 Perl_grok_bslash_c(pTHX_ const char source, const bool output_warning)
3886 {
3887
3888     U8 result;
3889
3890     if (! isASCII(source)) {
3891         Perl_croak(aTHX_ "Character following \"\\c\" must be ASCII");
3892     }
3893
3894     result = toCTRL(source);
3895     if (! isCNTRL(result)) {
3896         if (source == '{') {
3897             Perl_croak(aTHX_ "It is proposed that \"\\c{\" no longer be valid. It has historically evaluated to\n \";\".  If you disagree with this proposal, send email to perl5-porters@perl.org\nOtherwise, or in the meantime, you can work around this failure by changing\n\"\\c{\" to \";\"");
3898         }
3899         else if (output_warning) {
3900             U8 clearer[3];
3901             U8 i = 0;
3902             if (! isALNUM(result)) {
3903                 clearer[i++] = '\\';
3904             }
3905             clearer[i++] = result;
3906             clearer[i++] = '\0';
3907
3908             Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
3909                             "\"\\c%c\" more clearly written simply as \"%s\"",
3910                             source,
3911                             clearer);
3912         }
3913     }
3914
3915     return result;
3916 }
3917
3918 /* To workaround core dumps from the uninitialised tm_zone we get the
3919  * system to give us a reasonable struct to copy.  This fix means that
3920  * strftime uses the tm_zone and tm_gmtoff values returned by
3921  * localtime(time()). That should give the desired result most of the
3922  * time. But probably not always!
3923  *
3924  * This does not address tzname aspects of NETaa14816.
3925  *
3926  */
3927
3928 #ifdef HAS_GNULIBC
3929 # ifndef STRUCT_TM_HASZONE
3930 #    define STRUCT_TM_HASZONE
3931 # endif
3932 #endif
3933
3934 #ifdef STRUCT_TM_HASZONE /* Backward compat */
3935 # ifndef HAS_TM_TM_ZONE
3936 #    define HAS_TM_TM_ZONE
3937 # endif
3938 #endif
3939
3940 void
3941 Perl_init_tm(pTHX_ struct tm *ptm)      /* see mktime, strftime and asctime */
3942 {
3943 #ifdef HAS_TM_TM_ZONE
3944     Time_t now;
3945     const struct tm* my_tm;
3946     PERL_ARGS_ASSERT_INIT_TM;
3947     (void)time(&now);
3948     my_tm = localtime(&now);
3949     if (my_tm)
3950         Copy(my_tm, ptm, 1, struct tm);
3951 #else
3952     PERL_ARGS_ASSERT_INIT_TM;
3953     PERL_UNUSED_ARG(ptm);
3954 #endif
3955 }
3956
3957 /*
3958  * mini_mktime - normalise struct tm values without the localtime()
3959  * semantics (and overhead) of mktime().
3960  */
3961 void
3962 Perl_mini_mktime(pTHX_ struct tm *ptm)
3963 {
3964     int yearday;
3965     int secs;
3966     int month, mday, year, jday;
3967     int odd_cent, odd_year;
3968     PERL_UNUSED_CONTEXT;
3969
3970     PERL_ARGS_ASSERT_MINI_MKTIME;
3971
3972 #define DAYS_PER_YEAR   365
3973 #define DAYS_PER_QYEAR  (4*DAYS_PER_YEAR+1)
3974 #define DAYS_PER_CENT   (25*DAYS_PER_QYEAR-1)
3975 #define DAYS_PER_QCENT  (4*DAYS_PER_CENT+1)
3976 #define SECS_PER_HOUR   (60*60)
3977 #define SECS_PER_DAY    (24*SECS_PER_HOUR)
3978 /* parentheses deliberately absent on these two, otherwise they don't work */
3979 #define MONTH_TO_DAYS   153/5
3980 #define DAYS_TO_MONTH   5/153
3981 /* offset to bias by March (month 4) 1st between month/mday & year finding */
3982 #define YEAR_ADJUST     (4*MONTH_TO_DAYS+1)
3983 /* as used here, the algorithm leaves Sunday as day 1 unless we adjust it */
3984 #define WEEKDAY_BIAS    6       /* (1+6)%7 makes Sunday 0 again */
3985
3986 /*
3987  * Year/day algorithm notes:
3988  *
3989  * With a suitable offset for numeric value of the month, one can find
3990  * an offset into the year by considering months to have 30.6 (153/5) days,
3991  * using integer arithmetic (i.e., with truncation).  To avoid too much
3992  * messing about with leap days, we consider January and February to be
3993  * the 13th and 14th month of the previous year.  After that transformation,
3994  * we need the month index we use to be high by 1 from 'normal human' usage,
3995  * so the month index values we use run from 4 through 15.
3996  *
3997  * Given that, and the rules for the Gregorian calendar (leap years are those
3998  * divisible by 4 unless also divisible by 100, when they must be divisible
3999  * by 400 instead), we can simply calculate the number of days since some
4000  * arbitrary 'beginning of time' by futzing with the (adjusted) year number,
4001  * the days we derive from our month index, and adding in the day of the
4002  * month.  The value used here is not adjusted for the actual origin which
4003  * it normally would use (1 January A.D. 1), since we're not exposing it.
4004  * We're only building the value so we can turn around and get the
4005  * normalised values for the year, month, day-of-month, and day-of-year.
4006  *
4007  * For going backward, we need to bias the value we're using so that we find
4008  * the right year value.  (Basically, we don't want the contribution of
4009  * March 1st to the number to apply while deriving the year).  Having done
4010  * that, we 'count up' the contribution to the year number by accounting for
4011  * full quadracenturies (400-year periods) with their extra leap days, plus
4012  * the contribution from full centuries (to avoid counting in the lost leap
4013  * days), plus the contribution from full quad-years (to count in the normal
4014  * leap days), plus the leftover contribution from any non-leap years.
4015  * At this point, if we were working with an actual leap day, we'll have 0
4016  * days left over.  This is also true for March 1st, however.  So, we have
4017  * to special-case that result, and (earlier) keep track of the 'odd'
4018  * century and year contributions.  If we got 4 extra centuries in a qcent,
4019  * or 4 extra years in a qyear, then it's a leap day and we call it 29 Feb.
4020  * Otherwise, we add back in the earlier bias we removed (the 123 from
4021  * figuring in March 1st), find the month index (integer division by 30.6),
4022  * and the remainder is the day-of-month.  We then have to convert back to
4023  * 'real' months (including fixing January and February from being 14/15 in
4024  * the previous year to being in the proper year).  After that, to get
4025  * tm_yday, we work with the normalised year and get a new yearday value for
4026  * January 1st, which we subtract from the yearday value we had earlier,
4027  * representing the date we've re-built.  This is done from January 1
4028  * because tm_yday is 0-origin.
4029  *
4030  * Since POSIX time routines are only guaranteed to work for times since the
4031  * UNIX epoch (00:00:00 1 Jan 1970 UTC), the fact that this algorithm
4032  * applies Gregorian calendar rules even to dates before the 16th century
4033  * doesn't bother me.  Besides, you'd need cultural context for a given
4034  * date to know whether it was Julian or Gregorian calendar, and that's
4035  * outside the scope for this routine.  Since we convert back based on the
4036  * same rules we used to build the yearday, you'll only get strange results
4037  * for input which needed normalising, or for the 'odd' century years which
4038  * were leap years in the Julian calander but not in the Gregorian one.
4039  * I can live with that.
4040  *
4041  * This algorithm also fails to handle years before A.D. 1 gracefully, but
4042  * that's still outside the scope for POSIX time manipulation, so I don't
4043  * care.
4044  */
4045
4046     year = 1900 + ptm->tm_year;
4047     month = ptm->tm_mon;
4048     mday = ptm->tm_mday;
4049     /* allow given yday with no month & mday to dominate the result */
4050     if (ptm->tm_yday >= 0 && mday <= 0 && month <= 0) {
4051         month = 0;
4052         mday = 0;
4053         jday = 1 + ptm->tm_yday;
4054     }
4055     else {
4056         jday = 0;
4057     }
4058     if (month >= 2)
4059         month+=2;
4060     else
4061         month+=14, year--;
4062     yearday = DAYS_PER_YEAR * year + year/4 - year/100 + year/400;
4063     yearday += month*MONTH_TO_DAYS + mday + jday;
4064     /*
4065      * Note that we don't know when leap-seconds were or will be,
4066      * so we have to trust the user if we get something which looks
4067      * like a sensible leap-second.  Wild values for seconds will
4068      * be rationalised, however.
4069      */
4070     if ((unsigned) ptm->tm_sec <= 60) {
4071         secs = 0;
4072     }
4073     else {
4074         secs = ptm->tm_sec;
4075         ptm->tm_sec = 0;
4076     }
4077     secs += 60 * ptm->tm_min;
4078     secs += SECS_PER_HOUR * ptm->tm_hour;
4079     if (secs < 0) {
4080         if (secs-(secs/SECS_PER_DAY*SECS_PER_DAY) < 0) {
4081             /* got negative remainder, but need positive time */
4082             /* back off an extra day to compensate */
4083             yearday += (secs/SECS_PER_DAY)-1;
4084             secs -= SECS_PER_DAY * (secs/SECS_PER_DAY - 1);
4085         }
4086         else {
4087             yearday += (secs/SECS_PER_DAY);
4088             secs -= SECS_PER_DAY * (secs/SECS_PER_DAY);
4089         }
4090     }
4091     else if (secs >= SECS_PER_DAY) {
4092         yearday += (secs/SECS_PER_DAY);
4093         secs %= SECS_PER_DAY;
4094     }
4095     ptm->tm_hour = secs/SECS_PER_HOUR;
4096     secs %= SECS_PER_HOUR;
4097     ptm->tm_min = secs/60;
4098     secs %= 60;
4099     ptm->tm_sec += secs;
4100     /* done with time of day effects */
4101     /*
4102      * The algorithm for yearday has (so far) left it high by 428.
4103      * To avoid mistaking a legitimate Feb 29 as Mar 1, we need to
4104      * bias it by 123 while trying to figure out what year it
4105      * really represents.  Even with this tweak, the reverse
4106      * translation fails for years before A.D. 0001.
4107      * It would still fail for Feb 29, but we catch that one below.
4108      */
4109     jday = yearday;     /* save for later fixup vis-a-vis Jan 1 */
4110     yearday -= YEAR_ADJUST;
4111     year = (yearday / DAYS_PER_QCENT) * 400;
4112     yearday %= DAYS_PER_QCENT;
4113     odd_cent = yearday / DAYS_PER_CENT;
4114     year += odd_cent * 100;
4115     yearday %= DAYS_PER_CENT;
4116     year += (yearday / DAYS_PER_QYEAR) * 4;
4117     yearday %= DAYS_PER_QYEAR;
4118     odd_year = yearday / DAYS_PER_YEAR;
4119     year += odd_year;
4120     yearday %= DAYS_PER_YEAR;
4121     if (!yearday && (odd_cent==4 || odd_year==4)) { /* catch Feb 29 */
4122         month = 1;
4123         yearday = 29;
4124     }
4125     else {
4126         yearday += YEAR_ADJUST; /* recover March 1st crock */
4127         month = yearday*DAYS_TO_MONTH;
4128         yearday -= month*MONTH_TO_DAYS;
4129         /* recover other leap-year adjustment */
4130         if (month > 13) {
4131             month-=14;
4132             year++;
4133         }
4134         else {
4135             month-=2;
4136         }
4137     }
4138     ptm->tm_year = year - 1900;
4139     if (yearday) {
4140       ptm->tm_mday = yearday;
4141       ptm->tm_mon = month;
4142     }
4143     else {
4144       ptm->tm_mday = 31;
4145       ptm->tm_mon = month - 1;
4146     }
4147     /* re-build yearday based on Jan 1 to get tm_yday */
4148     year--;
4149     yearday = year*DAYS_PER_YEAR + year/4 - year/100 + year/400;
4150     yearday += 14*MONTH_TO_DAYS + 1;
4151     ptm->tm_yday = jday - yearday;
4152     /* fix tm_wday if not overridden by caller */
4153     if ((unsigned)ptm->tm_wday > 6)
4154         ptm->tm_wday = (jday + WEEKDAY_BIAS) % 7;
4155 }
4156
4157 char *
4158 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)
4159 {
4160 #ifdef HAS_STRFTIME
4161   char *buf;
4162   int buflen;
4163   struct tm mytm;
4164   int len;
4165
4166   PERL_ARGS_ASSERT_MY_STRFTIME;
4167
4168   init_tm(&mytm);       /* XXX workaround - see init_tm() above */
4169   mytm.tm_sec = sec;
4170   mytm.tm_min = min;
4171   mytm.tm_hour = hour;
4172   mytm.tm_mday = mday;
4173   mytm.tm_mon = mon;
4174   mytm.tm_year = year;
4175   mytm.tm_wday = wday;
4176   mytm.tm_yday = yday;
4177   mytm.tm_isdst = isdst;
4178   mini_mktime(&mytm);
4179   /* use libc to get the values for tm_gmtoff and tm_zone [perl #18238] */
4180 #if defined(HAS_MKTIME) && (defined(HAS_TM_TM_GMTOFF) || defined(HAS_TM_TM_ZONE))
4181   STMT_START {
4182     struct tm mytm2;
4183     mytm2 = mytm;
4184     mktime(&mytm2);
4185 #ifdef HAS_TM_TM_GMTOFF
4186     mytm.tm_gmtoff = mytm2.tm_gmtoff;
4187 #endif
4188 #ifdef HAS_TM_TM_ZONE
4189     mytm.tm_zone = mytm2.tm_zone;
4190 #endif
4191   } STMT_END;
4192 #endif
4193   buflen = 64;
4194   Newx(buf, buflen, char);
4195   len = strftime(buf, buflen, fmt, &mytm);
4196   /*
4197   ** The following is needed to handle to the situation where
4198   ** tmpbuf overflows.  Basically we want to allocate a buffer
4199   ** and try repeatedly.  The reason why it is so complicated
4200   ** is that getting a return value of 0 from strftime can indicate
4201   ** one of the following:
4202   ** 1. buffer overflowed,
4203   ** 2. illegal conversion specifier, or
4204   ** 3. the format string specifies nothing to be returned(not
4205   **      an error).  This could be because format is an empty string
4206   **    or it specifies %p that yields an empty string in some locale.
4207   ** If there is a better way to make it portable, go ahead by
4208   ** all means.
4209   */
4210   if ((len > 0 && len < buflen) || (len == 0 && *fmt == '\0'))
4211     return buf;
4212   else {
4213     /* Possibly buf overflowed - try again with a bigger buf */
4214     const int fmtlen = strlen(fmt);
4215     int bufsize = fmtlen + buflen;
4216
4217     Newx(buf, bufsize, char);
4218     while (buf) {
4219       buflen = strftime(buf, bufsize, fmt, &mytm);
4220       if (buflen > 0 && buflen < bufsize)
4221         break;
4222       /* heuristic to prevent out-of-memory errors */
4223       if (bufsize > 100*fmtlen) {
4224         Safefree(buf);
4225         buf = NULL;
4226         break;
4227       }
4228       bufsize *= 2;
4229       Renew(buf, bufsize, char);
4230     }
4231     return buf;
4232   }
4233 #else
4234   Perl_croak(aTHX_ "panic: no strftime");
4235   return NULL;
4236 #endif
4237 }
4238
4239
4240 #define SV_CWD_RETURN_UNDEF \
4241 sv_setsv(sv, &PL_sv_undef); \
4242 return FALSE
4243
4244 #define SV_CWD_ISDOT(dp) \
4245     (dp->d_name[0] == '.' && (dp->d_name[1] == '\0' || \
4246         (dp->d_name[1] == '.' && dp->d_name[2] == '\0')))
4247
4248 /*
4249 =head1 Miscellaneous Functions
4250
4251 =for apidoc getcwd_sv
4252
4253 Fill the sv with current working directory
4254
4255 =cut
4256 */
4257
4258 /* Originally written in Perl by John Bazik; rewritten in C by Ben Sugars.
4259  * rewritten again by dougm, optimized for use with xs TARG, and to prefer
4260  * getcwd(3) if available
4261  * Comments from the orignal:
4262  *     This is a faster version of getcwd.  It's also more dangerous
4263  *     because you might chdir out of a directory that you can't chdir
4264  *     back into. */
4265
4266 int
4267 Perl_getcwd_sv(pTHX_ register SV *sv)
4268 {
4269 #ifndef PERL_MICRO
4270     dVAR;
4271 #ifndef INCOMPLETE_TAINTS
4272     SvTAINTED_on(sv);
4273 #endif
4274
4275     PERL_ARGS_ASSERT_GETCWD_SV;
4276
4277 #ifdef HAS_GETCWD
4278     {
4279         char buf[MAXPATHLEN];
4280
4281         /* Some getcwd()s automatically allocate a buffer of the given
4282          * size from the heap if they are given a NULL buffer pointer.
4283          * The problem is that this behaviour is not portable. */
4284         if (getcwd(buf, sizeof(buf) - 1)) {
4285             sv_setpv(sv, buf);
4286             return TRUE;
4287         }
4288         else {
4289             sv_setsv(sv, &PL_sv_undef);
4290             return FALSE;
4291         }
4292     }
4293
4294 #else
4295
4296     Stat_t statbuf;
4297     int orig_cdev, orig_cino, cdev, cino, odev, oino, tdev, tino;
4298     int pathlen=0;
4299     Direntry_t *dp;
4300
4301     SvUPGRADE(sv, SVt_PV);
4302
4303     if (PerlLIO_lstat(".", &statbuf) < 0) {
4304         SV_CWD_RETURN_UNDEF;
4305     }
4306
4307     orig_cdev = statbuf.st_dev;
4308     orig_cino = statbuf.st_ino;
4309     cdev = orig_cdev;
4310     cino = orig_cino;
4311
4312     for (;;) {
4313         DIR *dir;
4314         int namelen;
4315         odev = cdev;
4316         oino = cino;
4317
4318         if (PerlDir_chdir("..") < 0) {
4319             SV_CWD_RETURN_UNDEF;
4320         }
4321         if (PerlLIO_stat(".", &statbuf) < 0) {
4322             SV_CWD_RETURN_UNDEF;
4323         }
4324
4325         cdev = statbuf.st_dev;
4326         cino = statbuf.st_ino;
4327
4328         if (odev == cdev && oino == cino) {
4329             break;
4330         }
4331         if (!(dir = PerlDir_open("."))) {
4332             SV_CWD_RETURN_UNDEF;
4333         }
4334
4335         while ((dp = PerlDir_read(dir)) != NULL) {
4336 #ifdef DIRNAMLEN
4337             namelen = dp->d_namlen;
4338 #else
4339             namelen = strlen(dp->d_name);
4340 #endif
4341             /* skip . and .. */
4342             if (SV_CWD_ISDOT(dp)) {
4343                 continue;
4344             }
4345
4346             if (PerlLIO_lstat(dp->d_name, &statbuf) < 0) {
4347                 SV_CWD_RETURN_UNDEF;
4348             }
4349
4350             tdev = statbuf.st_dev;
4351             tino = statbuf.st_ino;
4352             if (tino == oino && tdev == odev) {
4353                 break;
4354             }
4355         }
4356
4357         if (!dp) {
4358             SV_CWD_RETURN_UNDEF;
4359         }
4360
4361         if (pathlen + namelen + 1 >= MAXPATHLEN) {
4362             SV_CWD_RETURN_UNDEF;
4363         }
4364
4365         SvGROW(sv, pathlen + namelen + 1);
4366
4367         if (pathlen) {
4368             /* shift down */
4369             Move(SvPVX_const(sv), SvPVX(sv) + namelen + 1, pathlen, char);
4370         }
4371
4372         /* prepend current directory to the front */
4373         *SvPVX(sv) = '/';
4374         Move(dp->d_name, SvPVX(sv)+1, namelen, char);
4375         pathlen += (namelen + 1);
4376
4377 #ifdef VOID_CLOSEDIR
4378         PerlDir_close(dir);
4379 #else
4380         if (PerlDir_close(dir) < 0) {
4381             SV_CWD_RETURN_UNDEF;
4382         }
4383 #endif
4384     }
4385
4386     if (pathlen) {
4387         SvCUR_set(sv, pathlen);
4388         *SvEND(sv) = '\0';
4389         SvPOK_only(sv);
4390
4391         if (PerlDir_chdir(SvPVX_const(sv)) < 0) {
4392             SV_CWD_RETURN_UNDEF;
4393         }
4394     }
4395     if (PerlLIO_stat(".", &statbuf) < 0) {
4396         SV_CWD_RETURN_UNDEF;
4397     }
4398
4399     cdev = statbuf.st_dev;
4400     cino = statbuf.st_ino;
4401
4402     if (cdev != orig_cdev || cino != orig_cino) {
4403         Perl_croak(aTHX_ "Unstable directory path, "
4404                    "current directory changed unexpectedly");
4405     }
4406
4407     return TRUE;
4408 #endif
4409
4410 #else
4411     return FALSE;
4412 #endif
4413 }
4414
4415 #define VERSION_MAX 0x7FFFFFFF
4416
4417 /*
4418 =for apidoc prescan_version
4419
4420 =cut
4421 */
4422 const char *
4423 Perl_prescan_version(pTHX_ const char *s, bool strict,
4424                      const char **errstr,
4425                      bool *sqv, int *ssaw_decimal, int *swidth, bool *salpha) {
4426     bool qv = (sqv ? *sqv : FALSE);
4427     int width = 3;
4428     int saw_decimal = 0;
4429     bool alpha = FALSE;
4430     const char *d = s;
4431
4432     PERL_ARGS_ASSERT_PRESCAN_VERSION;
4433
4434     if (qv && isDIGIT(*d))
4435         goto dotted_decimal_version;
4436
4437     if (*d == 'v') { /* explicit v-string */
4438         d++;
4439         if (isDIGIT(*d)) {
4440             qv = TRUE;
4441         }
4442         else { /* degenerate v-string */
4443             /* requires v1.2.3 */
4444             BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
4445         }
4446
4447 dotted_decimal_version:
4448         if (strict && d[0] == '0' && isDIGIT(d[1])) {
4449             /* no leading zeros allowed */
4450             BADVERSION(s,errstr,"Invalid version format (no leading zeros)");
4451         }
4452
4453         while (isDIGIT(*d))     /* integer part */
4454             d++;
4455
4456         if (*d == '.')
4457         {
4458             saw_decimal++;
4459             d++;                /* decimal point */
4460         }
4461         else
4462         {
4463             if (strict) {
4464                 /* require v1.2.3 */
4465                 BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
4466             }
4467             else {
4468                 goto version_prescan_finish;
4469             }
4470         }
4471
4472         {
4473             int i = 0;
4474             int j = 0;
4475             while (isDIGIT(*d)) {       /* just keep reading */
4476                 i++;
4477                 while (isDIGIT(*d)) {
4478                     d++; j++;
4479                     /* maximum 3 digits between decimal */
4480                     if (strict && j > 3) {
4481                         BADVERSION(s,errstr,"Invalid version format (maximum 3 digits between decimals)");
4482                     }
4483                 }
4484                 if (*d == '_') {
4485                     if (strict) {
4486                         BADVERSION(s,errstr,"Invalid version format (no underscores)");
4487                     }
4488                     if ( alpha ) {
4489                         BADVERSION(s,errstr,"Invalid version format (multiple underscores)");
4490                     }
4491                     d++;
4492                     alpha = TRUE;
4493                 }
4494                 else if (*d == '.') {
4495                     if (alpha) {
4496                         BADVERSION(s,errstr,"Invalid version format (underscores before decimal)");
4497                     }
4498                     saw_decimal++;
4499                     d++;
4500                 }
4501                 else if (!isDIGIT(*d)) {
4502                     break;
4503                 }
4504                 j = 0;
4505             }
4506
4507             if (strict && i < 2) {
4508                 /* requires v1.2.3 */
4509                 BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
4510             }
4511         }
4512     }                                   /* end if dotted-decimal */
4513     else
4514     {                                   /* decimal versions */
4515         /* special strict case for leading '.' or '0' */
4516         if (strict) {
4517             if (*d == '.') {
4518                 BADVERSION(s,errstr,"Invalid version format (0 before decimal required)");
4519             }
4520             if (*d == '0' && isDIGIT(d[1])) {
4521                 BADVERSION(s,errstr,"Invalid version format (no leading zeros)");
4522             }
4523         }
4524
4525         /* consume all of the integer part */
4526         while (isDIGIT(*d))
4527             d++;
4528
4529         /* look for a fractional part */
4530         if (*d == '.') {
4531             /* we found it, so consume it */
4532             saw_decimal++;
4533             d++;
4534         }
4535         else if (!*d || *d == ';' || isSPACE(*d) || *d == '{' || *d == '}') {
4536             if ( d == s ) {
4537                 /* found nothing */
4538                 BADVERSION(s,errstr,"Invalid version format (version required)");
4539             }
4540             /* found just an integer */
4541             goto version_prescan_finish;
4542         }
4543         else if ( d == s ) {
4544             /* didn't find either integer or period */
4545             BADVERSION(s,errstr,"Invalid version format (non-numeric data)");
4546         }
4547         else if (*d == '_') {
4548             /* underscore can't come after integer part */
4549             if (strict) {
4550                 BADVERSION(s,errstr,"Invalid version format (no underscores)");
4551             }
4552             else if (isDIGIT(d[1])) {
4553                 BADVERSION(s,errstr,"Invalid version format (alpha without decimal)");
4554             }
4555             else {
4556                 BADVERSION(s,errstr,"Invalid version format (misplaced underscore)");
4557             }
4558         }
4559         else {
4560             /* anything else after integer part is just invalid data */
4561             BADVERSION(s,errstr,"Invalid version format (non-numeric data)");
4562         }
4563
4564         /* scan the fractional part after the decimal point*/
4565
4566         if (!isDIGIT(*d) && (strict || ! (!*d || *d == ';' || isSPACE(*d) || *d == '{' || *d == '}') )) {
4567                 /* strict or lax-but-not-the-end */
4568                 BADVERSION(s,errstr,"Invalid version format (fractional part required)");
4569         }
4570
4571         while (isDIGIT(*d)) {
4572             d++;
4573             if (*d == '.' && isDIGIT(d[-1])) {
4574                 if (alpha) {
4575                     BADVERSION(s,errstr,"Invalid version format (underscores before decimal)");
4576                 }
4577                 if (strict) {
4578                     BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions must begin with 'v')");
4579                 }
4580                 d = (char *)s;          /* start all over again */
4581                 qv = TRUE;
4582                 goto dotted_decimal_version;
4583             }
4584             if (*d == '_') {
4585                 if (strict) {
4586                     BADVERSION(s,errstr,"Invalid version format (no underscores)");
4587                 }
4588                 if ( alpha ) {
4589                     BADVERSION(s,errstr,"Invalid version format (multiple underscores)");
4590                 }
4591                 if ( ! isDIGIT(d[1]) ) {
4592                     BADVERSION(s,errstr,"Invalid version format (misplaced underscore)");
4593                 }
4594                 d++;
4595                 alpha = TRUE;
4596             }
4597         }
4598     }
4599
4600 version_prescan_finish:
4601     while (isSPACE(*d))
4602         d++;
4603
4604     if (!isDIGIT(*d) && (! (!*d || *d == ';' || *d == '{' || *d == '}') )) {
4605         /* trailing non-numeric data */
4606         BADVERSION(s,errstr,"Invalid version format (non-numeric data)");
4607     }
4608
4609     if (sqv)
4610         *sqv = qv;
4611     if (swidth)
4612         *swidth = width;
4613     if (ssaw_decimal)
4614         *ssaw_decimal = saw_decimal;
4615     if (salpha)
4616         *salpha = alpha;
4617     return d;
4618 }
4619
4620 /*
4621 =for apidoc scan_version
4622
4623 Returns a pointer to the next character after the parsed
4624 version string, as well as upgrading the passed in SV to
4625 an RV.
4626
4627 Function must be called with an already existing SV like
4628
4629     sv = newSV(0);
4630     s = scan_version(s, SV *sv, bool qv);
4631
4632 Performs some preprocessing to the string to ensure that
4633 it has the correct characteristics of a version.  Flags the
4634 object if it contains an underscore (which denotes this
4635 is an alpha version).  The boolean qv denotes that the version
4636 should be interpreted as if it had multiple decimals, even if
4637 it doesn't.
4638
4639 =cut
4640 */
4641
4642 const char *
4643 Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
4644 {
4645     const char *start;
4646     const char *pos;
4647     const char *last;
4648     const char *errstr = NULL;
4649     int saw_decimal = 0;
4650     int width = 3;
4651     bool alpha = FALSE;
4652     bool vinf = FALSE;
4653     AV * const av = newAV();
4654     SV * const hv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */
4655
4656     PERL_ARGS_ASSERT_SCAN_VERSION;
4657
4658     (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
4659
4660 #ifndef NODEFAULT_SHAREKEYS
4661     HvSHAREKEYS_on(hv);         /* key-sharing on by default */
4662 #endif
4663
4664     while (isSPACE(*s)) /* leading whitespace is OK */
4665         s++;
4666
4667     last = prescan_version(s, FALSE, &errstr, &qv, &saw_decimal, &width, &alpha);
4668     if (errstr) {
4669         /* "undef" is a special case and not an error */
4670         if ( ! ( *s == 'u' && strEQ(s,"undef")) ) {
4671             Perl_croak(aTHX_ "%s", errstr);
4672         }
4673     }
4674
4675     start = s;
4676     if (*s == 'v')
4677         s++;
4678     pos = s;
4679
4680     if ( qv )
4681         (void)hv_stores(MUTABLE_HV(hv), "qv", newSViv(qv));
4682     if ( alpha )
4683         (void)hv_stores(MUTABLE_HV(hv), "alpha", newSViv(alpha));
4684     if ( !qv && width < 3 )
4685         (void)hv_stores(MUTABLE_HV(hv), "width", newSViv(width));
4686
4687     while (isDIGIT(*pos))
4688         pos++;
4689     if (!isALPHA(*pos)) {
4690         I32 rev;
4691
4692         for (;;) {
4693             rev = 0;
4694             {
4695                 /* this is atoi() that delimits on underscores */
4696                 const char *end = pos;
4697                 I32 mult = 1;
4698                 I32 orev;
4699
4700                 /* the following if() will only be true after the decimal
4701                  * point of a version originally created with a bare
4702                  * floating point number, i.e. not quoted in any way
4703                  */
4704                 if ( !qv && s > start && saw_decimal == 1 ) {
4705                     mult *= 100;
4706                     while ( s < end ) {
4707                         orev = rev;
4708                         rev += (*s - '0') * mult;
4709                         mult /= 10;
4710                         if (   (PERL_ABS(orev) > PERL_ABS(rev))
4711                             || (PERL_ABS(rev) > VERSION_MAX )) {
4712                             Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4713                                            "Integer overflow in version %d",VERSION_MAX);
4714                             s = end - 1;
4715                             rev = VERSION_MAX;
4716                             vinf = 1;
4717                         }
4718                         s++;
4719                         if ( *s == '_' )
4720                             s++;
4721                     }
4722                 }
4723                 else {
4724                     while (--end >= s) {
4725                         orev = rev;
4726                         rev += (*end - '0') * mult;
4727                         mult *= 10;
4728                         if (   (PERL_ABS(orev) > PERL_ABS(rev))
4729                             || (PERL_ABS(rev) > VERSION_MAX )) {
4730                             Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4731                                            "Integer overflow in version");
4732                             end = s - 1;
4733                             rev = VERSION_MAX;
4734                             vinf = 1;
4735                         }
4736                     }
4737                 }
4738             }
4739
4740             /* Append revision */
4741             av_push(av, newSViv(rev));
4742             if ( vinf ) {
4743                 s = last;
4744                 break;
4745             }
4746             else if ( *pos == '.' )
4747                 s = ++pos;
4748             else if ( *pos == '_' && isDIGIT(pos[1]) )
4749                 s = ++pos;
4750             else if ( *pos == ',' && isDIGIT(pos[1]) )
4751                 s = ++pos;
4752             else if ( isDIGIT(*pos) )
4753                 s = pos;
4754             else {
4755                 s = pos;
4756                 break;
4757             }
4758             if ( qv ) {
4759                 while ( isDIGIT(*pos) )
4760                     pos++;
4761             }
4762             else {
4763                 int digits = 0;
4764                 while ( ( isDIGIT(*pos) || *pos == '_' ) && digits < 3 ) {
4765                     if ( *pos != '_' )
4766                         digits++;
4767                     pos++;
4768                 }
4769             }
4770         }
4771     }
4772     if ( qv ) { /* quoted versions always get at least three terms*/
4773         I32 len = av_len(av);
4774         /* This for loop appears to trigger a compiler bug on OS X, as it
4775            loops infinitely. Yes, len is negative. No, it makes no sense.
4776            Compiler in question is:
4777            gcc version 3.3 20030304 (Apple Computer, Inc. build 1640)
4778            for ( len = 2 - len; len > 0; len-- )
4779            av_push(MUTABLE_AV(sv), newSViv(0));
4780         */
4781         len = 2 - len;
4782         while (len-- > 0)
4783             av_push(av, newSViv(0));
4784     }
4785
4786     /* need to save off the current version string for later */
4787     if ( vinf ) {
4788         SV * orig = newSVpvn("v.Inf", sizeof("v.Inf")-1);
4789         (void)hv_stores(MUTABLE_HV(hv), "original", orig);
4790         (void)hv_stores(MUTABLE_HV(hv), "vinf", newSViv(1));
4791     }
4792     else if ( s > start ) {
4793         SV * orig = newSVpvn(start,s-start);
4794         if ( qv && saw_decimal == 1 && *start != 'v' ) {
4795             /* need to insert a v to be consistent */
4796             sv_insert(orig, 0, 0, "v", 1);
4797         }
4798         (void)hv_stores(MUTABLE_HV(hv), "original", orig);
4799     }
4800     else {
4801         (void)hv_stores(MUTABLE_HV(hv), "original", newSVpvs("0"));
4802         av_push(av, newSViv(0));
4803     }
4804
4805     /* And finally, store the AV in the hash */
4806     (void)hv_stores(MUTABLE_HV(hv), "version", newRV_noinc(MUTABLE_SV(av)));
4807
4808     /* fix RT#19517 - special case 'undef' as string */
4809     if ( *s == 'u' && strEQ(s,"undef") ) {
4810         s += 5;
4811     }
4812
4813     return s;
4814 }
4815
4816 /*
4817 =for apidoc new_version
4818
4819 Returns a new version object based on the passed in SV:
4820
4821     SV *sv = new_version(SV *ver);
4822
4823 Does not alter the passed in ver SV.  See "upg_version" if you
4824 want to upgrade the SV.
4825
4826 =cut
4827 */
4828
4829 SV *
4830 Perl_new_version(pTHX_ SV *ver)
4831 {
4832     dVAR;
4833     SV * const rv = newSV(0);
4834     PERL_ARGS_ASSERT_NEW_VERSION;
4835     if ( sv_derived_from(ver,"version") ) /* can just copy directly */
4836     {
4837         I32 key;
4838         AV * const av = newAV();
4839         AV *sav;
4840         /* This will get reblessed later if a derived class*/
4841         SV * const hv = newSVrv(rv, "version");
4842         (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
4843 #ifndef NODEFAULT_SHAREKEYS
4844         HvSHAREKEYS_on(hv);         /* key-sharing on by default */
4845 #endif
4846
4847         if ( SvROK(ver) )
4848             ver = SvRV(ver);
4849
4850         /* Begin copying all of the elements */
4851         if ( hv_exists(MUTABLE_HV(ver), "qv", 2) )
4852             (void)hv_stores(MUTABLE_HV(hv), "qv", newSViv(1));
4853
4854         if ( hv_exists(MUTABLE_HV(ver), "alpha", 5) )
4855             (void)hv_stores(MUTABLE_HV(hv), "alpha", newSViv(1));
4856
4857         if ( hv_exists(MUTABLE_HV(ver), "width", 5 ) )
4858         {
4859             const I32 width = SvIV(*hv_fetchs(MUTABLE_HV(ver), "width", FALSE));
4860             (void)hv_stores(MUTABLE_HV(hv), "width", newSViv(width));
4861         }
4862
4863         if ( hv_exists(MUTABLE_HV(ver), "original", 8 ) )
4864         {
4865             SV * pv = *hv_fetchs(MUTABLE_HV(ver), "original", FALSE);
4866             (void)hv_stores(MUTABLE_HV(hv), "original", newSVsv(pv));
4867         }
4868
4869         sav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(ver), "version", FALSE)));
4870         /* This will get reblessed later if a derived class*/
4871         for ( key = 0; key <= av_len(sav); key++ )
4872         {
4873             const I32 rev = SvIV(*av_fetch(sav, key, FALSE));
4874             av_push(av, newSViv(rev));
4875         }
4876
4877         (void)hv_stores(MUTABLE_HV(hv), "version", newRV_noinc(MUTABLE_SV(av)));
4878         return rv;
4879     }
4880 #ifdef SvVOK
4881     {
4882         const MAGIC* const mg = SvVSTRING_mg(ver);
4883         if ( mg ) { /* already a v-string */
4884             const STRLEN len = mg->mg_len;
4885             char * const version = savepvn( (const char*)mg->mg_ptr, len);
4886             sv_setpvn(rv,version,len);
4887             /* this is for consistency with the pure Perl class */
4888             if ( isDIGIT(*version) )
4889                 sv_insert(rv, 0, 0, "v", 1);
4890             Safefree(version);
4891         }
4892         else {
4893 #endif
4894         sv_setsv(rv,ver); /* make a duplicate */
4895 #ifdef SvVOK
4896         }
4897     }
4898 #endif
4899     return upg_version(rv, FALSE);
4900 }
4901
4902 /*
4903 =for apidoc upg_version
4904
4905 In-place upgrade of the supplied SV to a version object.
4906
4907     SV *sv = upg_version(SV *sv, bool qv);
4908
4909 Returns a pointer to the upgraded SV.  Set the boolean qv if you want
4910 to force this SV to be interpreted as an "extended" version.
4911
4912 =cut
4913 */
4914
4915 SV *
4916 Perl_upg_version(pTHX_ SV *ver, bool qv)
4917 {
4918     const char *version, *s;
4919 #ifdef SvVOK
4920     const MAGIC *mg;
4921 #endif
4922
4923     PERL_ARGS_ASSERT_UPG_VERSION;
4924
4925     if ( SvNOK(ver) && !( SvPOK(ver) && sv_len(ver) == 3 ) )
4926     {
4927         /* may get too much accuracy */
4928         char tbuf[64];
4929 #ifdef USE_LOCALE_NUMERIC
4930         char *loc = setlocale(LC_NUMERIC, "C");
4931 #endif
4932         STRLEN len = my_snprintf(tbuf, sizeof(tbuf), "%.9"NVff, SvNVX(ver));
4933 #ifdef USE_LOCALE_NUMERIC
4934         setlocale(LC_NUMERIC, loc);
4935 #endif
4936         while (tbuf[len-1] == '0' && len > 0) len--;
4937         if ( tbuf[len-1] == '.' ) len--; /* eat the trailing decimal */
4938         version = savepvn(tbuf, len);
4939     }
4940 #ifdef SvVOK
4941     else if ( (mg = SvVSTRING_mg(ver)) ) { /* already a v-string */
4942         version = savepvn( (const char*)mg->mg_ptr,mg->mg_len );
4943         qv = TRUE;
4944     }
4945 #endif
4946     else /* must be a string or something like a string */
4947     {
4948         STRLEN len;
4949         version = savepv(SvPV(ver,len));
4950 #ifndef SvVOK
4951 #  if PERL_VERSION > 5
4952         /* This will only be executed for 5.6.0 - 5.8.0 inclusive */
4953         if ( len >= 3 && !instr(version,".") && !instr(version,"_")
4954             && !(*version == 'u' && strEQ(version, "undef"))
4955             && (*version < '0' || *version > '9') ) {
4956             /* may be a v-string */
4957             SV * const nsv = sv_newmortal();
4958             const char *nver;
4959             const char *pos;
4960             int saw_decimal = 0;
4961             sv_setpvf(nsv,"v%vd",ver);
4962             pos = nver = savepv(SvPV_nolen(nsv));
4963
4964             /* scan the resulting formatted string */
4965             pos++; /* skip the leading 'v' */
4966             while ( *pos == '.' || isDIGIT(*pos) ) {
4967                 if ( *pos == '.' )
4968                     saw_decimal++ ;
4969                 pos++;
4970             }
4971
4972             /* is definitely a v-string */
4973             if ( saw_decimal >= 2 ) {
4974                 Safefree(version);
4975                 version = nver;
4976             }
4977         }
4978 #  endif
4979 #endif
4980     }
4981
4982     s = scan_version(version, ver, qv);
4983     if ( *s != '\0' )
4984         Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
4985                        "Version string '%s' contains invalid data; "
4986                        "ignoring: '%s'", version, s);
4987     Safefree(version);
4988     return ver;
4989 }
4990
4991 /*
4992 =for apidoc vverify
4993
4994 Validates that the SV contains a valid version object.
4995
4996     bool vverify(SV *vobj);
4997
4998 Note that it only confirms the bare minimum structure (so as not to get
4999 confused by derived classes which may contain additional hash entries):
5000
5001 =over 4
5002
5003 =item * The SV contains a [reference to a] hash
5004
5005 =item * The hash contains a "version" key
5006
5007 =item * The "version" key has [a reference to] an AV as its value
5008
5009 =back
5010
5011 =cut
5012 */
5013
5014 bool
5015 Perl_vverify(pTHX_ SV *vs)
5016 {
5017     SV *sv;
5018
5019     PERL_ARGS_ASSERT_VVERIFY;
5020
5021     if ( SvROK(vs) )
5022         vs = SvRV(vs);
5023
5024     /* see if the appropriate elements exist */
5025     if ( SvTYPE(vs) == SVt_PVHV
5026          && hv_exists(MUTABLE_HV(vs), "version", 7)
5027          && (sv = SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE)))
5028          && SvTYPE(sv) == SVt_PVAV )
5029         return TRUE;
5030     else
5031         return FALSE;
5032 }
5033
5034 /*
5035 =for apidoc vnumify
5036
5037 Accepts a version object and returns the normalized floating
5038 point representation.  Call like:
5039
5040     sv = vnumify(rv);
5041
5042 NOTE: you can pass either the object directly or the SV
5043 contained within the RV.
5044
5045 =cut
5046 */
5047
5048 SV *
5049 Perl_vnumify(pTHX_ SV *vs)
5050 {
5051     I32 i, len, digit;
5052     int width;
5053     bool alpha = FALSE;
5054     SV *sv;
5055     AV *av;
5056
5057     PERL_ARGS_ASSERT_VNUMIFY;
5058
5059     if ( SvROK(vs) )
5060         vs = SvRV(vs);
5061
5062     if ( !vverify(vs) )
5063         Perl_croak(aTHX_ "Invalid version object");
5064
5065     /* see if various flags exist */
5066     if ( hv_exists(MUTABLE_HV(vs), "alpha", 5 ) )
5067         alpha = TRUE;
5068     if ( hv_exists(MUTABLE_HV(vs), "width", 5 ) )
5069         width = SvIV(*hv_fetchs(MUTABLE_HV(vs), "width", FALSE));
5070     else
5071         width = 3;
5072
5073
5074     /* attempt to retrieve the version array */
5075     if ( !(av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE))) ) ) {
5076         return newSVpvs("0");
5077     }
5078
5079     len = av_len(av);
5080     if ( len == -1 )
5081     {
5082         return newSVpvs("0");
5083     }
5084
5085     digit = SvIV(*av_fetch(av, 0, 0));
5086     sv = Perl_newSVpvf(aTHX_ "%d.", (int)PERL_ABS(digit));
5087     for ( i = 1 ; i < len ; i++ )
5088     {
5089         digit = SvIV(*av_fetch(av, i, 0));
5090         if ( width < 3 ) {
5091             const int denom = (width == 2 ? 10 : 100);
5092             const div_t term = div((int)PERL_ABS(digit),denom);
5093             Perl_sv_catpvf(aTHX_ sv, "%0*d_%d", width, term.quot, term.rem);
5094         }
5095         else {
5096             Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit);
5097         }
5098     }
5099
5100     if ( len > 0 )
5101     {
5102         digit = SvIV(*av_fetch(av, len, 0));
5103         if ( alpha && width == 3 ) /* alpha version */
5104             sv_catpvs(sv,"_");
5105         Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit);
5106     }
5107     else /* len == 0 */
5108     {
5109         sv_catpvs(sv, "000");
5110     }
5111     return sv;
5112 }
5113
5114 /*
5115 =for apidoc vnormal
5116
5117 Accepts a version object and returns the normalized string
5118 representation.  Call like:
5119
5120     sv = vnormal(rv);
5121
5122 NOTE: you can pass either the object directly or the SV
5123 contained within the RV.
5124
5125 =cut
5126 */
5127
5128 SV *
5129 Perl_vnormal(pTHX_ SV *vs)
5130 {
5131     I32 i, len, digit;
5132     bool alpha = FALSE;
5133     SV *sv;
5134     AV *av;
5135
5136     PERL_ARGS_ASSERT_VNORMAL;
5137
5138     if ( SvROK(vs) )
5139         vs = SvRV(vs);
5140
5141     if ( !vverify(vs) )
5142         Perl_croak(aTHX_ "Invalid version object");
5143
5144     if ( hv_exists(MUTABLE_HV(vs), "alpha", 5 ) )
5145         alpha = TRUE;
5146     av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE)));
5147
5148     len = av_len(av);
5149     if ( len == -1 )
5150     {
5151         return newSVpvs("");
5152     }
5153     digit = SvIV(*av_fetch(av, 0, 0));
5154     sv = Perl_newSVpvf(aTHX_ "v%"IVdf, (IV)digit);
5155     for ( i = 1 ; i < len ; i++ ) {
5156         digit = SvIV(*av_fetch(av, i, 0));
5157         Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
5158     }
5159
5160     if ( len > 0 )
5161     {
5162         /* handle last digit specially */
5163         digit = SvIV(*av_fetch(av, len, 0));
5164         if ( alpha )
5165             Perl_sv_catpvf(aTHX_ sv, "_%"IVdf, (IV)digit);
5166         else
5167             Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
5168     }
5169
5170     if ( len <= 2 ) { /* short version, must be at least three */
5171         for ( len = 2 - len; len != 0; len-- )
5172             sv_catpvs(sv,".0");
5173     }
5174     return sv;
5175 }
5176
5177 /*
5178 =for apidoc vstringify
5179
5180 In order to maintain maximum compatibility with earlier versions
5181 of Perl, this function will return either the floating point
5182 notation or the multiple dotted notation, depending on whether
5183 the original version contained 1 or more dots, respectively
5184
5185 =cut
5186 */
5187
5188 SV *
5189 Perl_vstringify(pTHX_ SV *vs)
5190 {
5191     PERL_ARGS_ASSERT_VSTRINGIFY;
5192
5193     if ( SvROK(vs) )
5194         vs = SvRV(vs);
5195
5196     if ( !vverify(vs) )
5197         Perl_croak(aTHX_ "Invalid version object");
5198
5199     if (hv_exists(MUTABLE_HV(vs), "original",  sizeof("original") - 1)) {
5200         SV *pv;
5201         pv = *hv_fetchs(MUTABLE_HV(vs), "original", FALSE);
5202         if ( SvPOK(pv) )
5203             return newSVsv(pv);
5204         else
5205             return &PL_sv_undef;
5206     }
5207     else {
5208         if ( hv_exists(MUTABLE_HV(vs), "qv", 2) )
5209             return vnormal(vs);
5210         else
5211             return vnumify(vs);
5212     }
5213 }
5214
5215 /*
5216 =for apidoc vcmp
5217
5218 Version object aware cmp.  Both operands must already have been
5219 converted into version objects.
5220
5221 =cut
5222 */
5223
5224 int
5225 Perl_vcmp(pTHX_ SV *lhv, SV *rhv)
5226 {
5227     I32 i,l,m,r,retval;
5228     bool lalpha = FALSE;
5229     bool ralpha = FALSE;
5230     I32 left = 0;
5231     I32 right = 0;
5232     AV *lav, *rav;
5233
5234     PERL_ARGS_ASSERT_VCMP;
5235
5236     if ( SvROK(lhv) )
5237         lhv = SvRV(lhv);
5238     if ( SvROK(rhv) )
5239         rhv = SvRV(rhv);
5240
5241     if ( !vverify(lhv) )
5242         Perl_croak(aTHX_ "Invalid version object");
5243
5244     if ( !vverify(rhv) )
5245         Perl_croak(aTHX_ "Invalid version object");
5246
5247     /* get the left hand term */
5248     lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(lhv), "version", FALSE)));
5249     if ( hv_exists(MUTABLE_HV(lhv), "alpha", 5 ) )
5250         lalpha = TRUE;
5251
5252     /* and the right hand term */
5253     rav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(rhv), "version", FALSE)));
5254     if ( hv_exists(MUTABLE_HV(rhv), "alpha", 5 ) )
5255         ralpha = TRUE;
5256
5257     l = av_len(lav);
5258     r = av_len(rav);
5259     m = l < r ? l : r;
5260     retval = 0;
5261     i = 0;
5262     while ( i <= m && retval == 0 )
5263     {
5264         left  = SvIV(*av_fetch(lav,i,0));
5265         right = SvIV(*av_fetch(rav,i,0));
5266         if ( left < right  )
5267             retval = -1;
5268         if ( left > right )
5269             retval = +1;
5270         i++;
5271     }
5272
5273     /* tiebreaker for alpha with identical terms */
5274     if ( retval == 0 && l == r && left == right && ( lalpha || ralpha ) )
5275     {
5276         if ( lalpha && !ralpha )
5277         {
5278             retval = -1;
5279         }
5280         else if ( ralpha && !lalpha)
5281         {
5282             retval = +1;
5283         }
5284     }
5285
5286     if ( l != r && retval == 0 ) /* possible match except for trailing 0's */
5287     {
5288         if ( l < r )
5289         {
5290             while ( i <= r && retval == 0 )
5291             {
5292                 if ( SvIV(*av_fetch(rav,i,0)) != 0 )
5293                     retval = -1; /* not a match after all */
5294                 i++;
5295             }
5296         }
5297         else
5298         {
5299             while ( i <= l && retval == 0 )
5300             {
5301                 if ( SvIV(*av_fetch(lav,i,0)) != 0 )
5302                     retval = +1; /* not a match after all */
5303                 i++;
5304             }
5305         }
5306     }
5307     return retval;
5308 }
5309
5310 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET) && defined(SOCK_DGRAM) && defined(HAS_SELECT)
5311 #   define EMULATE_SOCKETPAIR_UDP
5312 #endif
5313
5314 #ifdef EMULATE_SOCKETPAIR_UDP
5315 static int
5316 S_socketpair_udp (int fd[2]) {
5317     dTHX;
5318     /* Fake a datagram socketpair using UDP to localhost.  */
5319     int sockets[2] = {-1, -1};
5320     struct sockaddr_in addresses[2];
5321     int i;
5322     Sock_size_t size = sizeof(struct sockaddr_in);
5323     unsigned short port;
5324     int got;
5325
5326     memset(&addresses, 0, sizeof(addresses));
5327     i = 1;
5328     do {
5329         sockets[i] = PerlSock_socket(AF_INET, SOCK_DGRAM, PF_INET);
5330         if (sockets[i] == -1)
5331             goto tidy_up_and_fail;
5332
5333         addresses[i].sin_family = AF_INET;
5334         addresses[i].sin_addr.s_addr = htonl(INADDR_LOOPBACK);
5335         addresses[i].sin_port = 0;      /* kernel choses port.  */
5336         if (PerlSock_bind(sockets[i], (struct sockaddr *) &addresses[i],
5337                 sizeof(struct sockaddr_in)) == -1)
5338             goto tidy_up_and_fail;
5339     } while (i--);
5340
5341     /* Now have 2 UDP sockets. Find out which port each is connected to, and
5342        for each connect the other socket to it.  */
5343     i = 1;
5344     do {
5345         if (PerlSock_getsockname(sockets[i], (struct sockaddr *) &addresses[i],
5346                 &size) == -1)
5347             goto tidy_up_and_fail;
5348         if (size != sizeof(struct sockaddr_in))
5349             goto abort_tidy_up_and_fail;
5350         /* !1 is 0, !0 is 1 */
5351         if (PerlSock_connect(sockets[!i], (struct sockaddr *) &addresses[i],
5352                 sizeof(struct sockaddr_in)) == -1)
5353             goto tidy_up_and_fail;
5354     } while (i--);
5355
5356     /* Now we have 2 sockets connected to each other. I don't trust some other
5357        process not to have already sent a packet to us (by random) so send
5358        a packet from each to the other.  */
5359     i = 1;
5360     do {
5361         /* I'm going to send my own port number.  As a short.
5362            (Who knows if someone somewhere has sin_port as a bitfield and needs
5363            this routine. (I'm assuming crays have socketpair)) */
5364         port = addresses[i].sin_port;
5365         got = PerlLIO_write(sockets[i], &port, sizeof(port));
5366         if (got != sizeof(port)) {
5367             if (got == -1)
5368                 goto tidy_up_and_fail;
5369             goto abort_tidy_up_and_fail;
5370         }
5371     } while (i--);
5372
5373     /* Packets sent. I don't trust them to have arrived though.
5374        (As I understand it Solaris TCP stack is multithreaded. Non-blocking
5375        connect to localhost will use a second kernel thread. In 2.6 the
5376        first thread running the connect() returns before the second completes,
5377        so EINPROGRESS> In 2.7 the improved stack is faster and connect()
5378        returns 0. Poor programs have tripped up. One poor program's authors'
5379        had a 50-1 reverse stock split. Not sure how connected these were.)
5380        So I don't trust someone not to have an unpredictable UDP stack.
5381     */
5382
5383     {
5384         struct timeval waitfor = {0, 100000}; /* You have 0.1 seconds */
5385         int max = sockets[1] > sockets[0] ? sockets[1] : sockets[0];
5386         fd_set rset;
5387
5388         FD_ZERO(&rset);
5389         FD_SET((unsigned int)sockets[0], &rset);
5390         FD_SET((unsigned int)sockets[1], &rset);
5391
5392         got = PerlSock_select(max + 1, &rset, NULL, NULL, &waitfor);
5393         if (got != 2 || !FD_ISSET(sockets[0], &rset)
5394                 || !FD_ISSET(sockets[1], &rset)) {
5395             /* I hope this is portable and appropriate.  */
5396             if (got == -1)
5397                 goto tidy_up_and_fail;
5398             goto abort_tidy_up_and_fail;
5399         }
5400     }
5401
5402     /* And the paranoia department even now doesn't trust it to have arrive
5403        (hence MSG_DONTWAIT). Or that what arrives was sent by us.  */
5404     {
5405         struct sockaddr_in readfrom;
5406         unsigned short buffer[2];
5407
5408         i = 1;
5409         do {
5410 #ifdef MSG_DONTWAIT
5411             got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
5412                     sizeof(buffer), MSG_DONTWAIT,
5413                     (struct sockaddr *) &readfrom, &size);
5414 #else
5415             got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
5416                     sizeof(buffer), 0,
5417                     (struct sockaddr *) &readfrom, &size);
5418 #endif
5419
5420             if (got == -1)
5421                 goto tidy_up_and_fail;
5422             if (got != sizeof(port)
5423                     || size != sizeof(struct sockaddr_in)
5424                     /* Check other socket sent us its port.  */
5425                     || buffer[0] != (unsigned short) addresses[!i].sin_port
5426                     /* Check kernel says we got the datagram from that socket */
5427                     || readfrom.sin_family != addresses[!i].sin_family
5428                     || readfrom.sin_addr.s_addr != addresses[!i].sin_addr.s_addr
5429                     || readfrom.sin_port != addresses[!i].sin_port)
5430                 goto abort_tidy_up_and_fail;
5431         } while (i--);
5432     }
5433     /* My caller (my_socketpair) has validated that this is non-NULL  */
5434     fd[0] = sockets[0];
5435     fd[1] = sockets[1];
5436     /* I hereby declare this connection open.  May God bless all who cross
5437        her.  */
5438     return 0;
5439
5440   abort_tidy_up_and_fail:
5441     errno = ECONNABORTED;
5442   tidy_up_and_fail:
5443     {
5444         dSAVE_ERRNO;
5445         if (sockets[0] != -1)
5446             PerlLIO_close(sockets[0]);
5447         if (sockets[1] != -1)
5448             PerlLIO_close(sockets[1]);
5449         RESTORE_ERRNO;
5450         return -1;
5451     }
5452 }
5453 #endif /*  EMULATE_SOCKETPAIR_UDP */
5454
5455 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET)
5456 int
5457 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
5458     /* Stevens says that family must be AF_LOCAL, protocol 0.
5459        I'm going to enforce that, then ignore it, and use TCP (or UDP).  */
5460     dTHX;
5461     int listener = -1;
5462     int connector = -1;
5463     int acceptor = -1;
5464     struct sockaddr_in listen_addr;
5465     struct sockaddr_in connect_addr;
5466     Sock_size_t size;
5467
5468     if (protocol
5469 #ifdef AF_UNIX
5470         || family != AF_UNIX
5471 #endif
5472     ) {
5473         errno = EAFNOSUPPORT;
5474         return -1;
5475     }
5476     if (!fd) {
5477         errno = EINVAL;
5478         return -1;
5479     }
5480
5481 #ifdef EMULATE_SOCKETPAIR_UDP
5482     if (type == SOCK_DGRAM)
5483         return S_socketpair_udp(fd);
5484 #endif
5485
5486     listener = PerlSock_socket(AF_INET, type, 0);
5487     if (listener == -1)
5488         return -1;
5489     memset(&listen_addr, 0, sizeof(listen_addr));
5490     listen_addr.sin_family = AF_INET;
5491     listen_addr.sin_addr.s_addr = htonl(INADDR_LOOPBACK);
5492     listen_addr.sin_port = 0;   /* kernel choses port.  */
5493     if (PerlSock_bind(listener, (struct sockaddr *) &listen_addr,
5494             sizeof(listen_addr)) == -1)
5495         goto tidy_up_and_fail;
5496     if (PerlSock_listen(listener, 1) == -1)
5497         goto tidy_up_and_fail;
5498
5499     connector = PerlSock_socket(AF_INET, type, 0);
5500     if (connector == -1)
5501         goto tidy_up_and_fail;
5502     /* We want to find out the port number to connect to.  */
5503     size = sizeof(connect_addr);
5504     if (PerlSock_getsockname(listener, (struct sockaddr *) &connect_addr,
5505             &size) == -1)
5506         goto tidy_up_and_fail;
5507     if (size != sizeof(connect_addr))
5508         goto abort_tidy_up_and_fail;
5509     if (PerlSock_connect(connector, (struct sockaddr *) &connect_addr,
5510             sizeof(connect_addr)) == -1)
5511         goto tidy_up_and_fail;
5512
5513     size = sizeof(listen_addr);
5514     acceptor = PerlSock_accept(listener, (struct sockaddr *) &listen_addr,
5515             &size);
5516     if (acceptor == -1)
5517         goto tidy_up_and_fail;
5518     if (size != sizeof(listen_addr))
5519         goto abort_tidy_up_and_fail;
5520     PerlLIO_close(listener);
5521     /* Now check we are talking to ourself by matching port and host on the
5522        two sockets.  */
5523     if (PerlSock_getsockname(connector, (struct sockaddr *) &connect_addr,
5524             &size) == -1)
5525         goto tidy_up_and_fail;
5526     if (size != sizeof(connect_addr)
5527             || listen_addr.sin_family != connect_addr.sin_family
5528             || listen_addr.sin_addr.s_addr != connect_addr.sin_addr.s_addr
5529             || listen_addr.sin_port != connect_addr.sin_port) {
5530         goto abort_tidy_up_and_fail;
5531     }
5532     fd[0] = connector;
5533     fd[1] = acceptor;
5534     return 0;
5535
5536   abort_tidy_up_and_fail:
5537 #ifdef ECONNABORTED
5538   errno = ECONNABORTED; /* This would be the standard thing to do. */
5539 #else
5540 #  ifdef ECONNREFUSED
5541   errno = ECONNREFUSED; /* E.g. Symbian does not have ECONNABORTED. */
5542 #  else
5543   errno = ETIMEDOUT;    /* Desperation time. */
5544 #  endif
5545 #endif
5546   tidy_up_and_fail:
5547     {
5548         dSAVE_ERRNO;
5549         if (listener != -1)
5550             PerlLIO_close(listener);
5551         if (connector != -1)
5552             PerlLIO_close(connector);
5553         if (acceptor != -1)
5554             PerlLIO_close(acceptor);
5555         RESTORE_ERRNO;
5556         return -1;
5557     }
5558 }
5559 #else
5560 /* In any case have a stub so that there's code corresponding
5561  * to the my_socketpair in global.sym. */
5562 int
5563 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
5564 #ifdef HAS_SOCKETPAIR
5565     return socketpair(family, type, protocol, fd);
5566 #else
5567     return -1;
5568 #endif
5569 }
5570 #endif
5571
5572 /*
5573
5574 =for apidoc sv_nosharing
5575
5576 Dummy routine which "shares" an SV when there is no sharing module present.
5577 Or "locks" it. Or "unlocks" it. In other words, ignores its single SV argument.
5578 Exists to avoid test for a NULL function pointer and because it could
5579 potentially warn under some level of strict-ness.
5580
5581 =cut
5582 */
5583
5584 void
5585 Perl_sv_nosharing(pTHX_ SV *sv)
5586 {
5587     PERL_UNUSED_CONTEXT;
5588     PERL_UNUSED_ARG(sv);
5589 }
5590
5591 /*
5592
5593 =for apidoc sv_destroyable
5594
5595 Dummy routine which reports that object can be destroyed when there is no
5596 sharing module present.  It ignores its single SV argument, and returns
5597 'true'.  Exists to avoid test for a NULL function pointer and because it
5598 could potentially warn under some level of strict-ness.
5599
5600 =cut
5601 */
5602
5603 bool
5604 Perl_sv_destroyable(pTHX_ SV *sv)
5605 {
5606     PERL_UNUSED_CONTEXT;
5607     PERL_UNUSED_ARG(sv);
5608     return TRUE;
5609 }
5610
5611 U32
5612 Perl_parse_unicode_opts(pTHX_ const char **popt)
5613 {
5614   const char *p = *popt;
5615   U32 opt = 0;
5616
5617   PERL_ARGS_ASSERT_PARSE_UNICODE_OPTS;
5618
5619   if (*p) {
5620        if (isDIGIT(*p)) {
5621             opt = (U32) atoi(p);
5622             while (isDIGIT(*p))
5623                 p++;
5624             if (*p && *p != '\n' && *p != '\r')
5625                  Perl_croak(aTHX_ "Unknown Unicode option letter '%c'", *p);
5626        }
5627        else {
5628             for (; *p; p++) {
5629                  switch (*p) {
5630                  case PERL_UNICODE_STDIN:
5631                       opt |= PERL_UNICODE_STDIN_FLAG;   break;
5632                  case PERL_UNICODE_STDOUT:
5633                       opt |= PERL_UNICODE_STDOUT_FLAG;  break;
5634                  case PERL_UNICODE_STDERR:
5635                       opt |= PERL_UNICODE_STDERR_FLAG;  break;
5636                  case PERL_UNICODE_STD:
5637                       opt |= PERL_UNICODE_STD_FLAG;     break;
5638                  case PERL_UNICODE_IN:
5639                       opt |= PERL_UNICODE_IN_FLAG;      break;
5640                  case PERL_UNICODE_OUT:
5641                       opt |= PERL_UNICODE_OUT_FLAG;     break;
5642                  case PERL_UNICODE_INOUT:
5643                       opt |= PERL_UNICODE_INOUT_FLAG;   break;
5644                  case PERL_UNICODE_LOCALE:
5645                       opt |= PERL_UNICODE_LOCALE_FLAG;  break;
5646                  case PERL_UNICODE_ARGV:
5647                       opt |= PERL_UNICODE_ARGV_FLAG;    break;
5648                  case PERL_UNICODE_UTF8CACHEASSERT:
5649                       opt |= PERL_UNICODE_UTF8CACHEASSERT_FLAG; break;
5650                  default:
5651                       if (*p != '\n' && *p != '\r')
5652                           Perl_croak(aTHX_
5653                                      "Unknown Unicode option letter '%c'", *p);
5654                  }
5655             }
5656        }
5657   }
5658   else
5659        opt = PERL_UNICODE_DEFAULT_FLAGS;
5660
5661   if (opt & ~PERL_UNICODE_ALL_FLAGS)
5662        Perl_croak(aTHX_ "Unknown Unicode option value %"UVuf,
5663                   (UV) (opt & ~PERL_UNICODE_ALL_FLAGS));
5664
5665   *popt = p;
5666
5667   return opt;
5668 }
5669
5670 U32
5671 Perl_seed(pTHX)
5672 {
5673     dVAR;
5674     /*
5675      * This is really just a quick hack which grabs various garbage
5676      * values.  It really should be a real hash algorithm which
5677      * spreads the effect of every input bit onto every output bit,
5678      * if someone who knows about such things would bother to write it.
5679      * Might be a good idea to add that function to CORE as well.
5680      * No numbers below come from careful analysis or anything here,
5681      * except they are primes and SEED_C1 > 1E6 to get a full-width
5682      * value from (tv_sec * SEED_C1 + tv_usec).  The multipliers should
5683      * probably be bigger too.
5684      */
5685 #if RANDBITS > 16
5686 #  define SEED_C1       1000003
5687 #define   SEED_C4       73819
5688 #else
5689 #  define SEED_C1       25747
5690 #define   SEED_C4       20639
5691 #endif
5692 #define   SEED_C2       3
5693 #define   SEED_C3       269
5694 #define   SEED_C5       26107
5695
5696 #ifndef PERL_NO_DEV_RANDOM
5697     int fd;
5698 #endif
5699     U32 u;
5700 #ifdef VMS
5701 #  include <starlet.h>
5702     /* when[] = (low 32 bits, high 32 bits) of time since epoch
5703      * in 100-ns units, typically incremented ever 10 ms.        */
5704     unsigned int when[2];
5705 #else
5706 #  ifdef HAS_GETTIMEOFDAY
5707     struct timeval when;
5708 #  else
5709     Time_t when;
5710 #  endif
5711 #endif
5712
5713 /* This test is an escape hatch, this symbol isn't set by Configure. */
5714 #ifndef PERL_NO_DEV_RANDOM
5715 #ifndef PERL_RANDOM_DEVICE
5716    /* /dev/random isn't used by default because reads from it will block
5717     * if there isn't enough entropy available.  You can compile with
5718     * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
5719     * is enough real entropy to fill the seed. */
5720 #  define PERL_RANDOM_DEVICE "/dev/urandom"
5721 #endif
5722     fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
5723     if (fd != -1) {
5724         if (PerlLIO_read(fd, (void*)&u, sizeof u) != sizeof u)
5725             u = 0;
5726         PerlLIO_close(fd);
5727         if (u)
5728             return u;
5729     }
5730 #endif
5731
5732 #ifdef VMS
5733     _ckvmssts(sys$gettim(when));
5734     u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
5735 #else
5736 #  ifdef HAS_GETTIMEOFDAY
5737     PerlProc_gettimeofday(&when,NULL);
5738     u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
5739 #  else
5740     (void)time(&when);
5741     u = (U32)SEED_C1 * when;
5742 #  endif
5743 #endif
5744     u += SEED_C3 * (U32)PerlProc_getpid();
5745     u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
5746 #ifndef PLAN9           /* XXX Plan9 assembler chokes on this; fix needed  */
5747     u += SEED_C5 * (U32)PTR2UV(&when);
5748 #endif
5749     return u;
5750 }
5751
5752 UV
5753 Perl_get_hash_seed(pTHX)
5754 {
5755     dVAR;
5756      const char *s = PerlEnv_getenv("PERL_HASH_SEED");
5757      UV myseed = 0;
5758
5759      if (s)
5760         while (isSPACE(*s))
5761             s++;
5762      if (s && isDIGIT(*s))
5763           myseed = (UV)Atoul(s);
5764      else
5765 #ifdef USE_HASH_SEED_EXPLICIT
5766      if (s)
5767 #endif
5768      {
5769           /* Compute a random seed */
5770           (void)seedDrand01((Rand_seed_t)seed());
5771           myseed = (UV)(Drand01() * (NV)UV_MAX);
5772 #if RANDBITS < (UVSIZE * 8)
5773           /* Since there are not enough randbits to to reach all
5774            * the bits of a UV, the low bits might need extra
5775            * help.  Sum in another random number that will
5776            * fill in the low bits. */
5777           myseed +=
5778                (UV)(Drand01() * (NV)((((UV)1) << ((UVSIZE * 8 - RANDBITS))) - 1));
5779 #endif /* RANDBITS < (UVSIZE * 8) */
5780           if (myseed == 0) { /* Superparanoia. */
5781               myseed = (UV)(Drand01() * (NV)UV_MAX); /* One more chance. */
5782               if (myseed == 0)
5783                   Perl_croak(aTHX_ "Your random numbers are not that random");
5784           }
5785      }
5786      PL_rehash_seed_set = TRUE;
5787
5788      return myseed;
5789 }
5790
5791 #ifdef USE_ITHREADS
5792 bool
5793 Perl_stashpv_hvname_match(pTHX_ const COP *c, const HV *hv)
5794 {
5795     const char * const stashpv = CopSTASHPV(c);
5796     const char * const name = HvNAME_get(hv);
5797     PERL_UNUSED_CONTEXT;
5798     PERL_ARGS_ASSERT_STASHPV_HVNAME_MATCH;
5799
5800     if (stashpv == name)
5801         return TRUE;
5802     if (stashpv && name)
5803         if (strEQ(stashpv, name))
5804             return TRUE;
5805     return FALSE;
5806 }
5807 #endif
5808
5809
5810 #ifdef PERL_GLOBAL_STRUCT
5811
5812 #define PERL_GLOBAL_STRUCT_INIT
5813 #include "opcode.h" /* the ppaddr and check */
5814
5815 struct perl_vars *
5816 Perl_init_global_struct(pTHX)
5817 {
5818     struct perl_vars *plvarsp = NULL;
5819 # ifdef PERL_GLOBAL_STRUCT
5820     const IV nppaddr = sizeof(Gppaddr)/sizeof(Perl_ppaddr_t);
5821     const IV ncheck  = sizeof(Gcheck) /sizeof(Perl_check_t);
5822 #  ifdef PERL_GLOBAL_STRUCT_PRIVATE
5823     /* PerlMem_malloc() because can't use even safesysmalloc() this early. */
5824     plvarsp = (struct perl_vars*)PerlMem_malloc(sizeof(struct perl_vars));
5825     if (!plvarsp)
5826         exit(1);
5827 #  else
5828     plvarsp = PL_VarsPtr;
5829 #  endif /* PERL_GLOBAL_STRUCT_PRIVATE */
5830 #  undef PERLVAR
5831 #  undef PERLVARA
5832 #  undef PERLVARI
5833 #  undef PERLVARIC
5834 #  undef PERLVARISC
5835 #  define PERLVAR(var,type) /**/
5836 #  define PERLVARA(var,n,type) /**/
5837 #  define PERLVARI(var,type,init) plvarsp->var = init;
5838 #  define PERLVARIC(var,type,init) plvarsp->var = init;
5839 #  define PERLVARISC(var,init) Copy(init, plvarsp->var, sizeof(init), char);
5840 #  include "perlvars.h"
5841 #  undef PERLVAR
5842 #  undef PERLVARA
5843 #  undef PERLVARI
5844 #  undef PERLVARIC
5845 #  undef PERLVARISC
5846 #  ifdef PERL_GLOBAL_STRUCT
5847     plvarsp->Gppaddr =
5848         (Perl_ppaddr_t*)
5849         PerlMem_malloc(nppaddr * sizeof(Perl_ppaddr_t));
5850     if (!plvarsp->Gppaddr)
5851         exit(1);
5852     plvarsp->Gcheck  =
5853         (Perl_check_t*)
5854         PerlMem_malloc(ncheck  * sizeof(Perl_check_t));
5855     if (!plvarsp->Gcheck)
5856         exit(1);
5857     Copy(Gppaddr, plvarsp->Gppaddr, nppaddr, Perl_ppaddr_t);
5858     Copy(Gcheck,  plvarsp->Gcheck,  ncheck,  Perl_check_t);
5859 #  endif
5860 #  ifdef PERL_SET_VARS
5861     PERL_SET_VARS(plvarsp);
5862 #  endif
5863 # undef PERL_GLOBAL_STRUCT_INIT
5864 # endif
5865     return plvarsp;
5866 }
5867
5868 #endif /* PERL_GLOBAL_STRUCT */
5869
5870 #ifdef PERL_GLOBAL_STRUCT
5871
5872 void
5873 Perl_free_global_struct(pTHX_ struct perl_vars *plvarsp)
5874 {
5875     PERL_ARGS_ASSERT_FREE_GLOBAL_STRUCT;
5876 # ifdef PERL_GLOBAL_STRUCT
5877 #  ifdef PERL_UNSET_VARS
5878     PERL_UNSET_VARS(plvarsp);
5879 #  endif
5880     free(plvarsp->Gppaddr);
5881     free(plvarsp->Gcheck);
5882 #  ifdef PERL_GLOBAL_STRUCT_PRIVATE
5883     free(plvarsp);
5884 #  endif
5885 # endif
5886 }
5887
5888 #endif /* PERL_GLOBAL_STRUCT */
5889
5890 #ifdef PERL_MEM_LOG
5891
5892 /* -DPERL_MEM_LOG: the Perl_mem_log_..() is compiled, including the
5893  * the default implementation, unless -DPERL_MEM_LOG_NOIMPL is also
5894  * given, and you supply your own implementation.
5895  *
5896  * The default implementation reads a single env var, PERL_MEM_LOG,
5897  * expecting one or more of the following:
5898  *
5899  *    \d+ - fd          fd to write to          : must be 1st (atoi)
5900  *    'm' - memlog      was PERL_MEM_LOG=1
5901  *    's' - svlog       was PERL_SV_LOG=1
5902  *    't' - timestamp   was PERL_MEM_LOG_TIMESTAMP=1
5903  *
5904  * This makes the logger controllable enough that it can reasonably be
5905  * added to the system perl.
5906  */
5907
5908 /* -DPERL_MEM_LOG_SPRINTF_BUF_SIZE=X: size of a (stack-allocated) buffer
5909  * the Perl_mem_log_...() will use (either via sprintf or snprintf).
5910  */
5911 #define PERL_MEM_LOG_SPRINTF_BUF_SIZE 128
5912
5913 /* -DPERL_MEM_LOG_FD=N: the file descriptor the Perl_mem_log_...()
5914  * writes to.  In the default logger, this is settable at runtime.
5915  */
5916 #ifndef PERL_MEM_LOG_FD
5917 #  define PERL_MEM_LOG_FD 2 /* If STDERR is too boring for you. */
5918 #endif
5919
5920 #ifndef PERL_MEM_LOG_NOIMPL
5921
5922 # ifdef DEBUG_LEAKING_SCALARS
5923 #   define SV_LOG_SERIAL_FMT        " [%lu]"
5924 #   define _SV_LOG_SERIAL_ARG(sv)   , (unsigned long) (sv)->sv_debug_serial
5925 # else
5926 #   define SV_LOG_SERIAL_FMT
5927 #   define _SV_LOG_SERIAL_ARG(sv)
5928 # endif
5929
5930 static void
5931 S_mem_log_common(enum mem_log_type mlt, const UV n,
5932                  const UV typesize, const char *type_name, const SV *sv,
5933                  Malloc_t oldalloc, Malloc_t newalloc,
5934                  const char *filename, const int linenumber,
5935                  const char *funcname)
5936 {
5937     const char *pmlenv;
5938
5939     PERL_ARGS_ASSERT_MEM_LOG_COMMON;
5940
5941     pmlenv = PerlEnv_getenv("PERL_MEM_LOG");
5942     if (!pmlenv)
5943         return;
5944     if (mlt < MLT_NEW_SV ? strchr(pmlenv,'m') : strchr(pmlenv,'s'))
5945     {
5946         /* We can't use SVs or PerlIO for obvious reasons,
5947          * so we'll use stdio and low-level IO instead. */
5948         char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE];
5949
5950 #   ifdef HAS_GETTIMEOFDAY
5951 #     define MEM_LOG_TIME_FMT   "%10d.%06d: "
5952 #     define MEM_LOG_TIME_ARG   (int)tv.tv_sec, (int)tv.tv_usec
5953         struct timeval tv;
5954         gettimeofday(&tv, 0);
5955 #   else
5956 #     define MEM_LOG_TIME_FMT   "%10d: "
5957 #     define MEM_LOG_TIME_ARG   (int)when
5958         Time_t when;
5959         (void)time(&when);
5960 #   endif
5961         /* If there are other OS specific ways of hires time than
5962          * gettimeofday() (see ext/Time-HiRes), the easiest way is
5963          * probably that they would be used to fill in the struct
5964          * timeval. */
5965         {
5966             STRLEN len;
5967             int fd = atoi(pmlenv);
5968             if (!fd)
5969                 fd = PERL_MEM_LOG_FD;
5970
5971             if (strchr(pmlenv, 't')) {
5972                 len = my_snprintf(buf, sizeof(buf),
5973                                 MEM_LOG_TIME_FMT, MEM_LOG_TIME_ARG);
5974                 PerlLIO_write(fd, buf, len);
5975             }
5976             switch (mlt) {
5977             case MLT_ALLOC:
5978                 len = my_snprintf(buf, sizeof(buf),
5979                         "alloc: %s:%d:%s: %"IVdf" %"UVuf
5980                         " %s = %"IVdf": %"UVxf"\n",
5981                         filename, linenumber, funcname, n, typesize,
5982                         type_name, n * typesize, PTR2UV(newalloc));
5983                 break;
5984             case MLT_REALLOC:
5985                 len = my_snprintf(buf, sizeof(buf),
5986                         "realloc: %s:%d:%s: %"IVdf" %"UVuf
5987                         " %s = %"IVdf": %"UVxf" -> %"UVxf"\n",
5988                         filename, linenumber, funcname, n, typesize,
5989                         type_name, n * typesize, PTR2UV(oldalloc),
5990                         PTR2UV(newalloc));
5991                 break;
5992             case MLT_FREE:
5993                 len = my_snprintf(buf, sizeof(buf),
5994                         "free: %s:%d:%s: %"UVxf"\n",
5995                         filename, linenumber, funcname,
5996                         PTR2UV(oldalloc));
5997                 break;
5998             case MLT_NEW_SV:
5999             case MLT_DEL_SV:
6000                 len = my_snprintf(buf, sizeof(buf),
6001                         "%s_SV: %s:%d:%s: %"UVxf SV_LOG_SERIAL_FMT "\n",
6002                         mlt == MLT_NEW_SV ? "new" : "del",
6003                         filename, linenumber, funcname,
6004                         PTR2UV(sv) _SV_LOG_SERIAL_ARG(sv));
6005                 break;
6006             default:
6007                 len = 0;
6008             }
6009             PerlLIO_write(fd, buf, len);
6010         }
6011     }
6012 }
6013 #endif /* !PERL_MEM_LOG_NOIMPL */
6014
6015 #ifndef PERL_MEM_LOG_NOIMPL
6016 # define \
6017     mem_log_common_if(alty, num, tysz, tynm, sv, oal, nal, flnm, ln, fnnm) \
6018     mem_log_common   (alty, num, tysz, tynm, sv, oal, nal, flnm, ln, fnnm)
6019 #else
6020 /* this is suboptimal, but bug compatible.  User is providing their
6021    own implemenation, but is getting these functions anyway, and they
6022    do nothing. But _NOIMPL users should be able to cope or fix */
6023 # define \
6024     mem_log_common_if(alty, num, tysz, tynm, u, oal, nal, flnm, ln, fnnm) \
6025     /* mem_log_common_if_PERL_MEM_LOG_NOIMPL */
6026 #endif
6027
6028 Malloc_t
6029 Perl_mem_log_alloc(const UV n, const UV typesize, const char *type_name,
6030                    Malloc_t newalloc,
6031                    const char *filename, const int linenumber,
6032                    const char *funcname)
6033 {
6034     mem_log_common_if(MLT_ALLOC, n, typesize, type_name,
6035                       NULL, NULL, newalloc,
6036                       filename, linenumber, funcname);
6037     return newalloc;
6038 }
6039
6040 Malloc_t
6041 Perl_mem_log_realloc(const UV n, const UV typesize, const char *type_name,
6042                      Malloc_t oldalloc, Malloc_t newalloc,
6043                      const char *filename, const int linenumber,
6044                      const char *funcname)
6045 {
6046     mem_log_common_if(MLT_REALLOC, n, typesize, type_name,
6047                       NULL, oldalloc, newalloc,
6048                       filename, linenumber, funcname);
6049     return newalloc;
6050 }
6051
6052 Malloc_t
6053 Perl_mem_log_free(Malloc_t oldalloc,
6054                   const char *filename, const int linenumber,
6055                   const char *funcname)
6056 {
6057     mem_log_common_if(MLT_FREE, 0, 0, "", NULL, oldalloc, NULL,
6058                       filename, linenumber, funcname);
6059     return oldalloc;
6060 }
6061
6062 void
6063 Perl_mem_log_new_sv(const SV *sv,
6064                     const char *filename, const int linenumber,
6065                     const char *funcname)
6066 {
6067     mem_log_common_if(MLT_NEW_SV, 0, 0, "", sv, NULL, NULL,
6068                       filename, linenumber, funcname);
6069 }
6070
6071 void
6072 Perl_mem_log_del_sv(const SV *sv,
6073                     const char *filename, const int linenumber,
6074                     const char *funcname)
6075 {
6076     mem_log_common_if(MLT_DEL_SV, 0, 0, "", sv, NULL, NULL,
6077                       filename, linenumber, funcname);
6078 }
6079
6080 #endif /* PERL_MEM_LOG */
6081
6082 /*
6083 =for apidoc my_sprintf
6084
6085 The C library C<sprintf>, wrapped if necessary, to ensure that it will return
6086 the length of the string written to the buffer. Only rare pre-ANSI systems
6087 need the wrapper function - usually this is a direct call to C<sprintf>.
6088
6089 =cut
6090 */
6091 #ifndef SPRINTF_RETURNS_STRLEN
6092 int
6093 Perl_my_sprintf(char *buffer, const char* pat, ...)
6094 {
6095     va_list args;
6096     PERL_ARGS_ASSERT_MY_SPRINTF;
6097     va_start(args, pat);
6098     vsprintf(buffer, pat, args);
6099     va_end(args);
6100     return strlen(buffer);
6101 }
6102 #endif
6103
6104 /*
6105 =for apidoc my_snprintf
6106
6107 The C library C<snprintf> functionality, if available and
6108 standards-compliant (uses C<vsnprintf>, actually).  However, if the
6109 C<vsnprintf> is not available, will unfortunately use the unsafe
6110 C<vsprintf> which can overrun the buffer (there is an overrun check,
6111 but that may be too late).  Consider using C<sv_vcatpvf> instead, or
6112 getting C<vsnprintf>.
6113
6114 =cut
6115 */
6116 int
6117 Perl_my_snprintf(char *buffer, const Size_t len, const char *format, ...)
6118 {
6119     dTHX;
6120     int retval;
6121     va_list ap;
6122     PERL_ARGS_ASSERT_MY_SNPRINTF;
6123     va_start(ap, format);
6124 #ifdef HAS_VSNPRINTF
6125     retval = vsnprintf(buffer, len, format, ap);
6126 #else
6127     retval = vsprintf(buffer, format, ap);
6128 #endif
6129     va_end(ap);
6130     /* vsnprintf() shows failure with >= len, vsprintf() with < 0 */
6131     if (retval < 0 || (len > 0 && (Size_t)retval >= len))
6132         Perl_croak(aTHX_ "panic: my_snprintf buffer overflow");
6133     return retval;
6134 }
6135
6136 /*
6137 =for apidoc my_vsnprintf
6138
6139 The C library C<vsnprintf> if available and standards-compliant.
6140 However, if if the C<vsnprintf> is not available, will unfortunately
6141 use the unsafe C<vsprintf> which can overrun the buffer (there is an
6142 overrun check, but that may be too late).  Consider using
6143 C<sv_vcatpvf> instead, or getting C<vsnprintf>.
6144
6145 =cut
6146 */
6147 int
6148 Perl_my_vsnprintf(char *buffer, const Size_t len, const char *format, va_list ap)
6149 {
6150     dTHX;
6151     int retval;
6152 #ifdef NEED_VA_COPY
6153     va_list apc;
6154
6155     PERL_ARGS_ASSERT_MY_VSNPRINTF;
6156
6157     Perl_va_copy(ap, apc);
6158 # ifdef HAS_VSNPRINTF
6159     retval = vsnprintf(buffer, len, format, apc);
6160 # else
6161     retval = vsprintf(buffer, format, apc);
6162 # endif
6163 #else
6164 # ifdef HAS_VSNPRINTF
6165     retval = vsnprintf(buffer, len, format, ap);
6166 # else
6167     retval = vsprintf(buffer, format, ap);
6168 # endif
6169 #endif /* #ifdef NEED_VA_COPY */
6170     /* vsnprintf() shows failure with >= len, vsprintf() with < 0 */
6171     if (retval < 0 || (len > 0 && (Size_t)retval >= len))
6172         Perl_croak(aTHX_ "panic: my_vsnprintf buffer overflow");
6173     return retval;
6174 }
6175
6176 void
6177 Perl_my_clearenv(pTHX)
6178 {
6179     dVAR;
6180 #if ! defined(PERL_MICRO)
6181 #  if defined(PERL_IMPLICIT_SYS) || defined(WIN32)
6182     PerlEnv_clearenv();
6183 #  else /* ! (PERL_IMPLICIT_SYS || WIN32) */
6184 #    if defined(USE_ENVIRON_ARRAY)
6185 #      if defined(USE_ITHREADS)
6186     /* only the parent thread can clobber the process environment */
6187     if (PL_curinterp == aTHX)
6188 #      endif /* USE_ITHREADS */
6189     {
6190 #      if ! defined(PERL_USE_SAFE_PUTENV)
6191     if ( !PL_use_safe_putenv) {
6192       I32 i;
6193       if (environ == PL_origenviron)
6194         environ = (char**)safesysmalloc(sizeof(char*));
6195       else
6196         for (i = 0; environ[i]; i++)
6197           (void)safesysfree(environ[i]);
6198     }
6199     environ[0] = NULL;
6200 #      else /* PERL_USE_SAFE_PUTENV */
6201 #        if defined(HAS_CLEARENV)
6202     (void)clearenv();
6203 #        elif defined(HAS_UNSETENV)
6204     int bsiz = 80; /* Most envvar names will be shorter than this. */
6205     int bufsiz = bsiz * sizeof(char); /* sizeof(char) paranoid? */
6206     char *buf = (char*)safesysmalloc(bufsiz);
6207     while (*environ != NULL) {
6208       char *e = strchr(*environ, '=');
6209       int l = e ? e - *environ : (int)strlen(*environ);
6210       if (bsiz < l + 1) {
6211         (void)safesysfree(buf);
6212         bsiz = l + 1; /* + 1 for the \0. */
6213         buf = (char*)safesysmalloc(bufsiz);
6214       }
6215       memcpy(buf, *environ, l);
6216       buf[l] = '\0';
6217       (void)unsetenv(buf);
6218     }
6219     (void)safesysfree(buf);
6220 #        else /* ! HAS_CLEARENV && ! HAS_UNSETENV */
6221     /* Just null environ and accept the leakage. */
6222     *environ = NULL;
6223 #        endif /* HAS_CLEARENV || HAS_UNSETENV */
6224 #      endif /* ! PERL_USE_SAFE_PUTENV */
6225     }
6226 #    endif /* USE_ENVIRON_ARRAY */
6227 #  endif /* PERL_IMPLICIT_SYS || WIN32 */
6228 #endif /* PERL_MICRO */
6229 }
6230
6231 #ifdef PERL_IMPLICIT_CONTEXT
6232
6233 /* Implements the MY_CXT_INIT macro. The first time a module is loaded,
6234 the global PL_my_cxt_index is incremented, and that value is assigned to
6235 that module's static my_cxt_index (who's address is passed as an arg).
6236 Then, for each interpreter this function is called for, it makes sure a
6237 void* slot is available to hang the static data off, by allocating or
6238 extending the interpreter's PL_my_cxt_list array */
6239
6240 #ifndef PERL_GLOBAL_STRUCT_PRIVATE
6241 void *
6242 Perl_my_cxt_init(pTHX_ int *index, size_t size)
6243 {
6244     dVAR;
6245     void *p;
6246     PERL_ARGS_ASSERT_MY_CXT_INIT;
6247     if (*index == -1) {
6248         /* this module hasn't been allocated an index yet */
6249 #if defined(USE_ITHREADS)
6250         MUTEX_LOCK(&PL_my_ctx_mutex);
6251 #endif
6252         *index = PL_my_cxt_index++;
6253 #if defined(USE_ITHREADS)
6254         MUTEX_UNLOCK(&PL_my_ctx_mutex);
6255 #endif
6256     }
6257
6258     /* make sure the array is big enough */
6259     if (PL_my_cxt_size <= *index) {
6260         if (PL_my_cxt_size) {
6261             while (PL_my_cxt_size <= *index)
6262                 PL_my_cxt_size *= 2;
6263             Renew(PL_my_cxt_list, PL_my_cxt_size, void *);
6264         }
6265         else {
6266             PL_my_cxt_size = 16;
6267             Newx(PL_my_cxt_list, PL_my_cxt_size, void *);
6268         }
6269     }
6270     /* newSV() allocates one more than needed */
6271     p = (void*)SvPVX(newSV(size-1));
6272     PL_my_cxt_list[*index] = p;
6273     Zero(p, size, char);
6274     return p;
6275 }
6276
6277 #else /* #ifndef PERL_GLOBAL_STRUCT_PRIVATE */
6278
6279 int
6280 Perl_my_cxt_index(pTHX_ const char *my_cxt_key)
6281 {
6282     dVAR;
6283     int index;
6284
6285     PERL_ARGS_ASSERT_MY_CXT_INDEX;
6286
6287     for (index = 0; index < PL_my_cxt_index; index++) {
6288         const char *key = PL_my_cxt_keys[index];
6289         /* try direct pointer compare first - there are chances to success,
6290          * and it's much faster.
6291          */
6292         if ((key == my_cxt_key) || strEQ(key, my_cxt_key))
6293             return index;
6294     }
6295     return -1;
6296 }
6297
6298 void *
6299 Perl_my_cxt_init(pTHX_ const char *my_cxt_key, size_t size)
6300 {
6301     dVAR;
6302     void *p;
6303     int index;
6304
6305     PERL_ARGS_ASSERT_MY_CXT_INIT;
6306
6307     index = Perl_my_cxt_index(aTHX_ my_cxt_key);
6308     if (index == -1) {
6309         /* this module hasn't been allocated an index yet */
6310 #if defined(USE_ITHREADS)
6311         MUTEX_LOCK(&PL_my_ctx_mutex);
6312 #endif
6313         index = PL_my_cxt_index++;
6314 #if defined(USE_ITHREADS)
6315         MUTEX_UNLOCK(&PL_my_ctx_mutex);
6316 #endif
6317     }
6318
6319     /* make sure the array is big enough */
6320     if (PL_my_cxt_size <= index) {
6321         int old_size = PL_my_cxt_size;
6322         int i;
6323         if (PL_my_cxt_size) {
6324             while (PL_my_cxt_size <= index)
6325                 PL_my_cxt_size *= 2;
6326             Renew(PL_my_cxt_list, PL_my_cxt_size, void *);
6327             Renew(PL_my_cxt_keys, PL_my_cxt_size, const char *);
6328         }
6329         else {
6330             PL_my_cxt_size = 16;
6331             Newx(PL_my_cxt_list, PL_my_cxt_size, void *);
6332             Newx(PL_my_cxt_keys, PL_my_cxt_size, const char *);
6333         }
6334         for (i = old_size; i < PL_my_cxt_size; i++) {
6335             PL_my_cxt_keys[i] = 0;
6336             PL_my_cxt_list[i] = 0;
6337         }
6338     }
6339     PL_my_cxt_keys[index] = my_cxt_key;
6340     /* newSV() allocates one more than needed */
6341     p = (void*)SvPVX(newSV(size-1));
6342     PL_my_cxt_list[index] = p;
6343     Zero(p, size, char);
6344     return p;
6345 }
6346 #endif /* #ifndef PERL_GLOBAL_STRUCT_PRIVATE */
6347 #endif /* PERL_IMPLICIT_CONTEXT */
6348
6349 #ifndef HAS_STRLCAT
6350 Size_t
6351 Perl_my_strlcat(char *dst, const char *src, Size_t size)
6352 {
6353     Size_t used, length, copy;
6354
6355     used = strlen(dst);
6356     length = strlen(src);
6357     if (size > 0 && used < size - 1) {
6358         copy = (length >= size - used) ? size - used - 1 : length;
6359         memcpy(dst + used, src, copy);
6360         dst[used + copy] = '\0';
6361     }
6362     return used + length;
6363 }
6364 #endif
6365
6366 #ifndef HAS_STRLCPY
6367 Size_t
6368 Perl_my_strlcpy(char *dst, const char *src, Size_t size)
6369 {
6370     Size_t length, copy;
6371
6372     length = strlen(src);
6373     if (size > 0) {
6374         copy = (length >= size) ? size - 1 : length;
6375         memcpy(dst, src, copy);
6376         dst[copy] = '\0';
6377     }
6378     return length;
6379 }
6380 #endif
6381
6382 #if defined(_MSC_VER) && (_MSC_VER >= 1300) && (_MSC_VER < 1400) && (WINVER < 0x0500)
6383 /* VC7 or 7.1, building with pre-VC7 runtime libraries. */
6384 long _ftol( double ); /* Defined by VC6 C libs. */
6385 long _ftol2( double dblSource ) { return _ftol( dblSource ); }
6386 #endif
6387
6388 void
6389 Perl_get_db_sub(pTHX_ SV **svp, CV *cv)
6390 {
6391     dVAR;
6392     SV * const dbsv = GvSVn(PL_DBsub);
6393     /* We do not care about using sv to call CV;
6394      * it's for informational purposes only.
6395      */
6396
6397     PERL_ARGS_ASSERT_GET_DB_SUB;
6398
6399     save_item(dbsv);
6400     if (!PERLDB_SUB_NN) {
6401         GV * const gv = CvGV(cv);
6402
6403         if ( svp && ((CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
6404              || strEQ(GvNAME(gv), "END")
6405              || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
6406                  !( (SvTYPE(*svp) == SVt_PVGV)
6407                     && (GvCV((const GV *)*svp) == cv) )))) {
6408             /* Use GV from the stack as a fallback. */
6409             /* GV is potentially non-unique, or contain different CV. */
6410             SV * const tmp = newRV(MUTABLE_SV(cv));
6411             sv_setsv(dbsv, tmp);
6412             SvREFCNT_dec(tmp);
6413         }
6414         else {
6415             gv_efullname3(dbsv, gv, NULL);
6416         }
6417     }
6418     else {
6419         const int type = SvTYPE(dbsv);
6420         if (type < SVt_PVIV && type != SVt_IV)
6421             sv_upgrade(dbsv, SVt_PVIV);
6422         (void)SvIOK_on(dbsv);
6423         SvIV_set(dbsv, PTR2IV(cv));     /* Do it the quickest way  */
6424     }
6425 }
6426
6427 int
6428 Perl_my_dirfd(pTHX_ DIR * dir) {
6429
6430     /* Most dirfd implementations have problems when passed NULL. */
6431     if(!dir)
6432         return -1;
6433 #ifdef HAS_DIRFD
6434     return dirfd(dir);
6435 #elif defined(HAS_DIR_DD_FD)
6436     return dir->dd_fd;
6437 #else
6438     Perl_die(aTHX_ PL_no_func, "dirfd");
6439    /* NOT REACHED */
6440     return 0;
6441 #endif
6442 }
6443
6444 REGEXP *
6445 Perl_get_re_arg(pTHX_ SV *sv) {
6446
6447     if (sv) {
6448         if (SvMAGICAL(sv))
6449             mg_get(sv);
6450         if (SvROK(sv))
6451             sv = MUTABLE_SV(SvRV(sv));
6452         if (SvTYPE(sv) == SVt_REGEXP)
6453             return (REGEXP*) sv;
6454     }
6455
6456     return NULL;
6457 }
6458
6459 /*
6460  * Local variables:
6461  * c-indentation-style: bsd
6462  * c-basic-offset: 4
6463  * indent-tabs-mode: t
6464  * End:
6465  *
6466  * ex: set ts=8 sts=4 sw=4 noet:
6467  */