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 #  ifdef OS2    /* Same, without fork()ing and all extra overhead... */
2271     return my_syspopen4(aTHX_ Nullch, mode, n, args);
2272 #  else
2273     Perl_croak(aTHX_ "List form of piped open not implemented");
2274     return (PerlIO *) NULL;
2275 #  endif
2276 #endif
2277 }
2278
2279     /* VMS' my_popen() is in VMS.c, same with OS/2. */
2280 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL)
2281 PerlIO *
2282 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2283 {
2284     dVAR;
2285     int p[2];
2286     register I32 This, that;
2287     register Pid_t pid;
2288     SV *sv;
2289     const I32 doexec = !(*cmd == '-' && cmd[1] == '\0');
2290     I32 did_pipes = 0;
2291     int pp[2];
2292
2293     PERL_FLUSHALL_FOR_CHILD;
2294 #ifdef OS2
2295     if (doexec) {
2296         return my_syspopen(aTHX_ cmd,mode);
2297     }
2298 #endif
2299     This = (*mode == 'w');
2300     that = !This;
2301     if (doexec && PL_tainting) {
2302         taint_env();
2303         taint_proper("Insecure %s%s", "EXEC");
2304     }
2305     if (PerlProc_pipe(p) < 0)
2306         return NULL;
2307     if (doexec && PerlProc_pipe(pp) >= 0)
2308         did_pipes = 1;
2309     while ((pid = PerlProc_fork()) < 0) {
2310         if (errno != EAGAIN) {
2311             PerlLIO_close(p[This]);
2312             PerlLIO_close(p[that]);
2313             if (did_pipes) {
2314                 PerlLIO_close(pp[0]);
2315                 PerlLIO_close(pp[1]);
2316             }
2317             if (!doexec)
2318                 Perl_croak(aTHX_ "Can't fork");
2319             return NULL;
2320         }
2321         sleep(5);
2322     }
2323     if (pid == 0) {
2324         GV* tmpgv;
2325
2326 #undef THIS
2327 #undef THAT
2328 #define THIS that
2329 #define THAT This
2330         if (did_pipes) {
2331             PerlLIO_close(pp[0]);
2332 #if defined(HAS_FCNTL) && defined(F_SETFD)
2333             fcntl(pp[1], F_SETFD, FD_CLOEXEC);
2334 #endif
2335         }
2336         if (p[THIS] != (*mode == 'r')) {
2337             PerlLIO_dup2(p[THIS], *mode == 'r');
2338             PerlLIO_close(p[THIS]);
2339             if (p[THAT] != (*mode == 'r'))      /* if dup2() didn't close it */
2340                 PerlLIO_close(p[THAT]);
2341         }
2342         else
2343             PerlLIO_close(p[THAT]);
2344 #ifndef OS2
2345         if (doexec) {
2346 #if !defined(HAS_FCNTL) || !defined(F_SETFD)
2347 #ifndef NOFILE
2348 #define NOFILE 20
2349 #endif
2350             {
2351                 int fd;
2352
2353                 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++)
2354                     if (fd != pp[1])
2355                         PerlLIO_close(fd);
2356             }
2357 #endif
2358             /* may or may not use the shell */
2359             do_exec3(cmd, pp[1], did_pipes);
2360             PerlProc__exit(1);
2361         }
2362 #endif  /* defined OS2 */
2363
2364 #ifdef PERLIO_USING_CRLF
2365    /* Since we circumvent IO layers when we manipulate low-level
2366       filedescriptors directly, need to manually switch to the
2367       default, binary, low-level mode; see PerlIOBuf_open(). */
2368    PerlLIO_setmode((*mode == 'r'), O_BINARY);
2369 #endif
2370
2371         if ((tmpgv = gv_fetchpvs("$", GV_ADD|GV_NOTQUAL, SVt_PV))) {
2372             SvREADONLY_off(GvSV(tmpgv));
2373             sv_setiv(GvSV(tmpgv), PerlProc_getpid());
2374             SvREADONLY_on(GvSV(tmpgv));
2375         }
2376 #ifdef THREADS_HAVE_PIDS
2377         PL_ppid = (IV)getppid();
2378 #endif
2379         PL_forkprocess = 0;
2380 #ifdef PERL_USES_PL_PIDSTATUS
2381         hv_clear(PL_pidstatus); /* we have no children */
2382 #endif
2383         return NULL;
2384 #undef THIS
2385 #undef THAT
2386     }
2387     do_execfree();      /* free any memory malloced by child on vfork */
2388     if (did_pipes)
2389         PerlLIO_close(pp[1]);
2390     if (p[that] < p[This]) {
2391         PerlLIO_dup2(p[This], p[that]);
2392         PerlLIO_close(p[This]);
2393         p[This] = p[that];
2394     }
2395     else
2396         PerlLIO_close(p[that]);
2397
2398     LOCK_FDPID_MUTEX;
2399     sv = *av_fetch(PL_fdpid,p[This],TRUE);
2400     UNLOCK_FDPID_MUTEX;
2401     SvUPGRADE(sv,SVt_IV);
2402     SvIV_set(sv, pid);
2403     PL_forkprocess = pid;
2404     if (did_pipes && pid > 0) {
2405         int errkid;
2406         unsigned n = 0;
2407         SSize_t n1;
2408
2409         while (n < sizeof(int)) {
2410             n1 = PerlLIO_read(pp[0],
2411                               (void*)(((char*)&errkid)+n),
2412                               (sizeof(int)) - n);
2413             if (n1 <= 0)
2414                 break;
2415             n += n1;
2416         }
2417         PerlLIO_close(pp[0]);
2418         did_pipes = 0;
2419         if (n) {                        /* Error */
2420             int pid2, status;
2421             PerlLIO_close(p[This]);
2422             if (n != sizeof(int))
2423                 Perl_croak(aTHX_ "panic: kid popen errno read");
2424             do {
2425                 pid2 = wait4pid(pid, &status, 0);
2426             } while (pid2 == -1 && errno == EINTR);
2427             errno = errkid;             /* Propagate errno from kid */
2428             return NULL;
2429         }
2430     }
2431     if (did_pipes)
2432          PerlLIO_close(pp[0]);
2433     return PerlIO_fdopen(p[This], mode);
2434 }
2435 #else
2436 #if defined(atarist) || defined(EPOC)
2437 FILE *popen();
2438 PerlIO *
2439 Perl_my_popen((pTHX_ const char *cmd, const char *mode)
2440 {
2441     PERL_FLUSHALL_FOR_CHILD;
2442     /* Call system's popen() to get a FILE *, then import it.
2443        used 0 for 2nd parameter to PerlIO_importFILE;
2444        apparently not used
2445     */
2446     return PerlIO_importFILE(popen(cmd, mode), 0);
2447 }
2448 #else
2449 #if defined(DJGPP)
2450 FILE *djgpp_popen();
2451 PerlIO *
2452 Perl_my_popen((pTHX_ const char *cmd, const char *mode)
2453 {
2454     PERL_FLUSHALL_FOR_CHILD;
2455     /* Call system's popen() to get a FILE *, then import it.
2456        used 0 for 2nd parameter to PerlIO_importFILE;
2457        apparently not used
2458     */
2459     return PerlIO_importFILE(djgpp_popen(cmd, mode), 0);
2460 }
2461 #endif
2462 #endif
2463
2464 #endif /* !DOSISH */
2465
2466 /* this is called in parent before the fork() */
2467 void
2468 Perl_atfork_lock(void)
2469 {
2470    dVAR;
2471 #if defined(USE_ITHREADS)
2472     /* locks must be held in locking order (if any) */
2473 #  ifdef MYMALLOC
2474     MUTEX_LOCK(&PL_malloc_mutex);
2475 #  endif
2476     OP_REFCNT_LOCK;
2477 #endif
2478 }
2479
2480 /* this is called in both parent and child after the fork() */
2481 void
2482 Perl_atfork_unlock(void)
2483 {
2484     dVAR;
2485 #if defined(USE_ITHREADS)
2486     /* locks must be released in same order as in atfork_lock() */
2487 #  ifdef MYMALLOC
2488     MUTEX_UNLOCK(&PL_malloc_mutex);
2489 #  endif
2490     OP_REFCNT_UNLOCK;
2491 #endif
2492 }
2493
2494 Pid_t
2495 Perl_my_fork(void)
2496 {
2497 #if defined(HAS_FORK)
2498     Pid_t pid;
2499 #if defined(USE_ITHREADS) && !defined(HAS_PTHREAD_ATFORK)
2500     atfork_lock();
2501     pid = fork();
2502     atfork_unlock();
2503 #else
2504     /* atfork_lock() and atfork_unlock() are installed as pthread_atfork()
2505      * handlers elsewhere in the code */
2506     pid = fork();
2507 #endif
2508     return pid;
2509 #else
2510     /* this "canna happen" since nothing should be calling here if !HAS_FORK */
2511     Perl_croak_nocontext("fork() not available");
2512     return 0;
2513 #endif /* HAS_FORK */
2514 }
2515
2516 #ifdef DUMP_FDS
2517 void
2518 Perl_dump_fds(pTHX_ char *s)
2519 {
2520     int fd;
2521     Stat_t tmpstatbuf;
2522
2523     PerlIO_printf(Perl_debug_log,"%s", s);
2524     for (fd = 0; fd < 32; fd++) {
2525         if (PerlLIO_fstat(fd,&tmpstatbuf) >= 0)
2526             PerlIO_printf(Perl_debug_log," %d",fd);
2527     }
2528     PerlIO_printf(Perl_debug_log,"\n");
2529     return;
2530 }
2531 #endif  /* DUMP_FDS */
2532
2533 #ifndef HAS_DUP2
2534 int
2535 dup2(int oldfd, int newfd)
2536 {
2537 #if defined(HAS_FCNTL) && defined(F_DUPFD)
2538     if (oldfd == newfd)
2539         return oldfd;
2540     PerlLIO_close(newfd);
2541     return fcntl(oldfd, F_DUPFD, newfd);
2542 #else
2543 #define DUP2_MAX_FDS 256
2544     int fdtmp[DUP2_MAX_FDS];
2545     I32 fdx = 0;
2546     int fd;
2547
2548     if (oldfd == newfd)
2549         return oldfd;
2550     PerlLIO_close(newfd);
2551     /* good enough for low fd's... */
2552     while ((fd = PerlLIO_dup(oldfd)) != newfd && fd >= 0) {
2553         if (fdx >= DUP2_MAX_FDS) {
2554             PerlLIO_close(fd);
2555             fd = -1;
2556             break;
2557         }
2558         fdtmp[fdx++] = fd;
2559     }
2560     while (fdx > 0)
2561         PerlLIO_close(fdtmp[--fdx]);
2562     return fd;
2563 #endif
2564 }
2565 #endif
2566
2567 #ifndef PERL_MICRO
2568 #ifdef HAS_SIGACTION
2569
2570 #ifdef MACOS_TRADITIONAL
2571 /* We don't want restart behavior on MacOS */
2572 #undef SA_RESTART
2573 #endif
2574
2575 Sighandler_t
2576 Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
2577 {
2578     dVAR;
2579     struct sigaction act, oact;
2580
2581 #ifdef USE_ITHREADS
2582     /* only "parent" interpreter can diddle signals */
2583     if (PL_curinterp != aTHX)
2584         return (Sighandler_t) SIG_ERR;
2585 #endif
2586
2587     act.sa_handler = (void(*)(int))handler;
2588     sigemptyset(&act.sa_mask);
2589     act.sa_flags = 0;
2590 #ifdef SA_RESTART
2591     if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2592         act.sa_flags |= SA_RESTART;     /* SVR4, 4.3+BSD */
2593 #endif
2594 #if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
2595     if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
2596         act.sa_flags |= SA_NOCLDWAIT;
2597 #endif
2598     if (sigaction(signo, &act, &oact) == -1)
2599         return (Sighandler_t) SIG_ERR;
2600     else
2601         return (Sighandler_t) oact.sa_handler;
2602 }
2603
2604 Sighandler_t
2605 Perl_rsignal_state(pTHX_ int signo)
2606 {
2607     struct sigaction oact;
2608     PERL_UNUSED_CONTEXT;
2609
2610     if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1)
2611         return (Sighandler_t) SIG_ERR;
2612     else
2613         return (Sighandler_t) oact.sa_handler;
2614 }
2615
2616 int
2617 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
2618 {
2619     dVAR;
2620     struct sigaction act;
2621
2622 #ifdef USE_ITHREADS
2623     /* only "parent" interpreter can diddle signals */
2624     if (PL_curinterp != aTHX)
2625         return -1;
2626 #endif
2627
2628     act.sa_handler = (void(*)(int))handler;
2629     sigemptyset(&act.sa_mask);
2630     act.sa_flags = 0;
2631 #ifdef SA_RESTART
2632     if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2633         act.sa_flags |= SA_RESTART;     /* SVR4, 4.3+BSD */
2634 #endif
2635 #if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
2636     if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
2637         act.sa_flags |= SA_NOCLDWAIT;
2638 #endif
2639     return sigaction(signo, &act, save);
2640 }
2641
2642 int
2643 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
2644 {
2645     dVAR;
2646 #ifdef USE_ITHREADS
2647     /* only "parent" interpreter can diddle signals */
2648     if (PL_curinterp != aTHX)
2649         return -1;
2650 #endif
2651
2652     return sigaction(signo, save, (struct sigaction *)NULL);
2653 }
2654
2655 #else /* !HAS_SIGACTION */
2656
2657 Sighandler_t
2658 Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
2659 {
2660 #if defined(USE_ITHREADS) && !defined(WIN32)
2661     /* only "parent" interpreter can diddle signals */
2662     if (PL_curinterp != aTHX)
2663         return (Sighandler_t) SIG_ERR;
2664 #endif
2665
2666     return PerlProc_signal(signo, handler);
2667 }
2668
2669 static Signal_t
2670 sig_trap(int signo)
2671 {
2672     dVAR;
2673     PL_sig_trapped++;
2674 }
2675
2676 Sighandler_t
2677 Perl_rsignal_state(pTHX_ int signo)
2678 {
2679     dVAR;
2680     Sighandler_t oldsig;
2681
2682 #if defined(USE_ITHREADS) && !defined(WIN32)
2683     /* only "parent" interpreter can diddle signals */
2684     if (PL_curinterp != aTHX)
2685         return (Sighandler_t) SIG_ERR;
2686 #endif
2687
2688     PL_sig_trapped = 0;
2689     oldsig = PerlProc_signal(signo, sig_trap);
2690     PerlProc_signal(signo, oldsig);
2691     if (PL_sig_trapped)
2692         PerlProc_kill(PerlProc_getpid(), signo);
2693     return oldsig;
2694 }
2695
2696 int
2697 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
2698 {
2699 #if defined(USE_ITHREADS) && !defined(WIN32)
2700     /* only "parent" interpreter can diddle signals */
2701     if (PL_curinterp != aTHX)
2702         return -1;
2703 #endif
2704     *save = PerlProc_signal(signo, handler);
2705     return (*save == (Sighandler_t) SIG_ERR) ? -1 : 0;
2706 }
2707
2708 int
2709 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
2710 {
2711 #if defined(USE_ITHREADS) && !defined(WIN32)
2712     /* only "parent" interpreter can diddle signals */
2713     if (PL_curinterp != aTHX)
2714         return -1;
2715 #endif
2716     return (PerlProc_signal(signo, *save) == (Sighandler_t) SIG_ERR) ? -1 : 0;
2717 }
2718
2719 #endif /* !HAS_SIGACTION */
2720 #endif /* !PERL_MICRO */
2721
2722     /* VMS' my_pclose() is in VMS.c; same with OS/2 */
2723 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL)
2724 I32
2725 Perl_my_pclose(pTHX_ PerlIO *ptr)
2726 {
2727     dVAR;
2728     Sigsave_t hstat, istat, qstat;
2729     int status;
2730     SV **svp;
2731     Pid_t pid;
2732     Pid_t pid2;
2733     bool close_failed;
2734     int saved_errno = 0;
2735 #ifdef WIN32
2736     int saved_win32_errno;
2737 #endif
2738
2739     LOCK_FDPID_MUTEX;
2740     svp = av_fetch(PL_fdpid,PerlIO_fileno(ptr),TRUE);
2741     UNLOCK_FDPID_MUTEX;
2742     pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1;
2743     SvREFCNT_dec(*svp);
2744     *svp = &PL_sv_undef;
2745 #ifdef OS2
2746     if (pid == -1) {                    /* Opened by popen. */
2747         return my_syspclose(ptr);
2748     }
2749 #endif
2750     if ((close_failed = (PerlIO_close(ptr) == EOF))) {
2751         saved_errno = errno;
2752 #ifdef WIN32
2753         saved_win32_errno = GetLastError();
2754 #endif
2755     }
2756 #ifdef UTS
2757     if(PerlProc_kill(pid, 0) < 0) { return(pid); }   /* HOM 12/23/91 */
2758 #endif
2759 #ifndef PERL_MICRO
2760     rsignal_save(SIGHUP,  (Sighandler_t) SIG_IGN, &hstat);
2761     rsignal_save(SIGINT,  (Sighandler_t) SIG_IGN, &istat);
2762     rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qstat);
2763 #endif
2764     do {
2765         pid2 = wait4pid(pid, &status, 0);
2766     } while (pid2 == -1 && errno == EINTR);
2767 #ifndef PERL_MICRO
2768     rsignal_restore(SIGHUP, &hstat);
2769     rsignal_restore(SIGINT, &istat);
2770     rsignal_restore(SIGQUIT, &qstat);
2771 #endif
2772     if (close_failed) {
2773         SETERRNO(saved_errno, 0);
2774         return -1;
2775     }
2776     return(pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status));
2777 }
2778 #endif /* !DOSISH */
2779
2780 #if  (!defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(NETWARE)) && !defined(MACOS_TRADITIONAL)
2781 I32
2782 Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
2783 {
2784     dVAR;
2785     I32 result = 0;
2786     if (!pid)
2787         return -1;
2788 #ifdef PERL_USES_PL_PIDSTATUS
2789     {
2790         if (pid > 0) {
2791             /* The keys in PL_pidstatus are now the raw 4 (or 8) bytes of the
2792                pid, rather than a string form.  */
2793             SV * const * const svp = hv_fetch(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),FALSE);
2794             if (svp && *svp != &PL_sv_undef) {
2795                 *statusp = SvIVX(*svp);
2796                 (void)hv_delete(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),
2797                                 G_DISCARD);
2798                 return pid;
2799             }
2800         }
2801         else {
2802             HE *entry;
2803
2804             hv_iterinit(PL_pidstatus);
2805             if ((entry = hv_iternext(PL_pidstatus))) {
2806                 SV * const sv = hv_iterval(PL_pidstatus,entry);
2807                 I32 len;
2808                 const char * const spid = hv_iterkey(entry,&len);
2809
2810                 assert (len == sizeof(Pid_t));
2811                 memcpy((char *)&pid, spid, len);
2812                 *statusp = SvIVX(sv);
2813                 /* The hash iterator is currently on this entry, so simply
2814                    calling hv_delete would trigger the lazy delete, which on
2815                    aggregate does more work, beacuse next call to hv_iterinit()
2816                    would spot the flag, and have to call the delete routine,
2817                    while in the meantime any new entries can't re-use that
2818                    memory.  */
2819                 hv_iterinit(PL_pidstatus);
2820                 (void)hv_delete(PL_pidstatus,spid,len,G_DISCARD);
2821                 return pid;
2822             }
2823         }
2824     }
2825 #endif
2826 #ifdef HAS_WAITPID
2827 #  ifdef HAS_WAITPID_RUNTIME
2828     if (!HAS_WAITPID_RUNTIME)
2829         goto hard_way;
2830 #  endif
2831     result = PerlProc_waitpid(pid,statusp,flags);
2832     goto finish;
2833 #endif
2834 #if !defined(HAS_WAITPID) && defined(HAS_WAIT4)
2835     result = wait4((pid==-1)?0:pid,statusp,flags,NULL);
2836     goto finish;
2837 #endif
2838 #ifdef PERL_USES_PL_PIDSTATUS
2839 #if defined(HAS_WAITPID) && defined(HAS_WAITPID_RUNTIME)
2840   hard_way:
2841 #endif
2842     {
2843         if (flags)
2844             Perl_croak(aTHX_ "Can't do waitpid with flags");
2845         else {
2846             while ((result = PerlProc_wait(statusp)) != pid && pid > 0 && result >= 0)
2847                 pidgone(result,*statusp);
2848             if (result < 0)
2849                 *statusp = -1;
2850         }
2851     }
2852 #endif
2853 #if defined(HAS_WAITPID) || defined(HAS_WAIT4)
2854   finish:
2855 #endif
2856     if (result < 0 && errno == EINTR) {
2857         PERL_ASYNC_CHECK();
2858     }
2859     return result;
2860 }
2861 #endif /* !DOSISH || OS2 || WIN32 || NETWARE */
2862
2863 #ifdef PERL_USES_PL_PIDSTATUS
2864 void
2865 Perl_pidgone(pTHX_ Pid_t pid, int status)
2866 {
2867     register SV *sv;
2868
2869     sv = *hv_fetch(PL_pidstatus,(const char*)&pid,sizeof(Pid_t),TRUE);
2870     SvUPGRADE(sv,SVt_IV);
2871     SvIV_set(sv, status);
2872     return;
2873 }
2874 #endif
2875
2876 #if defined(atarist) || defined(OS2) || defined(EPOC)
2877 int pclose();
2878 #ifdef HAS_FORK
2879 int                                     /* Cannot prototype with I32
2880                                            in os2ish.h. */
2881 my_syspclose(PerlIO *ptr)
2882 #else
2883 I32
2884 Perl_my_pclose(pTHX_ PerlIO *ptr)
2885 #endif
2886 {
2887     /* Needs work for PerlIO ! */
2888     FILE * const f = PerlIO_findFILE(ptr);
2889     const I32 result = pclose(f);
2890     PerlIO_releaseFILE(ptr,f);
2891     return result;
2892 }
2893 #endif
2894
2895 #if defined(DJGPP)
2896 int djgpp_pclose();
2897 I32
2898 Perl_my_pclose(pTHX_ PerlIO *ptr)
2899 {
2900     /* Needs work for PerlIO ! */
2901     FILE * const f = PerlIO_findFILE(ptr);
2902     I32 result = djgpp_pclose(f);
2903     result = (result << 8) & 0xff00;
2904     PerlIO_releaseFILE(ptr,f);
2905     return result;
2906 }
2907 #endif
2908
2909 void
2910 Perl_repeatcpy(pTHX_ register char *to, register const char *from, I32 len, register I32 count)
2911 {
2912     register I32 todo;
2913     register const char * const frombase = from;
2914     PERL_UNUSED_CONTEXT;
2915
2916     if (len == 1) {
2917         register const char c = *from;
2918         while (count-- > 0)
2919             *to++ = c;
2920         return;
2921     }
2922     while (count-- > 0) {
2923         for (todo = len; todo > 0; todo--) {
2924             *to++ = *from++;
2925         }
2926         from = frombase;
2927     }
2928 }
2929
2930 #ifndef HAS_RENAME
2931 I32
2932 Perl_same_dirent(pTHX_ const char *a, const char *b)
2933 {
2934     char *fa = strrchr(a,'/');
2935     char *fb = strrchr(b,'/');
2936     Stat_t tmpstatbuf1;
2937     Stat_t tmpstatbuf2;
2938     SV * const tmpsv = sv_newmortal();
2939
2940     if (fa)
2941         fa++;
2942     else
2943         fa = a;
2944     if (fb)
2945         fb++;
2946     else
2947         fb = b;
2948     if (strNE(a,b))
2949         return FALSE;
2950     if (fa == a)
2951         sv_setpvn(tmpsv, ".", 1);
2952     else
2953         sv_setpvn(tmpsv, a, fa - a);
2954     if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf1) < 0)
2955         return FALSE;
2956     if (fb == b)
2957         sv_setpvn(tmpsv, ".", 1);
2958     else
2959         sv_setpvn(tmpsv, b, fb - b);
2960     if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf2) < 0)
2961         return FALSE;
2962     return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev &&
2963            tmpstatbuf1.st_ino == tmpstatbuf2.st_ino;
2964 }
2965 #endif /* !HAS_RENAME */
2966
2967 char*
2968 Perl_find_script(pTHX_ const char *scriptname, bool dosearch,
2969                  const char *const *const search_ext, I32 flags)
2970 {
2971     dVAR;
2972     const char *xfound = NULL;
2973     char *xfailed = NULL;
2974     char tmpbuf[MAXPATHLEN];
2975     register char *s;
2976     I32 len = 0;
2977     int retval;
2978 #if defined(DOSISH) && !defined(OS2) && !defined(atarist)
2979 #  define SEARCH_EXTS ".bat", ".cmd", NULL
2980 #  define MAX_EXT_LEN 4
2981 #endif
2982 #ifdef OS2
2983 #  define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
2984 #  define MAX_EXT_LEN 4
2985 #endif
2986 #ifdef VMS
2987 #  define SEARCH_EXTS ".pl", ".com", NULL
2988 #  define MAX_EXT_LEN 4
2989 #endif
2990     /* additional extensions to try in each dir if scriptname not found */
2991 #ifdef SEARCH_EXTS
2992     static const char *const exts[] = { SEARCH_EXTS };
2993     const char *const *const ext = search_ext ? search_ext : exts;
2994     int extidx = 0, i = 0;
2995     const char *curext = NULL;
2996 #else
2997     PERL_UNUSED_ARG(search_ext);
2998 #  define MAX_EXT_LEN 0
2999 #endif
3000
3001     /*
3002      * If dosearch is true and if scriptname does not contain path
3003      * delimiters, search the PATH for scriptname.
3004      *
3005      * If SEARCH_EXTS is also defined, will look for each
3006      * scriptname{SEARCH_EXTS} whenever scriptname is not found
3007      * while searching the PATH.
3008      *
3009      * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
3010      * proceeds as follows:
3011      *   If DOSISH or VMSISH:
3012      *     + look for ./scriptname{,.foo,.bar}
3013      *     + search the PATH for scriptname{,.foo,.bar}
3014      *
3015      *   If !DOSISH:
3016      *     + look *only* in the PATH for scriptname{,.foo,.bar} (note
3017      *       this will not look in '.' if it's not in the PATH)
3018      */
3019     tmpbuf[0] = '\0';
3020
3021 #ifdef VMS
3022 #  ifdef ALWAYS_DEFTYPES
3023     len = strlen(scriptname);
3024     if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') {
3025         int idx = 0, deftypes = 1;
3026         bool seen_dot = 1;
3027
3028         const int hasdir = !dosearch || (strpbrk(scriptname,":[</") != NULL);
3029 #  else
3030     if (dosearch) {
3031         int idx = 0, deftypes = 1;
3032         bool seen_dot = 1;
3033
3034         const int hasdir = (strpbrk(scriptname,":[</") != NULL);
3035 #  endif
3036         /* The first time through, just add SEARCH_EXTS to whatever we
3037          * already have, so we can check for default file types. */
3038         while (deftypes ||
3039                (!hasdir && my_trnlnm("DCL$PATH",tmpbuf,idx++)) )
3040         {
3041             if (deftypes) {
3042                 deftypes = 0;
3043                 *tmpbuf = '\0';
3044             }
3045             if ((strlen(tmpbuf) + strlen(scriptname)
3046                  + MAX_EXT_LEN) >= sizeof tmpbuf)
3047                 continue;       /* don't search dir with too-long name */
3048             my_strlcat(tmpbuf, scriptname, sizeof(tmpbuf));
3049 #else  /* !VMS */
3050
3051 #ifdef DOSISH
3052     if (strEQ(scriptname, "-"))
3053         dosearch = 0;
3054     if (dosearch) {             /* Look in '.' first. */
3055         const char *cur = scriptname;
3056 #ifdef SEARCH_EXTS
3057         if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
3058             while (ext[i])
3059                 if (strEQ(ext[i++],curext)) {
3060                     extidx = -1;                /* already has an ext */
3061                     break;
3062                 }
3063         do {
3064 #endif
3065             DEBUG_p(PerlIO_printf(Perl_debug_log,
3066                                   "Looking for %s\n",cur));
3067             if (PerlLIO_stat(cur,&PL_statbuf) >= 0
3068                 && !S_ISDIR(PL_statbuf.st_mode)) {
3069                 dosearch = 0;
3070                 scriptname = cur;
3071 #ifdef SEARCH_EXTS
3072                 break;
3073 #endif
3074             }
3075 #ifdef SEARCH_EXTS
3076             if (cur == scriptname) {
3077                 len = strlen(scriptname);
3078                 if (len+MAX_EXT_LEN+1 >= sizeof(tmpbuf))
3079                     break;
3080                 my_strlcpy(tmpbuf, scriptname, sizeof(tmpbuf));
3081                 cur = tmpbuf;
3082             }
3083         } while (extidx >= 0 && ext[extidx]     /* try an extension? */
3084                  && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len));
3085 #endif
3086     }
3087 #endif
3088
3089 #ifdef MACOS_TRADITIONAL
3090     if (dosearch && !strchr(scriptname, ':') &&
3091         (s = PerlEnv_getenv("Commands")))
3092 #else
3093     if (dosearch && !strchr(scriptname, '/')
3094 #ifdef DOSISH
3095                  && !strchr(scriptname, '\\')
3096 #endif
3097                  && (s = PerlEnv_getenv("PATH")))
3098 #endif
3099     {
3100         bool seen_dot = 0;
3101
3102         PL_bufend = s + strlen(s);
3103         while (s < PL_bufend) {
3104 #ifdef MACOS_TRADITIONAL
3105             s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, PL_bufend,
3106                         ',',
3107                         &len);
3108 #else
3109 #if defined(atarist) || defined(DOSISH)
3110             for (len = 0; *s
3111 #  ifdef atarist
3112                     && *s != ','
3113 #  endif
3114                     && *s != ';'; len++, s++) {
3115                 if (len < sizeof tmpbuf)
3116                     tmpbuf[len] = *s;
3117             }
3118             if (len < sizeof tmpbuf)
3119                 tmpbuf[len] = '\0';
3120 #else  /* ! (atarist || DOSISH) */
3121             s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, PL_bufend,
3122                         ':',
3123                         &len);
3124 #endif /* ! (atarist || DOSISH) */
3125 #endif /* MACOS_TRADITIONAL */
3126             if (s < PL_bufend)
3127                 s++;
3128             if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf)
3129                 continue;       /* don't search dir with too-long name */
3130 #ifdef MACOS_TRADITIONAL
3131             if (len && tmpbuf[len - 1] != ':')
3132                 tmpbuf[len++] = ':';
3133 #else
3134             if (len
3135 #  if defined(atarist) || defined(__MINT__) || defined(DOSISH)
3136                 && tmpbuf[len - 1] != '/'
3137                 && tmpbuf[len - 1] != '\\'
3138 #  endif
3139                )
3140                 tmpbuf[len++] = '/';
3141             if (len == 2 && tmpbuf[0] == '.')
3142                 seen_dot = 1;
3143 #endif
3144             (void)my_strlcpy(tmpbuf + len, scriptname, sizeof(tmpbuf) - len);
3145 #endif  /* !VMS */
3146
3147 #ifdef SEARCH_EXTS
3148             len = strlen(tmpbuf);
3149             if (extidx > 0)     /* reset after previous loop */
3150                 extidx = 0;
3151             do {
3152 #endif
3153                 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tmpbuf));
3154                 retval = PerlLIO_stat(tmpbuf,&PL_statbuf);
3155                 if (S_ISDIR(PL_statbuf.st_mode)) {
3156                     retval = -1;
3157                 }
3158 #ifdef SEARCH_EXTS
3159             } while (  retval < 0               /* not there */
3160                     && extidx>=0 && ext[extidx] /* try an extension? */
3161                     && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len)
3162                 );
3163 #endif
3164             if (retval < 0)
3165                 continue;
3166             if (S_ISREG(PL_statbuf.st_mode)
3167                 && cando(S_IRUSR,TRUE,&PL_statbuf)
3168 #if !defined(DOSISH) && !defined(MACOS_TRADITIONAL)
3169                 && cando(S_IXUSR,TRUE,&PL_statbuf)
3170 #endif
3171                 )
3172             {
3173                 xfound = tmpbuf;                /* bingo! */
3174                 break;
3175             }
3176             if (!xfailed)
3177                 xfailed = savepv(tmpbuf);
3178         }
3179 #ifndef DOSISH
3180         if (!xfound && !seen_dot && !xfailed &&
3181             (PerlLIO_stat(scriptname,&PL_statbuf) < 0
3182              || S_ISDIR(PL_statbuf.st_mode)))
3183 #endif
3184             seen_dot = 1;                       /* Disable message. */
3185         if (!xfound) {
3186             if (flags & 1) {                    /* do or die? */
3187                 Perl_croak(aTHX_ "Can't %s %s%s%s",
3188                       (xfailed ? "execute" : "find"),
3189                       (xfailed ? xfailed : scriptname),
3190                       (xfailed ? "" : " on PATH"),
3191                       (xfailed || seen_dot) ? "" : ", '.' not in PATH");
3192             }
3193             scriptname = NULL;
3194         }
3195         Safefree(xfailed);
3196         scriptname = xfound;
3197     }
3198     return (scriptname ? savepv(scriptname) : NULL);
3199 }
3200
3201 #ifndef PERL_GET_CONTEXT_DEFINED
3202
3203 void *
3204 Perl_get_context(void)
3205 {
3206     dVAR;
3207 #if defined(USE_ITHREADS)
3208 #  ifdef OLD_PTHREADS_API
3209     pthread_addr_t t;
3210     if (pthread_getspecific(PL_thr_key, &t))
3211         Perl_croak_nocontext("panic: pthread_getspecific");
3212     return (void*)t;
3213 #  else
3214 #    ifdef I_MACH_CTHREADS
3215     return (void*)cthread_data(cthread_self());
3216 #    else
3217     return (void*)PTHREAD_GETSPECIFIC(PL_thr_key);
3218 #    endif
3219 #  endif
3220 #else
3221     return (void*)NULL;
3222 #endif
3223 }
3224
3225 void
3226 Perl_set_context(void *t)
3227 {
3228     dVAR;
3229 #if defined(USE_ITHREADS)
3230 #  ifdef I_MACH_CTHREADS
3231     cthread_set_data(cthread_self(), t);
3232 #  else
3233     if (pthread_setspecific(PL_thr_key, t))
3234         Perl_croak_nocontext("panic: pthread_setspecific");
3235 #  endif
3236 #else
3237     PERL_UNUSED_ARG(t);
3238 #endif
3239 }
3240
3241 #endif /* !PERL_GET_CONTEXT_DEFINED */
3242
3243 #if defined(PERL_GLOBAL_STRUCT) && !defined(PERL_GLOBAL_STRUCT_PRIVATE)
3244 struct perl_vars *
3245 Perl_GetVars(pTHX)
3246 {
3247  return &PL_Vars;
3248 }
3249 #endif
3250
3251 char **
3252 Perl_get_op_names(pTHX)
3253 {
3254     PERL_UNUSED_CONTEXT;
3255     return (char **)PL_op_name;
3256 }
3257
3258 char **
3259 Perl_get_op_descs(pTHX)
3260 {
3261     PERL_UNUSED_CONTEXT;
3262     return (char **)PL_op_desc;
3263 }
3264
3265 const char *
3266 Perl_get_no_modify(pTHX)
3267 {
3268     PERL_UNUSED_CONTEXT;
3269     return PL_no_modify;
3270 }
3271
3272 U32 *
3273 Perl_get_opargs(pTHX)
3274 {
3275     PERL_UNUSED_CONTEXT;
3276     return (U32 *)PL_opargs;
3277 }
3278
3279 PPADDR_t*
3280 Perl_get_ppaddr(pTHX)
3281 {
3282     dVAR;
3283     PERL_UNUSED_CONTEXT;
3284     return (PPADDR_t*)PL_ppaddr;
3285 }
3286
3287 #ifndef HAS_GETENV_LEN
3288 char *
3289 Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len)
3290 {
3291     char * const env_trans = PerlEnv_getenv(env_elem);
3292     PERL_UNUSED_CONTEXT;
3293     if (env_trans)
3294         *len = strlen(env_trans);
3295     return env_trans;
3296 }
3297 #endif
3298
3299
3300 MGVTBL*
3301 Perl_get_vtbl(pTHX_ int vtbl_id)
3302 {
3303     const MGVTBL* result;
3304     PERL_UNUSED_CONTEXT;
3305
3306     switch(vtbl_id) {
3307     case want_vtbl_sv:
3308         result = &PL_vtbl_sv;
3309         break;
3310     case want_vtbl_env:
3311         result = &PL_vtbl_env;
3312         break;
3313     case want_vtbl_envelem:
3314         result = &PL_vtbl_envelem;
3315         break;
3316     case want_vtbl_sig:
3317         result = &PL_vtbl_sig;
3318         break;
3319     case want_vtbl_sigelem:
3320         result = &PL_vtbl_sigelem;
3321         break;
3322     case want_vtbl_pack:
3323         result = &PL_vtbl_pack;
3324         break;
3325     case want_vtbl_packelem:
3326         result = &PL_vtbl_packelem;
3327         break;
3328     case want_vtbl_dbline:
3329         result = &PL_vtbl_dbline;
3330         break;
3331     case want_vtbl_isa:
3332         result = &PL_vtbl_isa;
3333         break;
3334     case want_vtbl_isaelem:
3335         result = &PL_vtbl_isaelem;
3336         break;
3337     case want_vtbl_arylen:
3338         result = &PL_vtbl_arylen;
3339         break;
3340     case want_vtbl_mglob:
3341         result = &PL_vtbl_mglob;
3342         break;
3343     case want_vtbl_nkeys:
3344         result = &PL_vtbl_nkeys;
3345         break;
3346     case want_vtbl_taint:
3347         result = &PL_vtbl_taint;
3348         break;
3349     case want_vtbl_substr:
3350         result = &PL_vtbl_substr;
3351         break;
3352     case want_vtbl_vec:
3353         result = &PL_vtbl_vec;
3354         break;
3355     case want_vtbl_pos:
3356         result = &PL_vtbl_pos;
3357         break;
3358     case want_vtbl_bm:
3359         result = &PL_vtbl_bm;
3360         break;
3361     case want_vtbl_fm:
3362         result = &PL_vtbl_fm;
3363         break;
3364     case want_vtbl_uvar:
3365         result = &PL_vtbl_uvar;
3366         break;
3367     case want_vtbl_defelem:
3368         result = &PL_vtbl_defelem;
3369         break;
3370     case want_vtbl_regexp:
3371         result = &PL_vtbl_regexp;
3372         break;
3373     case want_vtbl_regdata:
3374         result = &PL_vtbl_regdata;
3375         break;
3376     case want_vtbl_regdatum:
3377         result = &PL_vtbl_regdatum;
3378         break;
3379 #ifdef USE_LOCALE_COLLATE
3380     case want_vtbl_collxfrm:
3381         result = &PL_vtbl_collxfrm;
3382         break;
3383 #endif
3384     case want_vtbl_amagic:
3385         result = &PL_vtbl_amagic;
3386         break;
3387     case want_vtbl_amagicelem:
3388         result = &PL_vtbl_amagicelem;
3389         break;
3390     case want_vtbl_backref:
3391         result = &PL_vtbl_backref;
3392         break;
3393     case want_vtbl_utf8:
3394         result = &PL_vtbl_utf8;
3395         break;
3396     default:
3397         result = NULL;
3398         break;
3399     }
3400     return (MGVTBL*)result;
3401 }
3402
3403 I32
3404 Perl_my_fflush_all(pTHX)
3405 {
3406 #if defined(USE_PERLIO) || defined(FFLUSH_NULL) || defined(USE_SFIO)
3407     return PerlIO_flush(NULL);
3408 #else
3409 # if defined(HAS__FWALK)
3410     extern int fflush(FILE *);
3411     /* undocumented, unprototyped, but very useful BSDism */
3412     extern void _fwalk(int (*)(FILE *));
3413     _fwalk(&fflush);
3414     return 0;
3415 # else
3416 #  if defined(FFLUSH_ALL) && defined(HAS_STDIO_STREAM_ARRAY)
3417     long open_max = -1;
3418 #   ifdef PERL_FFLUSH_ALL_FOPEN_MAX
3419     open_max = PERL_FFLUSH_ALL_FOPEN_MAX;
3420 #   else
3421 #    if defined(HAS_SYSCONF) && defined(_SC_OPEN_MAX)
3422     open_max = sysconf(_SC_OPEN_MAX);
3423 #     else
3424 #      ifdef FOPEN_MAX
3425     open_max = FOPEN_MAX;
3426 #      else
3427 #       ifdef OPEN_MAX
3428     open_max = OPEN_MAX;
3429 #       else
3430 #        ifdef _NFILE
3431     open_max = _NFILE;
3432 #        endif
3433 #       endif
3434 #      endif
3435 #     endif
3436 #    endif
3437     if (open_max > 0) {
3438       long i;
3439       for (i = 0; i < open_max; i++)
3440             if (STDIO_STREAM_ARRAY[i]._file >= 0 &&
3441                 STDIO_STREAM_ARRAY[i]._file < open_max &&
3442                 STDIO_STREAM_ARRAY[i]._flag)
3443                 PerlIO_flush(&STDIO_STREAM_ARRAY[i]);
3444       return 0;
3445     }
3446 #  endif
3447     SETERRNO(EBADF,RMS_IFI);
3448     return EOF;
3449 # endif
3450 #endif
3451 }
3452
3453 void
3454 Perl_report_evil_fh(pTHX_ const GV *gv, const IO *io, I32 op)
3455 {
3456     const char * const name = gv && isGV(gv) ? GvENAME(gv) : NULL;
3457
3458     if (op == OP_phoney_OUTPUT_ONLY || op == OP_phoney_INPUT_ONLY) {
3459         if (ckWARN(WARN_IO)) {
3460             const char * const direction =
3461                 (const char *)((op == OP_phoney_INPUT_ONLY) ? "in" : "out");
3462             if (name && *name)
3463                 Perl_warner(aTHX_ packWARN(WARN_IO),
3464                             "Filehandle %s opened only for %sput",
3465                             name, direction);
3466             else
3467                 Perl_warner(aTHX_ packWARN(WARN_IO),
3468                             "Filehandle opened only for %sput", direction);
3469         }
3470     }
3471     else {
3472         const char *vile;
3473         I32   warn_type;
3474
3475         if (gv && io && IoTYPE(io) == IoTYPE_CLOSED) {
3476             vile = "closed";
3477             warn_type = WARN_CLOSED;
3478         }
3479         else {
3480             vile = "unopened";
3481             warn_type = WARN_UNOPENED;
3482         }
3483
3484         if (ckWARN(warn_type)) {
3485             const char * const pars =
3486                 (const char *)(OP_IS_FILETEST(op) ? "" : "()");
3487             const char * const func =
3488                 (const char *)
3489                 (op == OP_READLINE   ? "readline"  :    /* "<HANDLE>" not nice */
3490                  op == OP_LEAVEWRITE ? "write" :                /* "write exit" not nice */
3491                  op < 0              ? "" :              /* handle phoney cases */
3492                  PL_op_desc[op]);
3493             const char * const type =
3494                 (const char *)
3495                 (OP_IS_SOCKET(op) ||
3496                  (gv && io && IoTYPE(io) == IoTYPE_SOCKET) ?
3497                  "socket" : "filehandle");
3498             if (name && *name) {
3499                 Perl_warner(aTHX_ packWARN(warn_type),
3500                             "%s%s on %s %s %s", func, pars, vile, type, name);
3501                 if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3502                     Perl_warner(
3503                         aTHX_ packWARN(warn_type),
3504                         "\t(Are you trying to call %s%s on dirhandle %s?)\n",
3505                         func, pars, name
3506                     );
3507             }
3508             else {
3509                 Perl_warner(aTHX_ packWARN(warn_type),
3510                             "%s%s on %s %s", func, pars, vile, type);
3511                 if (gv && io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3512                     Perl_warner(
3513                         aTHX_ packWARN(warn_type),
3514                         "\t(Are you trying to call %s%s on dirhandle?)\n",
3515                         func, pars
3516                     );
3517             }
3518         }
3519     }
3520 }
3521
3522 #ifdef EBCDIC
3523 /* in ASCII order, not that it matters */
3524 static const char controllablechars[] = "?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_";
3525
3526 int
3527 Perl_ebcdic_control(pTHX_ int ch)
3528 {
3529     if (ch > 'a') {
3530         const char *ctlp;
3531
3532         if (islower(ch))
3533             ch = toupper(ch);
3534
3535         if ((ctlp = strchr(controllablechars, ch)) == 0) {
3536             Perl_die(aTHX_ "unrecognised control character '%c'\n", ch);
3537         }
3538
3539         if (ctlp == controllablechars)
3540             return('\177'); /* DEL */
3541         else
3542             return((unsigned char)(ctlp - controllablechars - 1));
3543     } else { /* Want uncontrol */
3544         if (ch == '\177' || ch == -1)
3545             return('?');
3546         else if (ch == '\157')
3547             return('\177');
3548         else if (ch == '\174')
3549             return('\000');
3550         else if (ch == '^')    /* '\137' in 1047, '\260' in 819 */
3551             return('\036');
3552         else if (ch == '\155')
3553             return('\037');
3554         else if (0 < ch && ch < (sizeof(controllablechars) - 1))
3555             return(controllablechars[ch+1]);
3556         else
3557             Perl_die(aTHX_ "invalid control request: '\\%03o'\n", ch & 0xFF);
3558     }
3559 }
3560 #endif
3561
3562 /* To workaround core dumps from the uninitialised tm_zone we get the
3563  * system to give us a reasonable struct to copy.  This fix means that
3564  * strftime uses the tm_zone and tm_gmtoff values returned by
3565  * localtime(time()). That should give the desired result most of the
3566  * time. But probably not always!
3567  *
3568  * This does not address tzname aspects of NETaa14816.
3569  *
3570  */
3571
3572 #ifdef HAS_GNULIBC
3573 # ifndef STRUCT_TM_HASZONE
3574 #    define STRUCT_TM_HASZONE
3575 # endif
3576 #endif
3577
3578 #ifdef STRUCT_TM_HASZONE /* Backward compat */
3579 # ifndef HAS_TM_TM_ZONE
3580 #    define HAS_TM_TM_ZONE
3581 # endif
3582 #endif
3583
3584 void
3585 Perl_init_tm(pTHX_ struct tm *ptm)      /* see mktime, strftime and asctime */
3586 {
3587 #ifdef HAS_TM_TM_ZONE
3588     Time_t now;
3589     const struct tm* my_tm;
3590     (void)time(&now);
3591     my_tm = localtime(&now);
3592     if (my_tm)
3593         Copy(my_tm, ptm, 1, struct tm);
3594 #else
3595     PERL_UNUSED_ARG(ptm);
3596 #endif
3597 }
3598
3599 /*
3600  * mini_mktime - normalise struct tm values without the localtime()
3601  * semantics (and overhead) of mktime().
3602  */
3603 void
3604 Perl_mini_mktime(pTHX_ struct tm *ptm)
3605 {
3606     int yearday;
3607     int secs;
3608     int month, mday, year, jday;
3609     int odd_cent, odd_year;
3610     PERL_UNUSED_CONTEXT;
3611
3612 #define DAYS_PER_YEAR   365
3613 #define DAYS_PER_QYEAR  (4*DAYS_PER_YEAR+1)
3614 #define DAYS_PER_CENT   (25*DAYS_PER_QYEAR-1)
3615 #define DAYS_PER_QCENT  (4*DAYS_PER_CENT+1)
3616 #define SECS_PER_HOUR   (60*60)
3617 #define SECS_PER_DAY    (24*SECS_PER_HOUR)
3618 /* parentheses deliberately absent on these two, otherwise they don't work */
3619 #define MONTH_TO_DAYS   153/5
3620 #define DAYS_TO_MONTH   5/153
3621 /* offset to bias by March (month 4) 1st between month/mday & year finding */
3622 #define YEAR_ADJUST     (4*MONTH_TO_DAYS+1)
3623 /* as used here, the algorithm leaves Sunday as day 1 unless we adjust it */
3624 #define WEEKDAY_BIAS    6       /* (1+6)%7 makes Sunday 0 again */
3625
3626 /*
3627  * Year/day algorithm notes:
3628  *
3629  * With a suitable offset for numeric value of the month, one can find
3630  * an offset into the year by considering months to have 30.6 (153/5) days,
3631  * using integer arithmetic (i.e., with truncation).  To avoid too much
3632  * messing about with leap days, we consider January and February to be
3633  * the 13th and 14th month of the previous year.  After that transformation,
3634  * we need the month index we use to be high by 1 from 'normal human' usage,
3635  * so the month index values we use run from 4 through 15.
3636  *
3637  * Given that, and the rules for the Gregorian calendar (leap years are those
3638  * divisible by 4 unless also divisible by 100, when they must be divisible
3639  * by 400 instead), we can simply calculate the number of days since some
3640  * arbitrary 'beginning of time' by futzing with the (adjusted) year number,
3641  * the days we derive from our month index, and adding in the day of the
3642  * month.  The value used here is not adjusted for the actual origin which
3643  * it normally would use (1 January A.D. 1), since we're not exposing it.
3644  * We're only building the value so we can turn around and get the
3645  * normalised values for the year, month, day-of-month, and day-of-year.
3646  *
3647  * For going backward, we need to bias the value we're using so that we find
3648  * the right year value.  (Basically, we don't want the contribution of
3649  * March 1st to the number to apply while deriving the year).  Having done
3650  * that, we 'count up' the contribution to the year number by accounting for
3651  * full quadracenturies (400-year periods) with their extra leap days, plus
3652  * the contribution from full centuries (to avoid counting in the lost leap
3653  * days), plus the contribution from full quad-years (to count in the normal
3654  * leap days), plus the leftover contribution from any non-leap years.
3655  * At this point, if we were working with an actual leap day, we'll have 0
3656  * days left over.  This is also true for March 1st, however.  So, we have
3657  * to special-case that result, and (earlier) keep track of the 'odd'
3658  * century and year contributions.  If we got 4 extra centuries in a qcent,
3659  * or 4 extra years in a qyear, then it's a leap day and we call it 29 Feb.
3660  * Otherwise, we add back in the earlier bias we removed (the 123 from
3661  * figuring in March 1st), find the month index (integer division by 30.6),
3662  * and the remainder is the day-of-month.  We then have to convert back to
3663  * 'real' months (including fixing January and February from being 14/15 in
3664  * the previous year to being in the proper year).  After that, to get
3665  * tm_yday, we work with the normalised year and get a new yearday value for
3666  * January 1st, which we subtract from the yearday value we had earlier,
3667  * representing the date we've re-built.  This is done from January 1
3668  * because tm_yday is 0-origin.
3669  *
3670  * Since POSIX time routines are only guaranteed to work for times since the
3671  * UNIX epoch (00:00:00 1 Jan 1970 UTC), the fact that this algorithm
3672  * applies Gregorian calendar rules even to dates before the 16th century
3673  * doesn't bother me.  Besides, you'd need cultural context for a given
3674  * date to know whether it was Julian or Gregorian calendar, and that's
3675  * outside the scope for this routine.  Since we convert back based on the
3676  * same rules we used to build the yearday, you'll only get strange results
3677  * for input which needed normalising, or for the 'odd' century years which
3678  * were leap years in the Julian calander but not in the Gregorian one.
3679  * I can live with that.
3680  *
3681  * This algorithm also fails to handle years before A.D. 1 gracefully, but
3682  * that's still outside the scope for POSIX time manipulation, so I don't
3683  * care.
3684  */
3685
3686     year = 1900 + ptm->tm_year;
3687     month = ptm->tm_mon;
3688     mday = ptm->tm_mday;
3689     /* allow given yday with no month & mday to dominate the result */
3690     if (ptm->tm_yday >= 0 && mday <= 0 && month <= 0) {
3691         month = 0;
3692         mday = 0;
3693         jday = 1 + ptm->tm_yday;
3694     }
3695     else {
3696         jday = 0;
3697     }
3698     if (month >= 2)
3699         month+=2;
3700     else
3701         month+=14, year--;
3702     yearday = DAYS_PER_YEAR * year + year/4 - year/100 + year/400;
3703     yearday += month*MONTH_TO_DAYS + mday + jday;
3704     /*
3705      * Note that we don't know when leap-seconds were or will be,
3706      * so we have to trust the user if we get something which looks
3707      * like a sensible leap-second.  Wild values for seconds will
3708      * be rationalised, however.
3709      */
3710     if ((unsigned) ptm->tm_sec <= 60) {
3711         secs = 0;
3712     }
3713     else {
3714         secs = ptm->tm_sec;
3715         ptm->tm_sec = 0;
3716     }
3717     secs += 60 * ptm->tm_min;
3718     secs += SECS_PER_HOUR * ptm->tm_hour;
3719     if (secs < 0) {
3720         if (secs-(secs/SECS_PER_DAY*SECS_PER_DAY) < 0) {
3721             /* got negative remainder, but need positive time */
3722             /* back off an extra day to compensate */
3723             yearday += (secs/SECS_PER_DAY)-1;
3724             secs -= SECS_PER_DAY * (secs/SECS_PER_DAY - 1);
3725         }
3726         else {
3727             yearday += (secs/SECS_PER_DAY);
3728             secs -= SECS_PER_DAY * (secs/SECS_PER_DAY);
3729         }
3730     }
3731     else if (secs >= SECS_PER_DAY) {
3732         yearday += (secs/SECS_PER_DAY);
3733         secs %= SECS_PER_DAY;
3734     }
3735     ptm->tm_hour = secs/SECS_PER_HOUR;
3736     secs %= SECS_PER_HOUR;
3737     ptm->tm_min = secs/60;
3738     secs %= 60;
3739     ptm->tm_sec += secs;
3740     /* done with time of day effects */
3741     /*
3742      * The algorithm for yearday has (so far) left it high by 428.
3743      * To avoid mistaking a legitimate Feb 29 as Mar 1, we need to
3744      * bias it by 123 while trying to figure out what year it
3745      * really represents.  Even with this tweak, the reverse
3746      * translation fails for years before A.D. 0001.
3747      * It would still fail for Feb 29, but we catch that one below.
3748      */
3749     jday = yearday;     /* save for later fixup vis-a-vis Jan 1 */
3750     yearday -= YEAR_ADJUST;
3751     year = (yearday / DAYS_PER_QCENT) * 400;
3752     yearday %= DAYS_PER_QCENT;
3753     odd_cent = yearday / DAYS_PER_CENT;
3754     year += odd_cent * 100;
3755     yearday %= DAYS_PER_CENT;
3756     year += (yearday / DAYS_PER_QYEAR) * 4;
3757     yearday %= DAYS_PER_QYEAR;
3758     odd_year = yearday / DAYS_PER_YEAR;
3759     year += odd_year;
3760     yearday %= DAYS_PER_YEAR;
3761     if (!yearday && (odd_cent==4 || odd_year==4)) { /* catch Feb 29 */
3762         month = 1;
3763         yearday = 29;
3764     }
3765     else {
3766         yearday += YEAR_ADJUST; /* recover March 1st crock */
3767         month = yearday*DAYS_TO_MONTH;
3768         yearday -= month*MONTH_TO_DAYS;
3769         /* recover other leap-year adjustment */
3770         if (month > 13) {
3771             month-=14;
3772             year++;
3773         }
3774         else {
3775             month-=2;
3776         }
3777     }
3778     ptm->tm_year = year - 1900;
3779     if (yearday) {
3780       ptm->tm_mday = yearday;
3781       ptm->tm_mon = month;
3782     }
3783     else {
3784       ptm->tm_mday = 31;
3785       ptm->tm_mon = month - 1;
3786     }
3787     /* re-build yearday based on Jan 1 to get tm_yday */
3788     year--;
3789     yearday = year*DAYS_PER_YEAR + year/4 - year/100 + year/400;
3790     yearday += 14*MONTH_TO_DAYS + 1;
3791     ptm->tm_yday = jday - yearday;
3792     /* fix tm_wday if not overridden by caller */
3793     if ((unsigned)ptm->tm_wday > 6)
3794         ptm->tm_wday = (jday + WEEKDAY_BIAS) % 7;
3795 }
3796
3797 char *
3798 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)
3799 {
3800 #ifdef HAS_STRFTIME
3801   char *buf;
3802   int buflen;
3803   struct tm mytm;
3804   int len;
3805
3806   init_tm(&mytm);       /* XXX workaround - see init_tm() above */
3807   mytm.tm_sec = sec;
3808   mytm.tm_min = min;
3809   mytm.tm_hour = hour;
3810   mytm.tm_mday = mday;
3811   mytm.tm_mon = mon;
3812   mytm.tm_year = year;
3813   mytm.tm_wday = wday;
3814   mytm.tm_yday = yday;
3815   mytm.tm_isdst = isdst;
3816   mini_mktime(&mytm);
3817   /* use libc to get the values for tm_gmtoff and tm_zone [perl #18238] */
3818 #if defined(HAS_MKTIME) && (defined(HAS_TM_TM_GMTOFF) || defined(HAS_TM_TM_ZONE))
3819   STMT_START {
3820     struct tm mytm2;
3821     mytm2 = mytm;
3822     mktime(&mytm2);
3823 #ifdef HAS_TM_TM_GMTOFF
3824     mytm.tm_gmtoff = mytm2.tm_gmtoff;
3825 #endif
3826 #ifdef HAS_TM_TM_ZONE
3827     mytm.tm_zone = mytm2.tm_zone;
3828 #endif
3829   } STMT_END;
3830 #endif
3831   buflen = 64;
3832   Newx(buf, buflen, char);
3833   len = strftime(buf, buflen, fmt, &mytm);
3834   /*
3835   ** The following is needed to handle to the situation where
3836   ** tmpbuf overflows.  Basically we want to allocate a buffer
3837   ** and try repeatedly.  The reason why it is so complicated
3838   ** is that getting a return value of 0 from strftime can indicate
3839   ** one of the following:
3840   ** 1. buffer overflowed,
3841   ** 2. illegal conversion specifier, or
3842   ** 3. the format string specifies nothing to be returned(not
3843   **      an error).  This could be because format is an empty string
3844   **    or it specifies %p that yields an empty string in some locale.
3845   ** If there is a better way to make it portable, go ahead by
3846   ** all means.
3847   */
3848   if ((len > 0 && len < buflen) || (len == 0 && *fmt == '\0'))
3849     return buf;
3850   else {
3851     /* Possibly buf overflowed - try again with a bigger buf */
3852     const int fmtlen = strlen(fmt);
3853     int bufsize = fmtlen + buflen;
3854
3855     Newx(buf, bufsize, char);
3856     while (buf) {
3857       buflen = strftime(buf, bufsize, fmt, &mytm);
3858       if (buflen > 0 && buflen < bufsize)
3859         break;
3860       /* heuristic to prevent out-of-memory errors */
3861       if (bufsize > 100*fmtlen) {
3862         Safefree(buf);
3863         buf = NULL;
3864         break;
3865       }
3866       bufsize *= 2;
3867       Renew(buf, bufsize, char);
3868     }
3869     return buf;
3870   }
3871 #else
3872   Perl_croak(aTHX_ "panic: no strftime");
3873   return NULL;
3874 #endif
3875 }
3876
3877
3878 #define SV_CWD_RETURN_UNDEF \
3879 sv_setsv(sv, &PL_sv_undef); \
3880 return FALSE
3881
3882 #define SV_CWD_ISDOT(dp) \
3883     (dp->d_name[0] == '.' && (dp->d_name[1] == '\0' || \
3884         (dp->d_name[1] == '.' && dp->d_name[2] == '\0')))
3885
3886 /*
3887 =head1 Miscellaneous Functions
3888
3889 =for apidoc getcwd_sv
3890
3891 Fill the sv with current working directory
3892
3893 =cut
3894 */
3895
3896 /* Originally written in Perl by John Bazik; rewritten in C by Ben Sugars.
3897  * rewritten again by dougm, optimized for use with xs TARG, and to prefer
3898  * getcwd(3) if available
3899  * Comments from the orignal:
3900  *     This is a faster version of getcwd.  It's also more dangerous
3901  *     because you might chdir out of a directory that you can't chdir
3902  *     back into. */
3903
3904 int
3905 Perl_getcwd_sv(pTHX_ register SV *sv)
3906 {
3907 #ifndef PERL_MICRO
3908     dVAR;
3909 #ifndef INCOMPLETE_TAINTS
3910     SvTAINTED_on(sv);
3911 #endif
3912
3913 #ifdef HAS_GETCWD
3914     {
3915         char buf[MAXPATHLEN];
3916
3917         /* Some getcwd()s automatically allocate a buffer of the given
3918          * size from the heap if they are given a NULL buffer pointer.
3919          * The problem is that this behaviour is not portable. */
3920         if (getcwd(buf, sizeof(buf) - 1)) {
3921             sv_setpv(sv, buf);
3922             return TRUE;
3923         }
3924         else {
3925             sv_setsv(sv, &PL_sv_undef);
3926             return FALSE;
3927         }
3928     }
3929
3930 #else
3931
3932     Stat_t statbuf;
3933     int orig_cdev, orig_cino, cdev, cino, odev, oino, tdev, tino;
3934     int pathlen=0;
3935     Direntry_t *dp;
3936
3937     SvUPGRADE(sv, SVt_PV);
3938
3939     if (PerlLIO_lstat(".", &statbuf) < 0) {
3940         SV_CWD_RETURN_UNDEF;
3941     }
3942
3943     orig_cdev = statbuf.st_dev;
3944     orig_cino = statbuf.st_ino;
3945     cdev = orig_cdev;
3946     cino = orig_cino;
3947
3948     for (;;) {
3949         DIR *dir;
3950         odev = cdev;
3951         oino = cino;
3952
3953         if (PerlDir_chdir("..") < 0) {
3954             SV_CWD_RETURN_UNDEF;
3955         }
3956         if (PerlLIO_stat(".", &statbuf) < 0) {
3957             SV_CWD_RETURN_UNDEF;
3958         }
3959
3960         cdev = statbuf.st_dev;
3961         cino = statbuf.st_ino;
3962
3963         if (odev == cdev && oino == cino) {
3964             break;
3965         }
3966         if (!(dir = PerlDir_open("."))) {
3967             SV_CWD_RETURN_UNDEF;
3968         }
3969
3970         while ((dp = PerlDir_read(dir)) != NULL) {
3971 #ifdef DIRNAMLEN
3972             const int namelen = dp->d_namlen;
3973 #else
3974             const int namelen = strlen(dp->d_name);
3975 #endif
3976             /* skip . and .. */
3977             if (SV_CWD_ISDOT(dp)) {
3978                 continue;
3979             }
3980
3981             if (PerlLIO_lstat(dp->d_name, &statbuf) < 0) {
3982                 SV_CWD_RETURN_UNDEF;
3983             }
3984
3985             tdev = statbuf.st_dev;
3986             tino = statbuf.st_ino;
3987             if (tino == oino && tdev == odev) {
3988                 break;
3989             }
3990         }
3991
3992         if (!dp) {
3993             SV_CWD_RETURN_UNDEF;
3994         }
3995
3996         if (pathlen + namelen + 1 >= MAXPATHLEN) {
3997             SV_CWD_RETURN_UNDEF;
3998         }
3999
4000         SvGROW(sv, pathlen + namelen + 1);
4001
4002         if (pathlen) {
4003             /* shift down */
4004             Move(SvPVX_const(sv), SvPVX(sv) + namelen + 1, pathlen, char);
4005         }
4006
4007         /* prepend current directory to the front */
4008         *SvPVX(sv) = '/';
4009         Move(dp->d_name, SvPVX(sv)+1, namelen, char);
4010         pathlen += (namelen + 1);
4011
4012 #ifdef VOID_CLOSEDIR
4013         PerlDir_close(dir);
4014 #else
4015         if (PerlDir_close(dir) < 0) {
4016             SV_CWD_RETURN_UNDEF;
4017         }
4018 #endif
4019     }
4020
4021     if (pathlen) {
4022         SvCUR_set(sv, pathlen);
4023         *SvEND(sv) = '\0';
4024         SvPOK_only(sv);
4025
4026         if (PerlDir_chdir(SvPVX_const(sv)) < 0) {
4027             SV_CWD_RETURN_UNDEF;
4028         }
4029     }
4030     if (PerlLIO_stat(".", &statbuf) < 0) {
4031         SV_CWD_RETURN_UNDEF;
4032     }
4033
4034     cdev = statbuf.st_dev;
4035     cino = statbuf.st_ino;
4036
4037     if (cdev != orig_cdev || cino != orig_cino) {
4038         Perl_croak(aTHX_ "Unstable directory path, "
4039                    "current directory changed unexpectedly");
4040     }
4041
4042     return TRUE;
4043 #endif
4044
4045 #else
4046     return FALSE;
4047 #endif
4048 }
4049
4050 /*
4051 =for apidoc scan_version
4052
4053 Returns a pointer to the next character after the parsed
4054 version string, as well as upgrading the passed in SV to
4055 an RV.
4056
4057 Function must be called with an already existing SV like
4058
4059     sv = newSV(0);
4060     s = scan_version(s,SV *sv, bool qv);
4061
4062 Performs some preprocessing to the string to ensure that
4063 it has the correct characteristics of a version.  Flags the
4064 object if it contains an underscore (which denotes this
4065 is a alpha version).  The boolean qv denotes that the version
4066 should be interpreted as if it had multiple decimals, even if
4067 it doesn't.
4068
4069 =cut
4070 */
4071
4072 const char *
4073 Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
4074 {
4075     const char *start;
4076     const char *pos;
4077     const char *last;
4078     int saw_period = 0;
4079     int alpha = 0;
4080     int width = 3;
4081     AV * const av = newAV();
4082     SV * const hv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */
4083     (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
4084
4085 #ifndef NODEFAULT_SHAREKEYS
4086     HvSHAREKEYS_on(hv);         /* key-sharing on by default */
4087 #endif
4088
4089     while (isSPACE(*s)) /* leading whitespace is OK */
4090         s++;
4091
4092     if (*s == 'v') {
4093         s++;  /* get past 'v' */
4094         qv = 1; /* force quoted version processing */
4095     }
4096
4097     start = last = pos = s;
4098
4099     /* pre-scan the input string to check for decimals/underbars */
4100     while ( *pos == '.' || *pos == '_' || isDIGIT(*pos) )
4101     {
4102         if ( *pos == '.' )
4103         {
4104             if ( alpha )
4105                 Perl_croak(aTHX_ "Invalid version format (underscores before decimal)");
4106             saw_period++ ;
4107             last = pos;
4108         }
4109         else if ( *pos == '_' )
4110         {
4111             if ( alpha )
4112                 Perl_croak(aTHX_ "Invalid version format (multiple underscores)");
4113             alpha = 1;
4114             width = pos - last - 1; /* natural width of sub-version */
4115         }
4116         pos++;
4117     }
4118
4119     if ( alpha && !saw_period )
4120         Perl_croak(aTHX_ "Invalid version format (alpha without decimal)");
4121
4122     if ( saw_period > 1 )
4123         qv = 1; /* force quoted version processing */
4124
4125     pos = s;
4126
4127     if ( qv )
4128         hv_store((HV *)hv, "qv", 2, newSViv(qv), 0);
4129     if ( alpha )
4130         hv_store((HV *)hv, "alpha", 5, newSViv(alpha), 0);
4131     if ( !qv && width < 3 )
4132         hv_store((HV *)hv, "width", 5, newSViv(width), 0);
4133
4134     while (isDIGIT(*pos))
4135         pos++;
4136     if (!isALPHA(*pos)) {
4137         I32 rev;
4138
4139         for (;;) {
4140             rev = 0;
4141             {
4142                 /* this is atoi() that delimits on underscores */
4143                 const char *end = pos;
4144                 I32 mult = 1;
4145                 I32 orev;
4146
4147                 /* the following if() will only be true after the decimal
4148                  * point of a version originally created with a bare
4149                  * floating point number, i.e. not quoted in any way
4150                  */
4151                 if ( !qv && s > start && saw_period == 1 ) {
4152                     mult *= 100;
4153                     while ( s < end ) {
4154                         orev = rev;
4155                         rev += (*s - '0') * mult;
4156                         mult /= 10;
4157                         if ( PERL_ABS(orev) > PERL_ABS(rev) )
4158                             Perl_croak(aTHX_ "Integer overflow in version");
4159                         s++;
4160                         if ( *s == '_' )
4161                             s++;
4162                     }
4163                 }
4164                 else {
4165                     while (--end >= s) {
4166                         orev = rev;
4167                         rev += (*end - '0') * mult;
4168                         mult *= 10;
4169                         if ( PERL_ABS(orev) > PERL_ABS(rev) )
4170                             Perl_croak(aTHX_ "Integer overflow in version");
4171                     }
4172                 }
4173             }
4174
4175             /* Append revision */
4176             av_push(av, newSViv(rev));
4177             if ( *pos == '.' )
4178                 s = ++pos;
4179             else if ( *pos == '_' && isDIGIT(pos[1]) )
4180                 s = ++pos;
4181             else if ( isDIGIT(*pos) )
4182                 s = pos;
4183             else {
4184                 s = pos;
4185                 break;
4186             }
4187             if ( qv ) {
4188                 while ( isDIGIT(*pos) )
4189                     pos++;
4190             }
4191             else {
4192                 int digits = 0;
4193                 while ( ( isDIGIT(*pos) || *pos == '_' ) && digits < 3 ) {
4194                     if ( *pos != '_' )
4195                         digits++;
4196                     pos++;
4197                 }
4198             }
4199         }
4200     }
4201     if ( qv ) { /* quoted versions always get at least three terms*/
4202         I32 len = av_len(av);
4203         /* This for loop appears to trigger a compiler bug on OS X, as it
4204            loops infinitely. Yes, len is negative. No, it makes no sense.
4205            Compiler in question is:
4206            gcc version 3.3 20030304 (Apple Computer, Inc. build 1640)
4207            for ( len = 2 - len; len > 0; len-- )
4208            av_push((AV *)sv, newSViv(0));
4209         */
4210         len = 2 - len;
4211         while (len-- > 0)
4212             av_push(av, newSViv(0));
4213     }
4214
4215     if ( av_len(av) == -1 ) /* oops, someone forgot to pass a value */
4216         av_push(av, newSViv(0));
4217
4218     /* fix RT#19517 - special case 'undef' as string */
4219     if ( *s == 'u' && strEQ(s,"undef") ) {
4220         s += 5;
4221     }
4222
4223     /* And finally, store the AV in the hash */
4224     hv_store((HV *)hv, "version", 7, newRV_noinc((SV *)av), 0);
4225     return s;
4226 }
4227
4228 /*
4229 =for apidoc new_version
4230
4231 Returns a new version object based on the passed in SV:
4232
4233     SV *sv = new_version(SV *ver);
4234
4235 Does not alter the passed in ver SV.  See "upg_version" if you
4236 want to upgrade the SV.
4237
4238 =cut
4239 */
4240
4241 SV *
4242 Perl_new_version(pTHX_ SV *ver)
4243 {
4244     dVAR;
4245     SV * const rv = newSV(0);
4246     if ( sv_derived_from(ver,"version") ) /* can just copy directly */
4247     {
4248         I32 key;
4249         AV * const av = newAV();
4250         AV *sav;
4251         /* This will get reblessed later if a derived class*/
4252         SV * const hv = newSVrv(rv, "version");
4253         (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
4254 #ifndef NODEFAULT_SHAREKEYS
4255         HvSHAREKEYS_on(hv);         /* key-sharing on by default */
4256 #endif
4257
4258         if ( SvROK(ver) )
4259             ver = SvRV(ver);
4260
4261         /* Begin copying all of the elements */
4262         if ( hv_exists((HV *)ver, "qv", 2) )
4263             hv_store((HV *)hv, "qv", 2, &PL_sv_yes, 0);
4264
4265         if ( hv_exists((HV *)ver, "alpha", 5) )
4266             hv_store((HV *)hv, "alpha", 5, &PL_sv_yes, 0);
4267
4268         if ( hv_exists((HV*)ver, "width", 5 ) )
4269         {
4270             const I32 width = SvIV(*hv_fetchs((HV*)ver, "width", FALSE));
4271             hv_store((HV *)hv, "width", 5, newSViv(width), 0);
4272         }
4273
4274         sav = (AV *)SvRV(*hv_fetchs((HV*)ver, "version", FALSE));
4275         /* This will get reblessed later if a derived class*/
4276         for ( key = 0; key <= av_len(sav); key++ )
4277         {
4278             const I32 rev = SvIV(*av_fetch(sav, key, FALSE));
4279             av_push(av, newSViv(rev));
4280         }
4281
4282         hv_store((HV *)hv, "version", 7, newRV_noinc((SV *)av), 0);
4283         return rv;
4284     }
4285 #ifdef SvVOK
4286     {
4287         const MAGIC* const mg = SvVSTRING_mg(ver);
4288         if ( mg ) { /* already a v-string */
4289             const STRLEN len = mg->mg_len;
4290             char * const version = savepvn( (const char*)mg->mg_ptr, len);
4291             sv_setpvn(rv,version,len);
4292             Safefree(version);
4293         }
4294         else {
4295 #endif
4296         sv_setsv(rv,ver); /* make a duplicate */
4297 #ifdef SvVOK
4298         }
4299     }
4300 #endif
4301     return upg_version(rv);
4302 }
4303
4304 /*
4305 =for apidoc upg_version
4306
4307 In-place upgrade of the supplied SV to a version object.
4308
4309     SV *sv = upg_version(SV *sv);
4310
4311 Returns a pointer to the upgraded SV.
4312
4313 =cut
4314 */
4315
4316 SV *
4317 Perl_upg_version(pTHX_ SV *ver)
4318 {
4319     const char *version, *s;
4320     bool qv = 0;
4321 #ifdef SvVOK
4322     const MAGIC *mg;
4323 #endif
4324
4325     if ( SvNOK(ver) ) /* may get too much accuracy */
4326     {
4327         char tbuf[64];
4328 #ifdef USE_LOCALE_NUMERIC
4329         char *loc = setlocale(LC_NUMERIC, "C");
4330 #endif
4331         STRLEN len = my_snprintf(tbuf, sizeof(tbuf), "%.9"NVff, SvNVX(ver));
4332 #ifdef USE_LOCALE_NUMERIC
4333         setlocale(LC_NUMERIC, loc);
4334 #endif
4335         while (tbuf[len-1] == '0' && len > 0) len--;
4336         version = savepvn(tbuf, len);
4337     }
4338 #ifdef SvVOK
4339     else if ( (mg = SvVSTRING_mg(ver)) ) { /* already a v-string */
4340         version = savepvn( (const char*)mg->mg_ptr,mg->mg_len );
4341         qv = 1;
4342     }
4343 #endif
4344     else /* must be a string or something like a string */
4345     {
4346         version = savepv(SvPV_nolen(ver));
4347     }
4348
4349     s = scan_version(version, ver, qv);
4350     if ( *s != '\0' )
4351         if(ckWARN(WARN_MISC))
4352             Perl_warner(aTHX_ packWARN(WARN_MISC),
4353                 "Version string '%s' contains invalid data; "
4354                 "ignoring: '%s'", version, s);
4355     Safefree(version);
4356     return ver;
4357 }
4358
4359 /*
4360 =for apidoc vverify
4361
4362 Validates that the SV contains a valid version object.
4363
4364     bool vverify(SV *vobj);
4365
4366 Note that it only confirms the bare minimum structure (so as not to get
4367 confused by derived classes which may contain additional hash entries):
4368
4369 =over 4
4370
4371 =item * The SV contains a [reference to a] hash
4372
4373 =item * The hash contains a "version" key
4374
4375 =item * The "version" key has [a reference to] an AV as its value
4376
4377 =back
4378
4379 =cut
4380 */
4381
4382 bool
4383 Perl_vverify(pTHX_ SV *vs)
4384 {
4385     SV *sv;
4386     if ( SvROK(vs) )
4387         vs = SvRV(vs);
4388
4389     /* see if the appropriate elements exist */
4390     if ( SvTYPE(vs) == SVt_PVHV
4391          && hv_exists((HV*)vs, "version", 7)
4392          && (sv = SvRV(*hv_fetchs((HV*)vs, "version", FALSE)))
4393          && SvTYPE(sv) == SVt_PVAV )
4394         return TRUE;
4395     else
4396         return FALSE;
4397 }
4398
4399 /*
4400 =for apidoc vnumify
4401
4402 Accepts a version object and returns the normalized floating
4403 point representation.  Call like:
4404
4405     sv = vnumify(rv);
4406
4407 NOTE: you can pass either the object directly or the SV
4408 contained within the RV.
4409
4410 =cut
4411 */
4412
4413 SV *
4414 Perl_vnumify(pTHX_ SV *vs)
4415 {
4416     I32 i, len, digit;
4417     int width;
4418     bool alpha = FALSE;
4419     SV * const sv = newSV(0);
4420     AV *av;
4421     if ( SvROK(vs) )
4422         vs = SvRV(vs);
4423
4424     if ( !vverify(vs) )
4425         Perl_croak(aTHX_ "Invalid version object");
4426
4427     /* see if various flags exist */
4428     if ( hv_exists((HV*)vs, "alpha", 5 ) )
4429         alpha = TRUE;
4430     if ( hv_exists((HV*)vs, "width", 5 ) )
4431         width = SvIV(*hv_fetchs((HV*)vs, "width", FALSE));
4432     else
4433         width = 3;
4434
4435
4436     /* attempt to retrieve the version array */
4437     if ( !(av = (AV *)SvRV(*hv_fetchs((HV*)vs, "version", FALSE)) ) ) {
4438         sv_catpvs(sv,"0");
4439         return sv;
4440     }
4441
4442     len = av_len(av);
4443     if ( len == -1 )
4444     {
4445         sv_catpvs(sv,"0");
4446         return sv;
4447     }
4448
4449     digit = SvIV(*av_fetch(av, 0, 0));
4450     Perl_sv_setpvf(aTHX_ sv, "%d.", (int)PERL_ABS(digit));
4451     for ( i = 1 ; i < len ; i++ )
4452     {
4453         digit = SvIV(*av_fetch(av, i, 0));
4454         if ( width < 3 ) {
4455             const int denom = (width == 2 ? 10 : 100);
4456             const div_t term = div((int)PERL_ABS(digit),denom);
4457             Perl_sv_catpvf(aTHX_ sv, "%0*d_%d", width, term.quot, term.rem);
4458         }
4459         else {
4460             Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit);
4461         }
4462     }
4463
4464     if ( len > 0 )
4465     {
4466         digit = SvIV(*av_fetch(av, len, 0));
4467         if ( alpha && width == 3 ) /* alpha version */
4468             sv_catpvs(sv,"_");
4469         Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit);
4470     }
4471     else /* len == 0 */
4472     {
4473         sv_catpvs(sv, "000");
4474     }
4475     return sv;
4476 }
4477
4478 /*
4479 =for apidoc vnormal
4480
4481 Accepts a version object and returns the normalized string
4482 representation.  Call like:
4483
4484     sv = vnormal(rv);
4485
4486 NOTE: you can pass either the object directly or the SV
4487 contained within the RV.
4488
4489 =cut
4490 */
4491
4492 SV *
4493 Perl_vnormal(pTHX_ SV *vs)
4494 {
4495     I32 i, len, digit;
4496     bool alpha = FALSE;
4497     SV * const sv = newSV(0);
4498     AV *av;
4499     if ( SvROK(vs) )
4500         vs = SvRV(vs);
4501
4502     if ( !vverify(vs) )
4503         Perl_croak(aTHX_ "Invalid version object");
4504
4505     if ( hv_exists((HV*)vs, "alpha", 5 ) )
4506         alpha = TRUE;
4507     av = (AV *)SvRV(*hv_fetchs((HV*)vs, "version", FALSE));
4508
4509     len = av_len(av);
4510     if ( len == -1 )
4511     {
4512         sv_catpvs(sv,"");
4513         return sv;
4514     }
4515     digit = SvIV(*av_fetch(av, 0, 0));
4516     Perl_sv_setpvf(aTHX_ sv, "v%"IVdf, (IV)digit);
4517     for ( i = 1 ; i < len ; i++ ) {
4518         digit = SvIV(*av_fetch(av, i, 0));
4519         Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
4520     }
4521
4522     if ( len > 0 )
4523     {
4524         /* handle last digit specially */
4525         digit = SvIV(*av_fetch(av, len, 0));
4526         if ( alpha )
4527             Perl_sv_catpvf(aTHX_ sv, "_%"IVdf, (IV)digit);
4528         else
4529             Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
4530     }
4531
4532     if ( len <= 2 ) { /* short version, must be at least three */
4533         for ( len = 2 - len; len != 0; len-- )
4534             sv_catpvs(sv,".0");
4535     }
4536     return sv;
4537 }
4538
4539 /*
4540 =for apidoc vstringify
4541
4542 In order to maintain maximum compatibility with earlier versions
4543 of Perl, this function will return either the floating point
4544 notation or the multiple dotted notation, depending on whether
4545 the original version contained 1 or more dots, respectively
4546
4547 =cut
4548 */
4549
4550 SV *
4551 Perl_vstringify(pTHX_ SV *vs)
4552 {
4553     if ( SvROK(vs) )
4554         vs = SvRV(vs);
4555
4556     if ( !vverify(vs) )
4557         Perl_croak(aTHX_ "Invalid version object");
4558
4559     if ( hv_exists((HV *)vs, "qv", 2) )
4560         return vnormal(vs);
4561     else
4562         return vnumify(vs);
4563 }
4564
4565 /*
4566 =for apidoc vcmp
4567
4568 Version object aware cmp.  Both operands must already have been
4569 converted into version objects.
4570
4571 =cut
4572 */
4573
4574 int
4575 Perl_vcmp(pTHX_ SV *lhv, SV *rhv)
4576 {
4577     I32 i,l,m,r,retval;
4578     bool lalpha = FALSE;
4579     bool ralpha = FALSE;
4580     I32 left = 0;
4581     I32 right = 0;
4582     AV *lav, *rav;
4583     if ( SvROK(lhv) )
4584         lhv = SvRV(lhv);
4585     if ( SvROK(rhv) )
4586         rhv = SvRV(rhv);
4587
4588     if ( !vverify(lhv) )
4589         Perl_croak(aTHX_ "Invalid version object");
4590
4591     if ( !vverify(rhv) )
4592         Perl_croak(aTHX_ "Invalid version object");
4593
4594     /* get the left hand term */
4595     lav = (AV *)SvRV(*hv_fetchs((HV*)lhv, "version", FALSE));
4596     if ( hv_exists((HV*)lhv, "alpha", 5 ) )
4597         lalpha = TRUE;
4598
4599     /* and the right hand term */
4600     rav = (AV *)SvRV(*hv_fetchs((HV*)rhv, "version", FALSE));
4601     if ( hv_exists((HV*)rhv, "alpha", 5 ) )
4602         ralpha = TRUE;
4603
4604     l = av_len(lav);
4605     r = av_len(rav);
4606     m = l < r ? l : r;
4607     retval = 0;
4608     i = 0;
4609     while ( i <= m && retval == 0 )
4610     {
4611         left  = SvIV(*av_fetch(lav,i,0));
4612         right = SvIV(*av_fetch(rav,i,0));
4613         if ( left < right  )
4614             retval = -1;
4615         if ( left > right )
4616             retval = +1;
4617         i++;
4618     }
4619
4620     /* tiebreaker for alpha with identical terms */
4621     if ( retval == 0 && l == r && left == right && ( lalpha || ralpha ) )
4622     {
4623         if ( lalpha && !ralpha )
4624         {
4625             retval = -1;
4626         }
4627         else if ( ralpha && !lalpha)
4628         {
4629             retval = +1;
4630         }
4631     }
4632
4633     if ( l != r && retval == 0 ) /* possible match except for trailing 0's */
4634     {
4635         if ( l < r )
4636         {
4637             while ( i <= r && retval == 0 )
4638             {
4639                 if ( SvIV(*av_fetch(rav,i,0)) != 0 )
4640                     retval = -1; /* not a match after all */
4641                 i++;
4642             }
4643         }
4644         else
4645         {
4646             while ( i <= l && retval == 0 )
4647             {
4648                 if ( SvIV(*av_fetch(lav,i,0)) != 0 )
4649                     retval = +1; /* not a match after all */
4650                 i++;
4651             }
4652         }
4653     }
4654     return retval;
4655 }
4656
4657 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET) && defined(SOCK_DGRAM) && defined(HAS_SELECT)
4658 #   define EMULATE_SOCKETPAIR_UDP
4659 #endif
4660
4661 #ifdef EMULATE_SOCKETPAIR_UDP
4662 static int
4663 S_socketpair_udp (int fd[2]) {
4664     dTHX;
4665     /* Fake a datagram socketpair using UDP to localhost.  */
4666     int sockets[2] = {-1, -1};
4667     struct sockaddr_in addresses[2];
4668     int i;
4669     Sock_size_t size = sizeof(struct sockaddr_in);
4670     unsigned short port;
4671     int got;
4672
4673     memset(&addresses, 0, sizeof(addresses));
4674     i = 1;
4675     do {
4676         sockets[i] = PerlSock_socket(AF_INET, SOCK_DGRAM, PF_INET);
4677         if (sockets[i] == -1)
4678             goto tidy_up_and_fail;
4679
4680         addresses[i].sin_family = AF_INET;
4681         addresses[i].sin_addr.s_addr = htonl(INADDR_LOOPBACK);
4682         addresses[i].sin_port = 0;      /* kernel choses port.  */
4683         if (PerlSock_bind(sockets[i], (struct sockaddr *) &addresses[i],
4684                 sizeof(struct sockaddr_in)) == -1)
4685             goto tidy_up_and_fail;
4686     } while (i--);
4687
4688     /* Now have 2 UDP sockets. Find out which port each is connected to, and
4689        for each connect the other socket to it.  */
4690     i = 1;
4691     do {
4692         if (PerlSock_getsockname(sockets[i], (struct sockaddr *) &addresses[i],
4693                 &size) == -1)
4694             goto tidy_up_and_fail;
4695         if (size != sizeof(struct sockaddr_in))
4696             goto abort_tidy_up_and_fail;
4697         /* !1 is 0, !0 is 1 */
4698         if (PerlSock_connect(sockets[!i], (struct sockaddr *) &addresses[i],
4699                 sizeof(struct sockaddr_in)) == -1)
4700             goto tidy_up_and_fail;
4701     } while (i--);
4702
4703     /* Now we have 2 sockets connected to each other. I don't trust some other
4704        process not to have already sent a packet to us (by random) so send
4705        a packet from each to the other.  */
4706     i = 1;
4707     do {
4708         /* I'm going to send my own port number.  As a short.
4709            (Who knows if someone somewhere has sin_port as a bitfield and needs
4710            this routine. (I'm assuming crays have socketpair)) */
4711         port = addresses[i].sin_port;
4712         got = PerlLIO_write(sockets[i], &port, sizeof(port));
4713         if (got != sizeof(port)) {
4714             if (got == -1)
4715                 goto tidy_up_and_fail;
4716             goto abort_tidy_up_and_fail;
4717         }
4718     } while (i--);
4719
4720     /* Packets sent. I don't trust them to have arrived though.
4721        (As I understand it Solaris TCP stack is multithreaded. Non-blocking
4722        connect to localhost will use a second kernel thread. In 2.6 the
4723        first thread running the connect() returns before the second completes,
4724        so EINPROGRESS> In 2.7 the improved stack is faster and connect()
4725        returns 0. Poor programs have tripped up. One poor program's authors'
4726        had a 50-1 reverse stock split. Not sure how connected these were.)
4727        So I don't trust someone not to have an unpredictable UDP stack.
4728     */
4729
4730     {
4731         struct timeval waitfor = {0, 100000}; /* You have 0.1 seconds */
4732         int max = sockets[1] > sockets[0] ? sockets[1] : sockets[0];
4733         fd_set rset;
4734
4735         FD_ZERO(&rset);
4736         FD_SET((unsigned int)sockets[0], &rset);
4737         FD_SET((unsigned int)sockets[1], &rset);
4738
4739         got = PerlSock_select(max + 1, &rset, NULL, NULL, &waitfor);
4740         if (got != 2 || !FD_ISSET(sockets[0], &rset)
4741                 || !FD_ISSET(sockets[1], &rset)) {
4742             /* I hope this is portable and appropriate.  */
4743             if (got == -1)
4744                 goto tidy_up_and_fail;
4745             goto abort_tidy_up_and_fail;
4746         }
4747     }
4748
4749     /* And the paranoia department even now doesn't trust it to have arrive
4750        (hence MSG_DONTWAIT). Or that what arrives was sent by us.  */
4751     {
4752         struct sockaddr_in readfrom;
4753         unsigned short buffer[2];
4754
4755         i = 1;
4756         do {
4757 #ifdef MSG_DONTWAIT
4758             got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
4759                     sizeof(buffer), MSG_DONTWAIT,
4760                     (struct sockaddr *) &readfrom, &size);
4761 #else
4762             got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
4763                     sizeof(buffer), 0,
4764                     (struct sockaddr *) &readfrom, &size);
4765 #endif
4766
4767             if (got == -1)
4768                 goto tidy_up_and_fail;
4769             if (got != sizeof(port)
4770                     || size != sizeof(struct sockaddr_in)
4771                     /* Check other socket sent us its port.  */
4772                     || buffer[0] != (unsigned short) addresses[!i].sin_port
4773                     /* Check kernel says we got the datagram from that socket */
4774                     || readfrom.sin_family != addresses[!i].sin_family
4775                     || readfrom.sin_addr.s_addr != addresses[!i].sin_addr.s_addr
4776                     || readfrom.sin_port != addresses[!i].sin_port)
4777                 goto abort_tidy_up_and_fail;
4778         } while (i--);
4779     }
4780     /* My caller (my_socketpair) has validated that this is non-NULL  */
4781     fd[0] = sockets[0];
4782     fd[1] = sockets[1];
4783     /* I hereby declare this connection open.  May God bless all who cross
4784        her.  */
4785     return 0;
4786
4787   abort_tidy_up_and_fail:
4788     errno = ECONNABORTED;
4789   tidy_up_and_fail:
4790     {
4791         const int save_errno = errno;
4792         if (sockets[0] != -1)
4793             PerlLIO_close(sockets[0]);
4794         if (sockets[1] != -1)
4795             PerlLIO_close(sockets[1]);
4796         errno = save_errno;
4797         return -1;
4798     }
4799 }
4800 #endif /*  EMULATE_SOCKETPAIR_UDP */
4801
4802 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET)
4803 int
4804 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
4805     /* Stevens says that family must be AF_LOCAL, protocol 0.
4806        I'm going to enforce that, then ignore it, and use TCP (or UDP).  */
4807     dTHX;
4808     int listener = -1;
4809     int connector = -1;
4810     int acceptor = -1;
4811     struct sockaddr_in listen_addr;
4812     struct sockaddr_in connect_addr;
4813     Sock_size_t size;
4814
4815     if (protocol
4816 #ifdef AF_UNIX
4817         || family != AF_UNIX
4818 #endif
4819     ) {
4820         errno = EAFNOSUPPORT;
4821         return -1;
4822     }
4823     if (!fd) {
4824         errno = EINVAL;
4825         return -1;
4826     }
4827
4828 #ifdef EMULATE_SOCKETPAIR_UDP
4829     if (type == SOCK_DGRAM)
4830         return S_socketpair_udp(fd);
4831 #endif
4832
4833     listener = PerlSock_socket(AF_INET, type, 0);
4834     if (listener == -1)
4835         return -1;
4836     memset(&listen_addr, 0, sizeof(listen_addr));
4837     listen_addr.sin_family = AF_INET;
4838     listen_addr.sin_addr.s_addr = htonl(INADDR_LOOPBACK);
4839     listen_addr.sin_port = 0;   /* kernel choses port.  */
4840     if (PerlSock_bind(listener, (struct sockaddr *) &listen_addr,
4841             sizeof(listen_addr)) == -1)
4842         goto tidy_up_and_fail;
4843     if (PerlSock_listen(listener, 1) == -1)
4844         goto tidy_up_and_fail;
4845
4846     connector = PerlSock_socket(AF_INET, type, 0);
4847     if (connector == -1)
4848         goto tidy_up_and_fail;
4849     /* We want to find out the port number to connect to.  */
4850     size = sizeof(connect_addr);
4851     if (PerlSock_getsockname(listener, (struct sockaddr *) &connect_addr,
4852             &size) == -1)
4853         goto tidy_up_and_fail;
4854     if (size != sizeof(connect_addr))
4855         goto abort_tidy_up_and_fail;
4856     if (PerlSock_connect(connector, (struct sockaddr *) &connect_addr,
4857             sizeof(connect_addr)) == -1)
4858         goto tidy_up_and_fail;
4859
4860     size = sizeof(listen_addr);
4861     acceptor = PerlSock_accept(listener, (struct sockaddr *) &listen_addr,
4862             &size);
4863     if (acceptor == -1)
4864         goto tidy_up_and_fail;
4865     if (size != sizeof(listen_addr))
4866         goto abort_tidy_up_and_fail;
4867     PerlLIO_close(listener);
4868     /* Now check we are talking to ourself by matching port and host on the
4869        two sockets.  */
4870     if (PerlSock_getsockname(connector, (struct sockaddr *) &connect_addr,
4871             &size) == -1)
4872         goto tidy_up_and_fail;
4873     if (size != sizeof(connect_addr)
4874             || listen_addr.sin_family != connect_addr.sin_family
4875             || listen_addr.sin_addr.s_addr != connect_addr.sin_addr.s_addr
4876             || listen_addr.sin_port != connect_addr.sin_port) {
4877         goto abort_tidy_up_and_fail;
4878     }
4879     fd[0] = connector;
4880     fd[1] = acceptor;
4881     return 0;
4882
4883   abort_tidy_up_and_fail:
4884 #ifdef ECONNABORTED
4885   errno = ECONNABORTED; /* This would be the standard thing to do. */
4886 #else
4887 #  ifdef ECONNREFUSED
4888   errno = ECONNREFUSED; /* E.g. Symbian does not have ECONNABORTED. */
4889 #  else
4890   errno = ETIMEDOUT;    /* Desperation time. */
4891 #  endif
4892 #endif
4893   tidy_up_and_fail:
4894     {
4895         const int save_errno = errno;
4896         if (listener != -1)
4897             PerlLIO_close(listener);
4898         if (connector != -1)
4899             PerlLIO_close(connector);
4900         if (acceptor != -1)
4901             PerlLIO_close(acceptor);
4902         errno = save_errno;
4903         return -1;
4904     }
4905 }
4906 #else
4907 /* In any case have a stub so that there's code corresponding
4908  * to the my_socketpair in global.sym. */
4909 int
4910 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
4911 #ifdef HAS_SOCKETPAIR
4912     return socketpair(family, type, protocol, fd);
4913 #else
4914     return -1;
4915 #endif
4916 }
4917 #endif
4918
4919 /*
4920
4921 =for apidoc sv_nosharing
4922
4923 Dummy routine which "shares" an SV when there is no sharing module present.
4924 Or "locks" it. Or "unlocks" it. In other words, ignores its single SV argument.
4925 Exists to avoid test for a NULL function pointer and because it could
4926 potentially warn under some level of strict-ness.
4927
4928 =cut
4929 */
4930
4931 void
4932 Perl_sv_nosharing(pTHX_ SV *sv)
4933 {
4934     PERL_UNUSED_CONTEXT;
4935     PERL_UNUSED_ARG(sv);
4936 }
4937
4938 U32
4939 Perl_parse_unicode_opts(pTHX_ const char **popt)
4940 {
4941   const char *p = *popt;
4942   U32 opt = 0;
4943
4944   if (*p) {
4945        if (isDIGIT(*p)) {
4946             opt = (U32) atoi(p);
4947             while (isDIGIT(*p))
4948                 p++;
4949             if (*p && *p != '\n' && *p != '\r')
4950                  Perl_croak(aTHX_ "Unknown Unicode option letter '%c'", *p);
4951        }
4952        else {
4953             for (; *p; p++) {
4954                  switch (*p) {
4955                  case PERL_UNICODE_STDIN:
4956                       opt |= PERL_UNICODE_STDIN_FLAG;   break;
4957                  case PERL_UNICODE_STDOUT:
4958                       opt |= PERL_UNICODE_STDOUT_FLAG;  break;
4959                  case PERL_UNICODE_STDERR:
4960                       opt |= PERL_UNICODE_STDERR_FLAG;  break;
4961                  case PERL_UNICODE_STD:
4962                       opt |= PERL_UNICODE_STD_FLAG;     break;
4963                  case PERL_UNICODE_IN:
4964                       opt |= PERL_UNICODE_IN_FLAG;      break;
4965                  case PERL_UNICODE_OUT:
4966                       opt |= PERL_UNICODE_OUT_FLAG;     break;
4967                  case PERL_UNICODE_INOUT:
4968                       opt |= PERL_UNICODE_INOUT_FLAG;   break;
4969                  case PERL_UNICODE_LOCALE:
4970                       opt |= PERL_UNICODE_LOCALE_FLAG;  break;
4971                  case PERL_UNICODE_ARGV:
4972                       opt |= PERL_UNICODE_ARGV_FLAG;    break;
4973                  case PERL_UNICODE_UTF8CACHEASSERT:
4974                       opt |= PERL_UNICODE_UTF8CACHEASSERT_FLAG; break;
4975                  default:
4976                       if (*p != '\n' && *p != '\r')
4977                           Perl_croak(aTHX_
4978                                      "Unknown Unicode option letter '%c'", *p);
4979                  }
4980             }
4981        }
4982   }
4983   else
4984        opt = PERL_UNICODE_DEFAULT_FLAGS;
4985
4986   if (opt & ~PERL_UNICODE_ALL_FLAGS)
4987        Perl_croak(aTHX_ "Unknown Unicode option value %"UVuf,
4988                   (UV) (opt & ~PERL_UNICODE_ALL_FLAGS));
4989
4990   *popt = p;
4991
4992   return opt;
4993 }
4994
4995 U32
4996 Perl_seed(pTHX)
4997 {
4998     dVAR;
4999     /*
5000      * This is really just a quick hack which grabs various garbage
5001      * values.  It really should be a real hash algorithm which
5002      * spreads the effect of every input bit onto every output bit,
5003      * if someone who knows about such things would bother to write it.
5004      * Might be a good idea to add that function to CORE as well.
5005      * No numbers below come from careful analysis or anything here,
5006      * except they are primes and SEED_C1 > 1E6 to get a full-width
5007      * value from (tv_sec * SEED_C1 + tv_usec).  The multipliers should
5008      * probably be bigger too.
5009      */
5010 #if RANDBITS > 16
5011 #  define SEED_C1       1000003
5012 #define   SEED_C4       73819
5013 #else
5014 #  define SEED_C1       25747
5015 #define   SEED_C4       20639
5016 #endif
5017 #define   SEED_C2       3
5018 #define   SEED_C3       269
5019 #define   SEED_C5       26107
5020
5021 #ifndef PERL_NO_DEV_RANDOM
5022     int fd;
5023 #endif
5024     U32 u;
5025 #ifdef VMS
5026 #  include <starlet.h>
5027     /* when[] = (low 32 bits, high 32 bits) of time since epoch
5028      * in 100-ns units, typically incremented ever 10 ms.        */
5029     unsigned int when[2];
5030 #else
5031 #  ifdef HAS_GETTIMEOFDAY
5032     struct timeval when;
5033 #  else
5034     Time_t when;
5035 #  endif
5036 #endif
5037
5038 /* This test is an escape hatch, this symbol isn't set by Configure. */
5039 #ifndef PERL_NO_DEV_RANDOM
5040 #ifndef PERL_RANDOM_DEVICE
5041    /* /dev/random isn't used by default because reads from it will block
5042     * if there isn't enough entropy available.  You can compile with
5043     * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
5044     * is enough real entropy to fill the seed. */
5045 #  define PERL_RANDOM_DEVICE "/dev/urandom"
5046 #endif
5047     fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
5048     if (fd != -1) {
5049         if (PerlLIO_read(fd, (void*)&u, sizeof u) != sizeof u)
5050             u = 0;
5051         PerlLIO_close(fd);
5052         if (u)
5053             return u;
5054     }
5055 #endif
5056
5057 #ifdef VMS
5058     _ckvmssts(sys$gettim(when));
5059     u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
5060 #else
5061 #  ifdef HAS_GETTIMEOFDAY
5062     PerlProc_gettimeofday(&when,NULL);
5063     u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
5064 #  else
5065     (void)time(&when);
5066     u = (U32)SEED_C1 * when;
5067 #  endif
5068 #endif
5069     u += SEED_C3 * (U32)PerlProc_getpid();
5070     u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
5071 #ifndef PLAN9           /* XXX Plan9 assembler chokes on this; fix needed  */
5072     u += SEED_C5 * (U32)PTR2UV(&when);
5073 #endif
5074     return u;
5075 }
5076
5077 UV
5078 Perl_get_hash_seed(pTHX)
5079 {
5080     dVAR;
5081      const char *s = PerlEnv_getenv("PERL_HASH_SEED");
5082      UV myseed = 0;
5083
5084      if (s)
5085         while (isSPACE(*s))
5086             s++;
5087      if (s && isDIGIT(*s))
5088           myseed = (UV)Atoul(s);
5089      else
5090 #ifdef USE_HASH_SEED_EXPLICIT
5091      if (s)
5092 #endif
5093      {
5094           /* Compute a random seed */
5095           (void)seedDrand01((Rand_seed_t)seed());
5096           myseed = (UV)(Drand01() * (NV)UV_MAX);
5097 #if RANDBITS < (UVSIZE * 8)
5098           /* Since there are not enough randbits to to reach all
5099            * the bits of a UV, the low bits might need extra
5100            * help.  Sum in another random number that will
5101            * fill in the low bits. */
5102           myseed +=
5103                (UV)(Drand01() * (NV)((1 << ((UVSIZE * 8 - RANDBITS))) - 1));
5104 #endif /* RANDBITS < (UVSIZE * 8) */
5105           if (myseed == 0) { /* Superparanoia. */
5106               myseed = (UV)(Drand01() * (NV)UV_MAX); /* One more chance. */
5107               if (myseed == 0)
5108                   Perl_croak(aTHX_ "Your random numbers are not that random");
5109           }
5110      }
5111      PL_rehash_seed_set = TRUE;
5112
5113      return myseed;
5114 }
5115
5116 #ifdef USE_ITHREADS
5117 bool
5118 Perl_stashpv_hvname_match(pTHX_ const COP *c, const HV *hv)
5119 {
5120     const char * const stashpv = CopSTASHPV(c);
5121     const char * const name = HvNAME_get(hv);
5122     PERL_UNUSED_CONTEXT;
5123
5124     if (stashpv == name)
5125         return TRUE;
5126     if (stashpv && name)
5127         if (strEQ(stashpv, name))
5128             return TRUE;
5129     return FALSE;
5130 }
5131 #endif
5132
5133
5134 #ifdef PERL_GLOBAL_STRUCT
5135
5136 struct perl_vars *
5137 Perl_init_global_struct(pTHX)
5138 {
5139     struct perl_vars *plvarsp = NULL;
5140 #ifdef PERL_GLOBAL_STRUCT
5141 #  define PERL_GLOBAL_STRUCT_INIT
5142 #  include "opcode.h" /* the ppaddr and check */
5143     const IV nppaddr = sizeof(Gppaddr)/sizeof(Perl_ppaddr_t);
5144     const IV ncheck  = sizeof(Gcheck) /sizeof(Perl_check_t);
5145 #  ifdef PERL_GLOBAL_STRUCT_PRIVATE
5146     /* PerlMem_malloc() because can't use even safesysmalloc() this early. */
5147     plvarsp = (struct perl_vars*)PerlMem_malloc(sizeof(struct perl_vars));
5148     if (!plvarsp)
5149         exit(1);
5150 #  else
5151     plvarsp = PL_VarsPtr;
5152 #  endif /* PERL_GLOBAL_STRUCT_PRIVATE */
5153 #  undef PERLVAR
5154 #  undef PERLVARA
5155 #  undef PERLVARI
5156 #  undef PERLVARIC
5157 #  undef PERLVARISC
5158 #  define PERLVAR(var,type) /**/
5159 #  define PERLVARA(var,n,type) /**/
5160 #  define PERLVARI(var,type,init) plvarsp->var = init;
5161 #  define PERLVARIC(var,type,init) plvarsp->var = init;
5162 #  define PERLVARISC(var,init) Copy(init, plvarsp->var, sizeof(init), char);
5163 #  include "perlvars.h"
5164 #  undef PERLVAR
5165 #  undef PERLVARA
5166 #  undef PERLVARI
5167 #  undef PERLVARIC
5168 #  undef PERLVARISC
5169 #  ifdef PERL_GLOBAL_STRUCT
5170     plvarsp->Gppaddr = PerlMem_malloc(nppaddr * sizeof(Perl_ppaddr_t));
5171     if (!plvarsp->Gppaddr)
5172         exit(1);
5173     plvarsp->Gcheck  = PerlMem_malloc(ncheck  * sizeof(Perl_check_t));
5174     if (!plvarsp->Gcheck)
5175         exit(1);
5176     Copy(Gppaddr, plvarsp->Gppaddr, nppaddr, Perl_ppaddr_t);
5177     Copy(Gcheck,  plvarsp->Gcheck,  ncheck,  Perl_check_t);
5178 #  endif
5179 #  ifdef PERL_SET_VARS
5180     PERL_SET_VARS(plvarsp);
5181 #  endif
5182 #  undef PERL_GLOBAL_STRUCT_INIT
5183 #endif
5184     return plvarsp;
5185 }
5186
5187 #endif /* PERL_GLOBAL_STRUCT */
5188
5189 #ifdef PERL_GLOBAL_STRUCT
5190
5191 void
5192 Perl_free_global_struct(pTHX_ struct perl_vars *plvarsp)
5193 {
5194 #ifdef PERL_GLOBAL_STRUCT
5195 #  ifdef PERL_UNSET_VARS
5196     PERL_UNSET_VARS(plvarsp);
5197 #  endif
5198     free(plvarsp->Gppaddr);
5199     free(plvarsp->Gcheck);
5200 #    ifdef PERL_GLOBAL_STRUCT_PRIVATE
5201     free(plvarsp);
5202 #    endif
5203 #endif
5204 }
5205
5206 #endif /* PERL_GLOBAL_STRUCT */
5207
5208 #ifdef PERL_MEM_LOG
5209
5210 /*
5211  * PERL_MEM_LOG: the Perl_mem_log_..() will be compiled.
5212  *
5213  * PERL_MEM_LOG_ENV: if defined, during run time the environment
5214  * variable PERL_MEM_LOG will be consulted, and if the integer value
5215  * of that is true, the logging will happen.  (The default is to
5216  * always log if the PERL_MEM_LOG define was in effect.)
5217  */
5218
5219 /*
5220  * PERL_MEM_LOG_SPRINTF_BUF_SIZE: size of a (stack-allocated) buffer
5221  * the Perl_mem_log_...() will use (either via sprintf or snprintf).
5222  */
5223 #define PERL_MEM_LOG_SPRINTF_BUF_SIZE 128
5224
5225 /*
5226  * PERL_MEM_LOG_FD: the file descriptor the Perl_mem_log_...() will
5227  * log to.  You can also define in compile time PERL_MEM_LOG_ENV_FD,
5228  * in which case the environment variable PERL_MEM_LOG_FD will be
5229  * consulted for the file descriptor number to use.
5230  */
5231 #ifndef PERL_MEM_LOG_FD
5232 #  define PERL_MEM_LOG_FD 2 /* If STDERR is too boring for you. */
5233 #endif
5234
5235 Malloc_t
5236 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)
5237 {
5238 #ifdef PERL_MEM_LOG_STDERR
5239 # if defined(PERL_MEM_LOG_ENV) || defined(PERL_MEM_LOG_ENV_FD)
5240     char *s;
5241 # endif
5242 # ifdef PERL_MEM_LOG_ENV
5243     s = getenv("PERL_MEM_LOG");
5244     if (s ? atoi(s) : 0)
5245 # endif
5246     {
5247         /* We can't use SVs or PerlIO for obvious reasons,
5248          * so we'll use stdio and low-level IO instead. */
5249         char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE];
5250 # ifdef PERL_MEM_LOG_TIMESTAMP
5251         struct timeval tv;
5252 #   ifdef HAS_GETTIMEOFDAY
5253         gettimeofday(&tv, 0);
5254 #   endif
5255         /* If there are other OS specific ways of hires time than
5256          * gettimeofday() (see ext/Time/HiRes), the easiest way is
5257          * probably that they would be used to fill in the struct
5258          * timeval. */
5259 # endif
5260         {
5261             const STRLEN len =
5262                 my_snprintf(buf,
5263                             sizeof(buf),
5264 #  ifdef PERL_MEM_LOG_TIMESTAMP
5265                             "%10d.%06d: "
5266 # endif
5267                             "alloc: %s:%d:%s: %"IVdf" %"UVuf
5268                             " %s = %"IVdf": %"UVxf"\n",
5269 #  ifdef PERL_MEM_LOG_TIMESTAMP
5270                             (int)tv.tv_sec, (int)tv.tv_usec,
5271 # endif
5272                             filename, linenumber, funcname, n, typesize,
5273                             typename, n * typesize, PTR2UV(newalloc));
5274 # ifdef PERL_MEM_LOG_ENV_FD
5275             s = PerlEnv_getenv("PERL_MEM_LOG_FD");
5276             PerlLIO_write(s ? atoi(s) : PERL_MEM_LOG_FD, buf, len);
5277 # else
5278             PerlLIO_write(PERL_MEM_LOG_FD, buf, len);
5279 #endif
5280         }
5281     }
5282 #endif
5283     return newalloc;
5284 }
5285
5286 Malloc_t
5287 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)
5288 {
5289 #ifdef PERL_MEM_LOG_STDERR
5290 # if defined(PERL_MEM_LOG_ENV) || defined(PERL_MEM_LOG_ENV_FD)
5291     char *s;
5292 # endif
5293 # ifdef PERL_MEM_LOG_ENV
5294     s = PerlEnv_getenv("PERL_MEM_LOG");
5295     if (s ? atoi(s) : 0)
5296 # endif
5297     {
5298         /* We can't use SVs or PerlIO for obvious reasons,
5299          * so we'll use stdio and low-level IO instead. */
5300         char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE];
5301 #  ifdef PERL_MEM_LOG_TIMESTAMP
5302         struct timeval tv;
5303         gettimeofday(&tv, 0);
5304 # endif
5305         {
5306             const STRLEN len =
5307                 my_snprintf(buf,
5308                             sizeof(buf),
5309 #  ifdef PERL_MEM_LOG_TIMESTAMP
5310                             "%10d.%06d: "
5311 # endif
5312                             "realloc: %s:%d:%s: %"IVdf" %"UVuf
5313                             " %s = %"IVdf": %"UVxf" -> %"UVxf"\n",
5314 #  ifdef PERL_MEM_LOG_TIMESTAMP
5315                             (int)tv.tv_sec, (int)tv.tv_usec,
5316 # endif
5317                             filename, linenumber, funcname, n, typesize,
5318                             typename, n * typesize, PTR2UV(oldalloc),
5319                             PTR2UV(newalloc));
5320 # ifdef PERL_MEM_LOG_ENV_FD
5321             s = PerlEnv_getenv("PERL_MEM_LOG_FD");
5322             PerlLIO_write(s ? atoi(s) : PERL_MEM_LOG_FD, buf, len);
5323 # else
5324             PerlLIO_write(PERL_MEM_LOG_FD, buf, len);
5325 # endif
5326         }
5327     }
5328 #endif
5329     return newalloc;
5330 }
5331
5332 Malloc_t
5333 Perl_mem_log_free(Malloc_t oldalloc, const char *filename, const int linenumber, const char *funcname)
5334 {
5335 #ifdef PERL_MEM_LOG_STDERR
5336 # if defined(PERL_MEM_LOG_ENV) || defined(PERL_MEM_LOG_ENV_FD)
5337     char *s;
5338 # endif
5339 # ifdef PERL_MEM_LOG_ENV
5340     s = PerlEnv_getenv("PERL_MEM_LOG");
5341     if (s ? atoi(s) : 0)
5342 # endif
5343     {
5344         /* We can't use SVs or PerlIO for obvious reasons,
5345          * so we'll use stdio and low-level IO instead. */
5346         char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE];
5347 #  ifdef PERL_MEM_LOG_TIMESTAMP
5348         struct timeval tv;
5349         gettimeofday(&tv, 0);
5350 # endif
5351         {
5352             const STRLEN len =
5353                 my_snprintf(buf,
5354                             sizeof(buf),
5355 #  ifdef PERL_MEM_LOG_TIMESTAMP
5356                             "%10d.%06d: "
5357 # endif
5358                             "free: %s:%d:%s: %"UVxf"\n",
5359 #  ifdef PERL_MEM_LOG_TIMESTAMP
5360                             (int)tv.tv_sec, (int)tv.tv_usec,
5361 # endif
5362                             filename, linenumber, funcname,
5363                             PTR2UV(oldalloc));
5364 # ifdef PERL_MEM_LOG_ENV_FD
5365             s = PerlEnv_getenv("PERL_MEM_LOG_FD");
5366             PerlLIO_write(s ? atoi(s) : PERL_MEM_LOG_FD, buf, len);
5367 # else
5368             PerlLIO_write(PERL_MEM_LOG_FD, buf, len);
5369 # endif
5370         }
5371     }
5372 #endif
5373     return oldalloc;
5374 }
5375
5376 #endif /* PERL_MEM_LOG */
5377
5378 /*
5379 =for apidoc my_sprintf
5380
5381 The C library C<sprintf>, wrapped if necessary, to ensure that it will return
5382 the length of the string written to the buffer. Only rare pre-ANSI systems
5383 need the wrapper function - usually this is a direct call to C<sprintf>.
5384
5385 =cut
5386 */
5387 #ifndef SPRINTF_RETURNS_STRLEN
5388 int
5389 Perl_my_sprintf(char *buffer, const char* pat, ...)
5390 {
5391     va_list args;
5392     va_start(args, pat);
5393     vsprintf(buffer, pat, args);
5394     va_end(args);
5395     return strlen(buffer);
5396 }
5397 #endif
5398
5399 /*
5400 =for apidoc my_snprintf
5401
5402 The C library C<snprintf> functionality, if available and
5403 standards-compliant (uses C<vsnprintf>, actually).  However, if the
5404 C<vsnprintf> is not available, will unfortunately use the unsafe
5405 C<vsprintf> which can overrun the buffer (there is an overrun check,
5406 but that may be too late).  Consider using C<sv_vcatpvf> instead, or
5407 getting C<vsnprintf>.
5408
5409 =cut
5410 */
5411 int
5412 Perl_my_snprintf(char *buffer, const Size_t len, const char *format, ...)
5413 {
5414     dTHX;
5415     int retval;
5416     va_list ap;
5417     va_start(ap, format);
5418 #ifdef HAS_VSNPRINTF
5419     retval = vsnprintf(buffer, len, format, ap);
5420 #else
5421     retval = vsprintf(buffer, format, ap);
5422 #endif
5423     va_end(ap);
5424     /* vsnprintf() shows failure with >= len, vsprintf() with < 0 */
5425     if (retval < 0 || (len > 0 && (Size_t)retval >= len))
5426         Perl_croak(aTHX_ "panic: my_snprintf buffer overflow");
5427     return retval;
5428 }
5429
5430 /*
5431 =for apidoc my_vsnprintf
5432
5433 The C library C<vsnprintf> if available and standards-compliant.
5434 However, if if the C<vsnprintf> is not available, will unfortunately
5435 use the unsafe C<vsprintf> which can overrun the buffer (there is an
5436 overrun check, but that may be too late).  Consider using
5437 C<sv_vcatpvf> instead, or getting C<vsnprintf>.
5438
5439 =cut
5440 */
5441 int
5442 Perl_my_vsnprintf(char *buffer, const Size_t len, const char *format, va_list ap)
5443 {
5444     dTHX;
5445     int retval;
5446 #ifdef NEED_VA_COPY
5447     va_list apc;
5448     Perl_va_copy(ap, apc);
5449 # ifdef HAS_VSNPRINTF
5450     retval = vsnprintf(buffer, len, format, apc);
5451 # else
5452     retval = vsprintf(buffer, format, apc);
5453 # endif
5454 #else
5455 # ifdef HAS_VSNPRINTF
5456     retval = vsnprintf(buffer, len, format, ap);
5457 # else
5458     retval = vsprintf(buffer, format, ap);
5459 # endif
5460 #endif /* #ifdef NEED_VA_COPY */
5461     /* vsnprintf() shows failure with >= len, vsprintf() with < 0 */
5462     if (retval < 0 || (len > 0 && (Size_t)retval >= len))
5463         Perl_croak(aTHX_ "panic: my_vsnprintf buffer overflow");
5464     return retval;
5465 }
5466
5467 void
5468 Perl_my_clearenv(pTHX)
5469 {
5470     dVAR;
5471 #if ! defined(PERL_MICRO)
5472 #  if defined(PERL_IMPLICIT_SYS) || defined(WIN32)
5473     PerlEnv_clearenv();
5474 #  else /* ! (PERL_IMPLICIT_SYS || WIN32) */
5475 #    if defined(USE_ENVIRON_ARRAY)
5476 #      if defined(USE_ITHREADS)
5477     /* only the parent thread can clobber the process environment */
5478     if (PL_curinterp == aTHX)
5479 #      endif /* USE_ITHREADS */
5480     {
5481 #      if ! defined(PERL_USE_SAFE_PUTENV)
5482     if ( !PL_use_safe_putenv) {
5483       I32 i;
5484       if (environ == PL_origenviron)
5485         environ = (char**)safesysmalloc(sizeof(char*));
5486       else
5487         for (i = 0; environ[i]; i++)
5488           (void)safesysfree(environ[i]);
5489     }
5490     environ[0] = NULL;
5491 #      else /* PERL_USE_SAFE_PUTENV */
5492 #        if defined(HAS_CLEARENV)
5493     (void)clearenv();
5494 #        elif defined(HAS_UNSETENV)
5495     int bsiz = 80; /* Most envvar names will be shorter than this. */
5496     int bufsiz = bsiz * sizeof(char); /* sizeof(char) paranoid? */
5497     char *buf = (char*)safesysmalloc(bufsiz);
5498     while (*environ != NULL) {
5499       char *e = strchr(*environ, '=');
5500       int l = e ? e - *environ : (int)strlen(*environ);
5501       if (bsiz < l + 1) {
5502         (void)safesysfree(buf);
5503         bsiz = l + 1; /* + 1 for the \0. */
5504         buf = (char*)safesysmalloc(bufsiz);
5505       }
5506       my_strlcpy(buf, *environ, l + 1);
5507       (void)unsetenv(buf);
5508     }
5509     (void)safesysfree(buf);
5510 #        else /* ! HAS_CLEARENV && ! HAS_UNSETENV */
5511     /* Just null environ and accept the leakage. */
5512     *environ = NULL;
5513 #        endif /* HAS_CLEARENV || HAS_UNSETENV */
5514 #      endif /* ! PERL_USE_SAFE_PUTENV */
5515     }
5516 #    endif /* USE_ENVIRON_ARRAY */
5517 #  endif /* PERL_IMPLICIT_SYS || WIN32 */
5518 #endif /* PERL_MICRO */
5519 }
5520
5521 #ifdef PERL_IMPLICIT_CONTEXT
5522
5523 /* implements the MY_CXT_INIT macro. The first time a module is loaded,
5524 the global PL_my_cxt_index is incremented, and that value is assigned to
5525 that module's static my_cxt_index (who's address is passed as an arg).
5526 Then, for each interpreter this function is called for, it makes sure a
5527 void* slot is available to hang the static data off, by allocating or
5528 extending the interpreter's PL_my_cxt_list array */
5529
5530 void *
5531 Perl_my_cxt_init(pTHX_ int *index, size_t size)
5532 {
5533     dVAR;
5534     void *p;
5535     if (*index == -1) {
5536         /* this module hasn't been allocated an index yet */
5537         MUTEX_LOCK(&PL_my_ctx_mutex);
5538         *index = PL_my_cxt_index++;
5539         MUTEX_UNLOCK(&PL_my_ctx_mutex);
5540     }
5541
5542     /* make sure the array is big enough */
5543     if (PL_my_cxt_size <= *index) {
5544         if (PL_my_cxt_size) {
5545             while (PL_my_cxt_size <= *index)
5546                 PL_my_cxt_size *= 2;
5547             Renew(PL_my_cxt_list, PL_my_cxt_size, void *);
5548         }
5549         else {
5550             PL_my_cxt_size = 16;
5551             Newx(PL_my_cxt_list, PL_my_cxt_size, void *);
5552         }
5553     }
5554     /* newSV() allocates one more than needed */
5555     p = (void*)SvPVX(newSV(size-1));
5556     PL_my_cxt_list[*index] = p;
5557     Zero(p, size, char);
5558     return p;
5559 }
5560 #endif
5561
5562 #ifndef HAS_STRLCAT
5563 Size_t
5564 Perl_my_strlcat(char *dst, const char *src, Size_t size)
5565 {
5566     Size_t used, length, copy;
5567
5568     used = strlen(dst);
5569     length = strlen(src);
5570     if (size > 0 && used < size - 1) {
5571         copy = (length >= size - used) ? size - used - 1 : length;
5572         memcpy(dst + used, src, copy);
5573         dst[used + copy] = '\0';
5574     }
5575     return used + length;
5576 }
5577 #endif
5578
5579 #ifndef HAS_STRLCPY
5580 Size_t
5581 Perl_my_strlcpy(char *dst, const char *src, Size_t size)
5582 {
5583     Size_t length, copy;
5584
5585     length = strlen(src);
5586     if (size > 0) {
5587         copy = (length >= size) ? size - 1 : length;
5588         memcpy(dst, src, copy);
5589         dst[copy] = '\0';
5590     }
5591     return length;
5592 }
5593 #endif
5594
5595 void
5596 Perl_get_db_sub(pTHX_ SV **svp, CV *cv)
5597 {
5598     dVAR;
5599     SV * const dbsv = GvSVn(PL_DBsub);
5600     /* We do not care about using sv to call CV;
5601      * it's for informational purposes only.
5602      */
5603
5604     save_item(dbsv);
5605     if (!PERLDB_SUB_NN) {
5606         GV * const gv = CvGV(cv);
5607
5608         if ( svp && ((CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
5609              || strEQ(GvNAME(gv), "END")
5610              || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
5611                  !( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((GV*)*svp) == cv) )))) {
5612             /* Use GV from the stack as a fallback. */
5613             /* GV is potentially non-unique, or contain different CV. */
5614             SV * const tmp = newRV((SV*)cv);
5615             sv_setsv(dbsv, tmp);
5616             SvREFCNT_dec(tmp);
5617         }
5618         else {
5619             gv_efullname3(dbsv, gv, NULL);
5620         }
5621     }
5622     else {
5623         const int type = SvTYPE(dbsv);
5624         if (type < SVt_PVIV && type != SVt_IV)
5625             sv_upgrade(dbsv, SVt_PVIV);
5626         (void)SvIOK_on(dbsv);
5627         SvIV_set(dbsv, PTR2IV(cv));     /* Do it the quickest way  */
5628     }
5629 }
5630
5631 /*
5632  * Local variables:
5633  * c-indentation-style: bsd
5634  * c-basic-offset: 4
5635  * indent-tabs-mode: t
5636  * End:
5637  *
5638  * ex: set ts=8 sts=4 sw=4 noet:
5639  */