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