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