util.c

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