util.c

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