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