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