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