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_ const char *cmd, const 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_ const char *cmd, const 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 #ifdef USE_LOCALE_NUMERIC
4307         char *loc = setlocale(LC_NUMERIC, "C");
4308 #endif
4309         STRLEN len = my_snprintf(tbuf, sizeof(tbuf), "%.9"NVff, SvNVX(ver));
4310 #ifdef USE_LOCALE_NUMERIC
4311         setlocale(LC_NUMERIC, loc);
4312 #endif
4313         while (tbuf[len-1] == '0' && len > 0) len--;
4314         version = savepvn(tbuf, len);
4315     }
4316 #ifdef SvVOK
4317     else if ( (mg = SvVSTRING_mg(ver)) ) { /* already a v-string */
4318         version = savepvn( (const char*)mg->mg_ptr,mg->mg_len );
4319         qv = 1;
4320     }
4321 #endif
4322     else /* must be a string or something like a string */
4323     {
4324         version = savepv(SvPV_nolen(ver));
4325     }
4326
4327     s = scan_version(version, ver, qv);
4328     if ( *s != '\0' )
4329         if(ckWARN(WARN_MISC))
4330             Perl_warner(aTHX_ packWARN(WARN_MISC),
4331                 "Version string '%s' contains invalid data; "
4332                 "ignoring: '%s'", version, s);
4333     Safefree(version);
4334     return ver;
4335 }
4336
4337 /*
4338 =for apidoc vverify
4339
4340 Validates that the SV contains a valid version object.
4341
4342     bool vverify(SV *vobj);
4343
4344 Note that it only confirms the bare minimum structure (so as not to get
4345 confused by derived classes which may contain additional hash entries):
4346
4347 =over 4
4348
4349 =item * The SV contains a [reference to a] hash
4350
4351 =item * The hash contains a "version" key
4352
4353 =item * The "version" key has [a reference to] an AV as its value
4354
4355 =back
4356
4357 =cut
4358 */
4359
4360 bool
4361 Perl_vverify(pTHX_ SV *vs)
4362 {
4363     SV *sv;
4364     if ( SvROK(vs) )
4365         vs = SvRV(vs);
4366
4367     /* see if the appropriate elements exist */
4368     if ( SvTYPE(vs) == SVt_PVHV
4369          && hv_exists((HV*)vs, "version", 7)
4370          && (sv = SvRV(*hv_fetchs((HV*)vs, "version", FALSE)))
4371          && SvTYPE(sv) == SVt_PVAV )
4372         return TRUE;
4373     else
4374         return FALSE;
4375 }
4376
4377 /*
4378 =for apidoc vnumify
4379
4380 Accepts a version object and returns the normalized floating
4381 point representation.  Call like:
4382
4383     sv = vnumify(rv);
4384
4385 NOTE: you can pass either the object directly or the SV
4386 contained within the RV.
4387
4388 =cut
4389 */
4390
4391 SV *
4392 Perl_vnumify(pTHX_ SV *vs)
4393 {
4394     I32 i, len, digit;
4395     int width;
4396     bool alpha = FALSE;
4397     SV * const sv = newSV(0);
4398     AV *av;
4399     if ( SvROK(vs) )
4400         vs = SvRV(vs);
4401
4402     if ( !vverify(vs) )
4403         Perl_croak(aTHX_ "Invalid version object");
4404
4405     /* see if various flags exist */
4406     if ( hv_exists((HV*)vs, "alpha", 5 ) )
4407         alpha = TRUE;
4408     if ( hv_exists((HV*)vs, "width", 5 ) )
4409         width = SvIV(*hv_fetchs((HV*)vs, "width", FALSE));
4410     else
4411         width = 3;
4412
4413
4414     /* attempt to retrieve the version array */
4415     if ( !(av = (AV *)SvRV(*hv_fetchs((HV*)vs, "version", FALSE)) ) ) {
4416         sv_catpvs(sv,"0");
4417         return sv;
4418     }
4419
4420     len = av_len(av);
4421     if ( len == -1 )
4422     {
4423         sv_catpvs(sv,"0");
4424         return sv;
4425     }
4426
4427     digit = SvIV(*av_fetch(av, 0, 0));
4428     Perl_sv_setpvf(aTHX_ sv, "%d.", (int)PERL_ABS(digit));
4429     for ( i = 1 ; i < len ; i++ )
4430     {
4431         digit = SvIV(*av_fetch(av, i, 0));
4432         if ( width < 3 ) {
4433             const int denom = (width == 2 ? 10 : 100);
4434             const div_t term = div((int)PERL_ABS(digit),denom);
4435             Perl_sv_catpvf(aTHX_ sv, "%0*d_%d", width, term.quot, term.rem);
4436         }
4437         else {
4438             Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit);
4439         }
4440     }
4441
4442     if ( len > 0 )
4443     {
4444         digit = SvIV(*av_fetch(av, len, 0));
4445         if ( alpha && width == 3 ) /* alpha version */
4446             sv_catpvs(sv,"_");
4447         Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit);
4448     }
4449     else /* len == 0 */
4450     {
4451         sv_catpvs(sv, "000");
4452     }
4453     return sv;
4454 }
4455
4456 /*
4457 =for apidoc vnormal
4458
4459 Accepts a version object and returns the normalized string
4460 representation.  Call like:
4461
4462     sv = vnormal(rv);
4463
4464 NOTE: you can pass either the object directly or the SV
4465 contained within the RV.
4466
4467 =cut
4468 */
4469
4470 SV *
4471 Perl_vnormal(pTHX_ SV *vs)
4472 {
4473     I32 i, len, digit;
4474     bool alpha = FALSE;
4475     SV * const sv = newSV(0);
4476     AV *av;
4477     if ( SvROK(vs) )
4478         vs = SvRV(vs);
4479
4480     if ( !vverify(vs) )
4481         Perl_croak(aTHX_ "Invalid version object");
4482
4483     if ( hv_exists((HV*)vs, "alpha", 5 ) )
4484         alpha = TRUE;
4485     av = (AV *)SvRV(*hv_fetchs((HV*)vs, "version", FALSE));
4486
4487     len = av_len(av);
4488     if ( len == -1 )
4489     {
4490         sv_catpvs(sv,"");
4491         return sv;
4492     }
4493     digit = SvIV(*av_fetch(av, 0, 0));
4494     Perl_sv_setpvf(aTHX_ sv, "v%"IVdf, (IV)digit);
4495     for ( i = 1 ; i < len ; i++ ) {
4496         digit = SvIV(*av_fetch(av, i, 0));
4497         Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
4498     }
4499
4500     if ( len > 0 )
4501     {
4502         /* handle last digit specially */
4503         digit = SvIV(*av_fetch(av, len, 0));
4504         if ( alpha )
4505             Perl_sv_catpvf(aTHX_ sv, "_%"IVdf, (IV)digit);
4506         else
4507             Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
4508     }
4509
4510     if ( len <= 2 ) { /* short version, must be at least three */
4511         for ( len = 2 - len; len != 0; len-- )
4512             sv_catpvs(sv,".0");
4513     }
4514     return sv;
4515 }
4516
4517 /*
4518 =for apidoc vstringify
4519
4520 In order to maintain maximum compatibility with earlier versions
4521 of Perl, this function will return either the floating point
4522 notation or the multiple dotted notation, depending on whether
4523 the original version contained 1 or more dots, respectively
4524
4525 =cut
4526 */
4527
4528 SV *
4529 Perl_vstringify(pTHX_ SV *vs)
4530 {
4531     if ( SvROK(vs) )
4532         vs = SvRV(vs);
4533
4534     if ( !vverify(vs) )
4535         Perl_croak(aTHX_ "Invalid version object");
4536
4537     if ( hv_exists((HV *)vs, "qv", 2) )
4538         return vnormal(vs);
4539     else
4540         return vnumify(vs);
4541 }
4542
4543 /*
4544 =for apidoc vcmp
4545
4546 Version object aware cmp.  Both operands must already have been
4547 converted into version objects.
4548
4549 =cut
4550 */
4551
4552 int
4553 Perl_vcmp(pTHX_ SV *lhv, SV *rhv)
4554 {
4555     I32 i,l,m,r,retval;
4556     bool lalpha = FALSE;
4557     bool ralpha = FALSE;
4558     I32 left = 0;
4559     I32 right = 0;
4560     AV *lav, *rav;
4561     if ( SvROK(lhv) )
4562         lhv = SvRV(lhv);
4563     if ( SvROK(rhv) )
4564         rhv = SvRV(rhv);
4565
4566     if ( !vverify(lhv) )
4567         Perl_croak(aTHX_ "Invalid version object");
4568
4569     if ( !vverify(rhv) )
4570         Perl_croak(aTHX_ "Invalid version object");
4571
4572     /* get the left hand term */
4573     lav = (AV *)SvRV(*hv_fetchs((HV*)lhv, "version", FALSE));
4574     if ( hv_exists((HV*)lhv, "alpha", 5 ) )
4575         lalpha = TRUE;
4576
4577     /* and the right hand term */
4578     rav = (AV *)SvRV(*hv_fetchs((HV*)rhv, "version", FALSE));
4579     if ( hv_exists((HV*)rhv, "alpha", 5 ) )
4580         ralpha = TRUE;
4581
4582     l = av_len(lav);
4583     r = av_len(rav);
4584     m = l < r ? l : r;
4585     retval = 0;
4586     i = 0;
4587     while ( i <= m && retval == 0 )
4588     {
4589         left  = SvIV(*av_fetch(lav,i,0));
4590         right = SvIV(*av_fetch(rav,i,0));
4591         if ( left < right  )
4592             retval = -1;
4593         if ( left > right )
4594             retval = +1;
4595         i++;
4596     }
4597
4598     /* tiebreaker for alpha with identical terms */
4599     if ( retval == 0 && l == r && left == right && ( lalpha || ralpha ) )
4600     {
4601         if ( lalpha && !ralpha )
4602         {
4603             retval = -1;
4604         }
4605         else if ( ralpha && !lalpha)
4606         {
4607             retval = +1;
4608         }
4609     }
4610
4611     if ( l != r && retval == 0 ) /* possible match except for trailing 0's */
4612     {
4613         if ( l < r )
4614         {
4615             while ( i <= r && retval == 0 )
4616             {
4617                 if ( SvIV(*av_fetch(rav,i,0)) != 0 )
4618                     retval = -1; /* not a match after all */
4619                 i++;
4620             }
4621         }
4622         else
4623         {
4624             while ( i <= l && retval == 0 )
4625             {
4626                 if ( SvIV(*av_fetch(lav,i,0)) != 0 )
4627                     retval = +1; /* not a match after all */
4628                 i++;
4629             }
4630         }
4631     }
4632     return retval;
4633 }
4634
4635 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET) && defined(SOCK_DGRAM) && defined(HAS_SELECT)
4636 #   define EMULATE_SOCKETPAIR_UDP
4637 #endif
4638
4639 #ifdef EMULATE_SOCKETPAIR_UDP
4640 static int
4641 S_socketpair_udp (int fd[2]) {
4642     dTHX;
4643     /* Fake a datagram socketpair using UDP to localhost.  */
4644     int sockets[2] = {-1, -1};
4645     struct sockaddr_in addresses[2];
4646     int i;
4647     Sock_size_t size = sizeof(struct sockaddr_in);
4648     unsigned short port;
4649     int got;
4650
4651     memset(&addresses, 0, sizeof(addresses));
4652     i = 1;
4653     do {
4654         sockets[i] = PerlSock_socket(AF_INET, SOCK_DGRAM, PF_INET);
4655         if (sockets[i] == -1)
4656             goto tidy_up_and_fail;
4657
4658         addresses[i].sin_family = AF_INET;
4659         addresses[i].sin_addr.s_addr = htonl(INADDR_LOOPBACK);
4660         addresses[i].sin_port = 0;      /* kernel choses port.  */
4661         if (PerlSock_bind(sockets[i], (struct sockaddr *) &addresses[i],
4662                 sizeof(struct sockaddr_in)) == -1)
4663             goto tidy_up_and_fail;
4664     } while (i--);
4665
4666     /* Now have 2 UDP sockets. Find out which port each is connected to, and
4667        for each connect the other socket to it.  */
4668     i = 1;
4669     do {
4670         if (PerlSock_getsockname(sockets[i], (struct sockaddr *) &addresses[i],
4671                 &size) == -1)
4672             goto tidy_up_and_fail;
4673         if (size != sizeof(struct sockaddr_in))
4674             goto abort_tidy_up_and_fail;
4675         /* !1 is 0, !0 is 1 */
4676         if (PerlSock_connect(sockets[!i], (struct sockaddr *) &addresses[i],
4677                 sizeof(struct sockaddr_in)) == -1)
4678             goto tidy_up_and_fail;
4679     } while (i--);
4680
4681     /* Now we have 2 sockets connected to each other. I don't trust some other
4682        process not to have already sent a packet to us (by random) so send
4683        a packet from each to the other.  */
4684     i = 1;
4685     do {
4686         /* I'm going to send my own port number.  As a short.
4687            (Who knows if someone somewhere has sin_port as a bitfield and needs
4688            this routine. (I'm assuming crays have socketpair)) */
4689         port = addresses[i].sin_port;
4690         got = PerlLIO_write(sockets[i], &port, sizeof(port));
4691         if (got != sizeof(port)) {
4692             if (got == -1)
4693                 goto tidy_up_and_fail;
4694             goto abort_tidy_up_and_fail;
4695         }
4696     } while (i--);
4697
4698     /* Packets sent. I don't trust them to have arrived though.
4699        (As I understand it Solaris TCP stack is multithreaded. Non-blocking
4700        connect to localhost will use a second kernel thread. In 2.6 the
4701        first thread running the connect() returns before the second completes,
4702        so EINPROGRESS> In 2.7 the improved stack is faster and connect()
4703        returns 0. Poor programs have tripped up. One poor program's authors'
4704        had a 50-1 reverse stock split. Not sure how connected these were.)
4705        So I don't trust someone not to have an unpredictable UDP stack.
4706     */
4707
4708     {
4709         struct timeval waitfor = {0, 100000}; /* You have 0.1 seconds */
4710         int max = sockets[1] > sockets[0] ? sockets[1] : sockets[0];
4711         fd_set rset;
4712
4713         FD_ZERO(&rset);
4714         FD_SET((unsigned int)sockets[0], &rset);
4715         FD_SET((unsigned int)sockets[1], &rset);
4716
4717         got = PerlSock_select(max + 1, &rset, NULL, NULL, &waitfor);
4718         if (got != 2 || !FD_ISSET(sockets[0], &rset)
4719                 || !FD_ISSET(sockets[1], &rset)) {
4720             /* I hope this is portable and appropriate.  */
4721             if (got == -1)
4722                 goto tidy_up_and_fail;
4723             goto abort_tidy_up_and_fail;
4724         }
4725     }
4726
4727     /* And the paranoia department even now doesn't trust it to have arrive
4728        (hence MSG_DONTWAIT). Or that what arrives was sent by us.  */
4729     {
4730         struct sockaddr_in readfrom;
4731         unsigned short buffer[2];
4732
4733         i = 1;
4734         do {
4735 #ifdef MSG_DONTWAIT
4736             got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
4737                     sizeof(buffer), MSG_DONTWAIT,
4738                     (struct sockaddr *) &readfrom, &size);
4739 #else
4740             got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
4741                     sizeof(buffer), 0,
4742                     (struct sockaddr *) &readfrom, &size);
4743 #endif
4744
4745             if (got == -1)
4746                 goto tidy_up_and_fail;
4747             if (got != sizeof(port)
4748                     || size != sizeof(struct sockaddr_in)
4749                     /* Check other socket sent us its port.  */
4750                     || buffer[0] != (unsigned short) addresses[!i].sin_port
4751                     /* Check kernel says we got the datagram from that socket */
4752                     || readfrom.sin_family != addresses[!i].sin_family
4753                     || readfrom.sin_addr.s_addr != addresses[!i].sin_addr.s_addr
4754                     || readfrom.sin_port != addresses[!i].sin_port)
4755                 goto abort_tidy_up_and_fail;
4756         } while (i--);
4757     }
4758     /* My caller (my_socketpair) has validated that this is non-NULL  */
4759     fd[0] = sockets[0];
4760     fd[1] = sockets[1];
4761     /* I hereby declare this connection open.  May God bless all who cross
4762        her.  */
4763     return 0;
4764
4765   abort_tidy_up_and_fail:
4766     errno = ECONNABORTED;
4767   tidy_up_and_fail:
4768     {
4769         const int save_errno = errno;
4770         if (sockets[0] != -1)
4771             PerlLIO_close(sockets[0]);
4772         if (sockets[1] != -1)
4773             PerlLIO_close(sockets[1]);
4774         errno = save_errno;
4775         return -1;
4776     }
4777 }
4778 #endif /*  EMULATE_SOCKETPAIR_UDP */
4779
4780 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET)
4781 int
4782 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
4783     /* Stevens says that family must be AF_LOCAL, protocol 0.
4784        I'm going to enforce that, then ignore it, and use TCP (or UDP).  */
4785     dTHX;
4786     int listener = -1;
4787     int connector = -1;
4788     int acceptor = -1;
4789     struct sockaddr_in listen_addr;
4790     struct sockaddr_in connect_addr;
4791     Sock_size_t size;
4792
4793     if (protocol
4794 #ifdef AF_UNIX
4795         || family != AF_UNIX
4796 #endif
4797     ) {
4798         errno = EAFNOSUPPORT;
4799         return -1;
4800     }
4801     if (!fd) {
4802         errno = EINVAL;
4803         return -1;
4804     }
4805
4806 #ifdef EMULATE_SOCKETPAIR_UDP
4807     if (type == SOCK_DGRAM)
4808         return S_socketpair_udp(fd);
4809 #endif
4810
4811     listener = PerlSock_socket(AF_INET, type, 0);
4812     if (listener == -1)
4813         return -1;
4814     memset(&listen_addr, 0, sizeof(listen_addr));
4815     listen_addr.sin_family = AF_INET;
4816     listen_addr.sin_addr.s_addr = htonl(INADDR_LOOPBACK);
4817     listen_addr.sin_port = 0;   /* kernel choses port.  */
4818     if (PerlSock_bind(listener, (struct sockaddr *) &listen_addr,
4819             sizeof(listen_addr)) == -1)
4820         goto tidy_up_and_fail;
4821     if (PerlSock_listen(listener, 1) == -1)
4822         goto tidy_up_and_fail;
4823
4824     connector = PerlSock_socket(AF_INET, type, 0);
4825     if (connector == -1)
4826         goto tidy_up_and_fail;
4827     /* We want to find out the port number to connect to.  */
4828     size = sizeof(connect_addr);
4829     if (PerlSock_getsockname(listener, (struct sockaddr *) &connect_addr,
4830             &size) == -1)
4831         goto tidy_up_and_fail;
4832     if (size != sizeof(connect_addr))
4833         goto abort_tidy_up_and_fail;
4834     if (PerlSock_connect(connector, (struct sockaddr *) &connect_addr,
4835             sizeof(connect_addr)) == -1)
4836         goto tidy_up_and_fail;
4837
4838     size = sizeof(listen_addr);
4839     acceptor = PerlSock_accept(listener, (struct sockaddr *) &listen_addr,
4840             &size);
4841     if (acceptor == -1)
4842         goto tidy_up_and_fail;
4843     if (size != sizeof(listen_addr))
4844         goto abort_tidy_up_and_fail;
4845     PerlLIO_close(listener);
4846     /* Now check we are talking to ourself by matching port and host on the
4847        two sockets.  */
4848     if (PerlSock_getsockname(connector, (struct sockaddr *) &connect_addr,
4849             &size) == -1)
4850         goto tidy_up_and_fail;
4851     if (size != sizeof(connect_addr)
4852             || listen_addr.sin_family != connect_addr.sin_family
4853             || listen_addr.sin_addr.s_addr != connect_addr.sin_addr.s_addr
4854             || listen_addr.sin_port != connect_addr.sin_port) {
4855         goto abort_tidy_up_and_fail;
4856     }
4857     fd[0] = connector;
4858     fd[1] = acceptor;
4859     return 0;
4860
4861   abort_tidy_up_and_fail:
4862 #ifdef ECONNABORTED
4863   errno = ECONNABORTED; /* This would be the standard thing to do. */
4864 #else
4865 #  ifdef ECONNREFUSED
4866   errno = ECONNREFUSED; /* E.g. Symbian does not have ECONNABORTED. */
4867 #  else
4868   errno = ETIMEDOUT;    /* Desperation time. */
4869 #  endif
4870 #endif
4871   tidy_up_and_fail:
4872     {
4873         const int save_errno = errno;
4874         if (listener != -1)
4875             PerlLIO_close(listener);
4876         if (connector != -1)
4877             PerlLIO_close(connector);
4878         if (acceptor != -1)
4879             PerlLIO_close(acceptor);
4880         errno = save_errno;
4881         return -1;
4882     }
4883 }
4884 #else
4885 /* In any case have a stub so that there's code corresponding
4886  * to the my_socketpair in global.sym. */
4887 int
4888 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
4889 #ifdef HAS_SOCKETPAIR
4890     return socketpair(family, type, protocol, fd);
4891 #else
4892     return -1;
4893 #endif
4894 }
4895 #endif
4896
4897 /*
4898
4899 =for apidoc sv_nosharing
4900
4901 Dummy routine which "shares" an SV when there is no sharing module present.
4902 Or "locks" it. Or "unlocks" it. In other words, ignores its single SV argument.
4903 Exists to avoid test for a NULL function pointer and because it could
4904 potentially warn under some level of strict-ness.
4905
4906 =cut
4907 */
4908
4909 void
4910 Perl_sv_nosharing(pTHX_ SV *sv)
4911 {
4912     PERL_UNUSED_CONTEXT;
4913     PERL_UNUSED_ARG(sv);
4914 }
4915
4916 U32
4917 Perl_parse_unicode_opts(pTHX_ const char **popt)
4918 {
4919   const char *p = *popt;
4920   U32 opt = 0;
4921
4922   if (*p) {
4923        if (isDIGIT(*p)) {
4924             opt = (U32) atoi(p);
4925             while (isDIGIT(*p))
4926                 p++;
4927             if (*p && *p != '\n' && *p != '\r')
4928                  Perl_croak(aTHX_ "Unknown Unicode option letter '%c'", *p);
4929        }
4930        else {
4931             for (; *p; p++) {
4932                  switch (*p) {
4933                  case PERL_UNICODE_STDIN:
4934                       opt |= PERL_UNICODE_STDIN_FLAG;   break;
4935                  case PERL_UNICODE_STDOUT:
4936                       opt |= PERL_UNICODE_STDOUT_FLAG;  break;
4937                  case PERL_UNICODE_STDERR:
4938                       opt |= PERL_UNICODE_STDERR_FLAG;  break;
4939                  case PERL_UNICODE_STD:
4940                       opt |= PERL_UNICODE_STD_FLAG;     break;
4941                  case PERL_UNICODE_IN:
4942                       opt |= PERL_UNICODE_IN_FLAG;      break;
4943                  case PERL_UNICODE_OUT:
4944                       opt |= PERL_UNICODE_OUT_FLAG;     break;
4945                  case PERL_UNICODE_INOUT:
4946                       opt |= PERL_UNICODE_INOUT_FLAG;   break;
4947                  case PERL_UNICODE_LOCALE:
4948                       opt |= PERL_UNICODE_LOCALE_FLAG;  break;
4949                  case PERL_UNICODE_ARGV:
4950                       opt |= PERL_UNICODE_ARGV_FLAG;    break;
4951                  case PERL_UNICODE_UTF8CACHEASSERT:
4952                       opt |= PERL_UNICODE_UTF8CACHEASSERT_FLAG; break;
4953                  default:
4954                       if (*p != '\n' && *p != '\r')
4955                           Perl_croak(aTHX_
4956                                      "Unknown Unicode option letter '%c'", *p);
4957                  }
4958             }
4959        }
4960   }
4961   else
4962        opt = PERL_UNICODE_DEFAULT_FLAGS;
4963
4964   if (opt & ~PERL_UNICODE_ALL_FLAGS)
4965        Perl_croak(aTHX_ "Unknown Unicode option value %"UVuf,
4966                   (UV) (opt & ~PERL_UNICODE_ALL_FLAGS));
4967
4968   *popt = p;
4969
4970   return opt;
4971 }
4972
4973 U32
4974 Perl_seed(pTHX)
4975 {
4976     dVAR;
4977     /*
4978      * This is really just a quick hack which grabs various garbage
4979      * values.  It really should be a real hash algorithm which
4980      * spreads the effect of every input bit onto every output bit,
4981      * if someone who knows about such things would bother to write it.
4982      * Might be a good idea to add that function to CORE as well.
4983      * No numbers below come from careful analysis or anything here,
4984      * except they are primes and SEED_C1 > 1E6 to get a full-width
4985      * value from (tv_sec * SEED_C1 + tv_usec).  The multipliers should
4986      * probably be bigger too.
4987      */
4988 #if RANDBITS > 16
4989 #  define SEED_C1       1000003
4990 #define   SEED_C4       73819
4991 #else
4992 #  define SEED_C1       25747
4993 #define   SEED_C4       20639
4994 #endif
4995 #define   SEED_C2       3
4996 #define   SEED_C3       269
4997 #define   SEED_C5       26107
4998
4999 #ifndef PERL_NO_DEV_RANDOM
5000     int fd;
5001 #endif
5002     U32 u;
5003 #ifdef VMS
5004 #  include <starlet.h>
5005     /* when[] = (low 32 bits, high 32 bits) of time since epoch
5006      * in 100-ns units, typically incremented ever 10 ms.        */
5007     unsigned int when[2];
5008 #else
5009 #  ifdef HAS_GETTIMEOFDAY
5010     struct timeval when;
5011 #  else
5012     Time_t when;
5013 #  endif
5014 #endif
5015
5016 /* This test is an escape hatch, this symbol isn't set by Configure. */
5017 #ifndef PERL_NO_DEV_RANDOM
5018 #ifndef PERL_RANDOM_DEVICE
5019    /* /dev/random isn't used by default because reads from it will block
5020     * if there isn't enough entropy available.  You can compile with
5021     * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
5022     * is enough real entropy to fill the seed. */
5023 #  define PERL_RANDOM_DEVICE "/dev/urandom"
5024 #endif
5025     fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
5026     if (fd != -1) {
5027         if (PerlLIO_read(fd, (void*)&u, sizeof u) != sizeof u)
5028             u = 0;
5029         PerlLIO_close(fd);
5030         if (u)
5031             return u;
5032     }
5033 #endif
5034
5035 #ifdef VMS
5036     _ckvmssts(sys$gettim(when));
5037     u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
5038 #else
5039 #  ifdef HAS_GETTIMEOFDAY
5040     PerlProc_gettimeofday(&when,NULL);
5041     u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
5042 #  else
5043     (void)time(&when);
5044     u = (U32)SEED_C1 * when;
5045 #  endif
5046 #endif
5047     u += SEED_C3 * (U32)PerlProc_getpid();
5048     u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
5049 #ifndef PLAN9           /* XXX Plan9 assembler chokes on this; fix needed  */
5050     u += SEED_C5 * (U32)PTR2UV(&when);
5051 #endif
5052     return u;
5053 }
5054
5055 UV
5056 Perl_get_hash_seed(pTHX)
5057 {
5058     dVAR;
5059      const char *s = PerlEnv_getenv("PERL_HASH_SEED");
5060      UV myseed = 0;
5061
5062      if (s)
5063         while (isSPACE(*s))
5064             s++;
5065      if (s && isDIGIT(*s))
5066           myseed = (UV)Atoul(s);
5067      else
5068 #ifdef USE_HASH_SEED_EXPLICIT
5069      if (s)
5070 #endif
5071      {
5072           /* Compute a random seed */
5073           (void)seedDrand01((Rand_seed_t)seed());
5074           myseed = (UV)(Drand01() * (NV)UV_MAX);
5075 #if RANDBITS < (UVSIZE * 8)
5076           /* Since there are not enough randbits to to reach all
5077            * the bits of a UV, the low bits might need extra
5078            * help.  Sum in another random number that will
5079            * fill in the low bits. */
5080           myseed +=
5081                (UV)(Drand01() * (NV)((1 << ((UVSIZE * 8 - RANDBITS))) - 1));
5082 #endif /* RANDBITS < (UVSIZE * 8) */
5083           if (myseed == 0) { /* Superparanoia. */
5084               myseed = (UV)(Drand01() * (NV)UV_MAX); /* One more chance. */
5085               if (myseed == 0)
5086                   Perl_croak(aTHX_ "Your random numbers are not that random");
5087           }
5088      }
5089      PL_rehash_seed_set = TRUE;
5090
5091      return myseed;
5092 }
5093
5094 #ifdef USE_ITHREADS
5095 bool
5096 Perl_stashpv_hvname_match(pTHX_ const COP *c, const HV *hv)
5097 {
5098     const char * const stashpv = CopSTASHPV(c);
5099     const char * const name = HvNAME_get(hv);
5100     PERL_UNUSED_CONTEXT;
5101
5102     if (stashpv == name)
5103         return TRUE;
5104     if (stashpv && name)
5105         if (strEQ(stashpv, name))
5106             return TRUE;
5107     return FALSE;
5108 }
5109 #endif
5110
5111
5112 #ifdef PERL_GLOBAL_STRUCT
5113
5114 struct perl_vars *
5115 Perl_init_global_struct(pTHX)
5116 {
5117     struct perl_vars *plvarsp = NULL;
5118 #ifdef PERL_GLOBAL_STRUCT
5119 #  define PERL_GLOBAL_STRUCT_INIT
5120 #  include "opcode.h" /* the ppaddr and check */
5121     const IV nppaddr = sizeof(Gppaddr)/sizeof(Perl_ppaddr_t);
5122     const IV ncheck  = sizeof(Gcheck) /sizeof(Perl_check_t);
5123 #  ifdef PERL_GLOBAL_STRUCT_PRIVATE
5124     /* PerlMem_malloc() because can't use even safesysmalloc() this early. */
5125     plvarsp = (struct perl_vars*)PerlMem_malloc(sizeof(struct perl_vars));
5126     if (!plvarsp)
5127         exit(1);
5128 #  else
5129     plvarsp = PL_VarsPtr;
5130 #  endif /* PERL_GLOBAL_STRUCT_PRIVATE */
5131 #  undef PERLVAR
5132 #  undef PERLVARA
5133 #  undef PERLVARI
5134 #  undef PERLVARIC
5135 #  undef PERLVARISC
5136 #  define PERLVAR(var,type) /**/
5137 #  define PERLVARA(var,n,type) /**/
5138 #  define PERLVARI(var,type,init) plvarsp->var = init;
5139 #  define PERLVARIC(var,type,init) plvarsp->var = init;
5140 #  define PERLVARISC(var,init) Copy(init, plvarsp->var, sizeof(init), char);
5141 #  include "perlvars.h"
5142 #  undef PERLVAR
5143 #  undef PERLVARA
5144 #  undef PERLVARI
5145 #  undef PERLVARIC
5146 #  undef PERLVARISC
5147 #  ifdef PERL_GLOBAL_STRUCT
5148     plvarsp->Gppaddr = PerlMem_malloc(nppaddr * sizeof(Perl_ppaddr_t));
5149     if (!plvarsp->Gppaddr)
5150         exit(1);
5151     plvarsp->Gcheck  = PerlMem_malloc(ncheck  * sizeof(Perl_check_t));
5152     if (!plvarsp->Gcheck)
5153         exit(1);
5154     Copy(Gppaddr, plvarsp->Gppaddr, nppaddr, Perl_ppaddr_t);
5155     Copy(Gcheck,  plvarsp->Gcheck,  ncheck,  Perl_check_t);
5156 #  endif
5157 #  ifdef PERL_SET_VARS
5158     PERL_SET_VARS(plvarsp);
5159 #  endif
5160 #  undef PERL_GLOBAL_STRUCT_INIT
5161 #endif
5162     return plvarsp;
5163 }
5164
5165 #endif /* PERL_GLOBAL_STRUCT */
5166
5167 #ifdef PERL_GLOBAL_STRUCT
5168
5169 void
5170 Perl_free_global_struct(pTHX_ struct perl_vars *plvarsp)
5171 {
5172 #ifdef PERL_GLOBAL_STRUCT
5173 #  ifdef PERL_UNSET_VARS
5174     PERL_UNSET_VARS(plvarsp);
5175 #  endif
5176     free(plvarsp->Gppaddr);
5177     free(plvarsp->Gcheck);
5178 #    ifdef PERL_GLOBAL_STRUCT_PRIVATE
5179     free(plvarsp);
5180 #    endif
5181 #endif
5182 }
5183
5184 #endif /* PERL_GLOBAL_STRUCT */
5185
5186 #ifdef PERL_MEM_LOG
5187
5188 /*
5189  * PERL_MEM_LOG: the Perl_mem_log_..() will be compiled.
5190  *
5191  * PERL_MEM_LOG_ENV: if defined, during run time the environment
5192  * variable PERL_MEM_LOG will be consulted, and if the integer value
5193  * of that is true, the logging will happen.  (The default is to
5194  * always log if the PERL_MEM_LOG define was in effect.)
5195  */
5196
5197 /*
5198  * PERL_MEM_LOG_SPRINTF_BUF_SIZE: size of a (stack-allocated) buffer
5199  * the Perl_mem_log_...() will use (either via sprintf or snprintf).
5200  */
5201 #define PERL_MEM_LOG_SPRINTF_BUF_SIZE 128
5202
5203 /*
5204  * PERL_MEM_LOG_FD: the file descriptor the Perl_mem_log_...() will
5205  * log to.  You can also define in compile time PERL_MEM_LOG_ENV_FD,
5206  * in which case the environment variable PERL_MEM_LOG_FD will be
5207  * consulted for the file descriptor number to use.
5208  */
5209 #ifndef PERL_MEM_LOG_FD
5210 #  define PERL_MEM_LOG_FD 2 /* If STDERR is too boring for you. */
5211 #endif
5212
5213 Malloc_t
5214 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)
5215 {
5216 #ifdef PERL_MEM_LOG_STDERR
5217 # if defined(PERL_MEM_LOG_ENV) || defined(PERL_MEM_LOG_ENV_FD)
5218     char *s;
5219 # endif
5220 # ifdef PERL_MEM_LOG_ENV
5221     s = getenv("PERL_MEM_LOG");
5222     if (s ? atoi(s) : 0)
5223 # endif
5224     {
5225         /* We can't use SVs or PerlIO for obvious reasons,
5226          * so we'll use stdio and low-level IO instead. */
5227         char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE];
5228 # ifdef PERL_MEM_LOG_TIMESTAMP
5229         struct timeval tv;
5230 #   ifdef HAS_GETTIMEOFDAY
5231         gettimeofday(&tv, 0);
5232 #   endif
5233         /* If there are other OS specific ways of hires time than
5234          * gettimeofday() (see ext/Time/HiRes), the easiest way is
5235          * probably that they would be used to fill in the struct
5236          * timeval. */
5237 # endif
5238         {
5239             const STRLEN len =
5240                 my_snprintf(buf,
5241                             sizeof(buf),
5242 #  ifdef PERL_MEM_LOG_TIMESTAMP
5243                             "%10d.%06d: "
5244 # endif
5245                             "alloc: %s:%d:%s: %"IVdf" %"UVuf
5246                             " %s = %"IVdf": %"UVxf"\n",
5247 #  ifdef PERL_MEM_LOG_TIMESTAMP
5248                             (int)tv.tv_sec, (int)tv.tv_usec,
5249 # endif
5250                             filename, linenumber, funcname, n, typesize,
5251                             typename, n * typesize, PTR2UV(newalloc));
5252 # ifdef PERL_MEM_LOG_ENV_FD
5253             s = PerlEnv_getenv("PERL_MEM_LOG_FD");
5254             PerlLIO_write(s ? atoi(s) : PERL_MEM_LOG_FD, buf, len);
5255 # else
5256             PerlLIO_write(PERL_MEM_LOG_FD, buf, len);
5257 #endif
5258         }
5259     }
5260 #endif
5261     return newalloc;
5262 }
5263
5264 Malloc_t
5265 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)
5266 {
5267 #ifdef PERL_MEM_LOG_STDERR
5268 # if defined(PERL_MEM_LOG_ENV) || defined(PERL_MEM_LOG_ENV_FD)
5269     char *s;
5270 # endif
5271 # ifdef PERL_MEM_LOG_ENV
5272     s = PerlEnv_getenv("PERL_MEM_LOG");
5273     if (s ? atoi(s) : 0)
5274 # endif
5275     {
5276         /* We can't use SVs or PerlIO for obvious reasons,
5277          * so we'll use stdio and low-level IO instead. */
5278         char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE];
5279 #  ifdef PERL_MEM_LOG_TIMESTAMP
5280         struct timeval tv;
5281         gettimeofday(&tv, 0);
5282 # endif
5283         {
5284             const STRLEN len =
5285                 my_snprintf(buf,
5286                             sizeof(buf),
5287 #  ifdef PERL_MEM_LOG_TIMESTAMP
5288                             "%10d.%06d: "
5289 # endif
5290                             "realloc: %s:%d:%s: %"IVdf" %"UVuf
5291                             " %s = %"IVdf": %"UVxf" -> %"UVxf"\n",
5292 #  ifdef PERL_MEM_LOG_TIMESTAMP
5293                             (int)tv.tv_sec, (int)tv.tv_usec,
5294 # endif
5295                             filename, linenumber, funcname, n, typesize,
5296                             typename, n * typesize, PTR2UV(oldalloc),
5297                             PTR2UV(newalloc));
5298 # ifdef PERL_MEM_LOG_ENV_FD
5299             s = PerlEnv_getenv("PERL_MEM_LOG_FD");
5300             PerlLIO_write(s ? atoi(s) : PERL_MEM_LOG_FD, buf, len);
5301 # else
5302             PerlLIO_write(PERL_MEM_LOG_FD, buf, len);
5303 # endif
5304         }
5305     }
5306 #endif
5307     return newalloc;
5308 }
5309
5310 Malloc_t
5311 Perl_mem_log_free(Malloc_t oldalloc, const char *filename, const int linenumber, const char *funcname)
5312 {
5313 #ifdef PERL_MEM_LOG_STDERR
5314 # if defined(PERL_MEM_LOG_ENV) || defined(PERL_MEM_LOG_ENV_FD)
5315     char *s;
5316 # endif
5317 # ifdef PERL_MEM_LOG_ENV
5318     s = PerlEnv_getenv("PERL_MEM_LOG");
5319     if (s ? atoi(s) : 0)
5320 # endif
5321     {
5322         /* We can't use SVs or PerlIO for obvious reasons,
5323          * so we'll use stdio and low-level IO instead. */
5324         char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE];
5325 #  ifdef PERL_MEM_LOG_TIMESTAMP
5326         struct timeval tv;
5327         gettimeofday(&tv, 0);
5328 # endif
5329         {
5330             const STRLEN len =
5331                 my_snprintf(buf,
5332                             sizeof(buf),
5333 #  ifdef PERL_MEM_LOG_TIMESTAMP
5334                             "%10d.%06d: "
5335 # endif
5336                             "free: %s:%d:%s: %"UVxf"\n",
5337 #  ifdef PERL_MEM_LOG_TIMESTAMP
5338                             (int)tv.tv_sec, (int)tv.tv_usec,
5339 # endif
5340                             filename, linenumber, funcname,
5341                             PTR2UV(oldalloc));
5342 # ifdef PERL_MEM_LOG_ENV_FD
5343             s = PerlEnv_getenv("PERL_MEM_LOG_FD");
5344             PerlLIO_write(s ? atoi(s) : PERL_MEM_LOG_FD, buf, len);
5345 # else
5346             PerlLIO_write(PERL_MEM_LOG_FD, buf, len);
5347 # endif
5348         }
5349     }
5350 #endif
5351     return oldalloc;
5352 }
5353
5354 #endif /* PERL_MEM_LOG */
5355
5356 /*
5357 =for apidoc my_sprintf
5358
5359 The C library C<sprintf>, wrapped if necessary, to ensure that it will return
5360 the length of the string written to the buffer. Only rare pre-ANSI systems
5361 need the wrapper function - usually this is a direct call to C<sprintf>.
5362
5363 =cut
5364 */
5365 #ifndef SPRINTF_RETURNS_STRLEN
5366 int
5367 Perl_my_sprintf(char *buffer, const char* pat, ...)
5368 {
5369     va_list args;
5370     va_start(args, pat);
5371     vsprintf(buffer, pat, args);
5372     va_end(args);
5373     return strlen(buffer);
5374 }
5375 #endif
5376
5377 /*
5378 =for apidoc my_snprintf
5379
5380 The C library C<snprintf> functionality, if available and
5381 standards-compliant (uses C<vsnprintf>, actually).  However, if the
5382 C<vsnprintf> is not available, will unfortunately use the unsafe
5383 C<vsprintf> which can overrun the buffer (there is an overrun check,
5384 but that may be too late).  Consider using C<sv_vcatpvf> instead, or
5385 getting C<vsnprintf>.
5386
5387 =cut
5388 */
5389 int
5390 Perl_my_snprintf(char *buffer, const Size_t len, const char *format, ...)
5391 {
5392     dTHX;
5393     int retval;
5394     va_list ap;
5395     va_start(ap, format);
5396 #ifdef HAS_VSNPRINTF
5397     retval = vsnprintf(buffer, len, format, ap);
5398 #else
5399     retval = vsprintf(buffer, format, ap);
5400 #endif
5401     va_end(ap);
5402     /* vsnprintf() shows failure with >= len, vsprintf() with < 0 */
5403     if (retval < 0 || (len > 0 && (Size_t)retval >= len))
5404         Perl_croak(aTHX_ "panic: my_snprintf buffer overflow");
5405     return retval;
5406 }
5407
5408 /*
5409 =for apidoc my_vsnprintf
5410
5411 The C library C<vsnprintf> if available and standards-compliant.
5412 However, if if the C<vsnprintf> is not available, will unfortunately
5413 use the unsafe C<vsprintf> which can overrun the buffer (there is an
5414 overrun check, but that may be too late).  Consider using
5415 C<sv_vcatpvf> instead, or getting C<vsnprintf>.
5416
5417 =cut
5418 */
5419 int
5420 Perl_my_vsnprintf(char *buffer, const Size_t len, const char *format, va_list ap)
5421 {
5422     dTHX;
5423     int retval;
5424 #ifdef NEED_VA_COPY
5425     va_list apc;
5426     Perl_va_copy(ap, apc);
5427 # ifdef HAS_VSNPRINTF
5428     retval = vsnprintf(buffer, len, format, apc);
5429 # else
5430     retval = vsprintf(buffer, format, apc);
5431 # endif
5432 #else
5433 # ifdef HAS_VSNPRINTF
5434     retval = vsnprintf(buffer, len, format, ap);
5435 # else
5436     retval = vsprintf(buffer, format, ap);
5437 # endif
5438 #endif /* #ifdef NEED_VA_COPY */
5439     /* vsnprintf() shows failure with >= len, vsprintf() with < 0 */
5440     if (retval < 0 || (len > 0 && (Size_t)retval >= len))
5441         Perl_croak(aTHX_ "panic: my_vsnprintf buffer overflow");
5442     return retval;
5443 }
5444
5445 void
5446 Perl_my_clearenv(pTHX)
5447 {
5448     dVAR;
5449 #if ! defined(PERL_MICRO)
5450 #  if defined(PERL_IMPLICIT_SYS) || defined(WIN32)
5451     PerlEnv_clearenv();
5452 #  else /* ! (PERL_IMPLICIT_SYS || WIN32) */
5453 #    if defined(USE_ENVIRON_ARRAY)
5454 #      if defined(USE_ITHREADS)
5455     /* only the parent thread can clobber the process environment */
5456     if (PL_curinterp == aTHX)
5457 #      endif /* USE_ITHREADS */
5458     {
5459 #      if ! defined(PERL_USE_SAFE_PUTENV)
5460     if ( !PL_use_safe_putenv) {
5461       I32 i;
5462       if (environ == PL_origenviron)
5463         environ = (char**)safesysmalloc(sizeof(char*));
5464       else
5465         for (i = 0; environ[i]; i++)
5466           (void)safesysfree(environ[i]);
5467     }
5468     environ[0] = NULL;
5469 #      else /* PERL_USE_SAFE_PUTENV */
5470 #        if defined(HAS_CLEARENV)
5471     (void)clearenv();
5472 #        elif defined(HAS_UNSETENV)
5473     int bsiz = 80; /* Most envvar names will be shorter than this. */
5474     int bufsiz = bsiz * sizeof(char); /* sizeof(char) paranoid? */
5475     char *buf = (char*)safesysmalloc(bufsiz);
5476     while (*environ != NULL) {
5477       char *e = strchr(*environ, '=');
5478       int l = e ? e - *environ : (int)strlen(*environ);
5479       if (bsiz < l + 1) {
5480         (void)safesysfree(buf);
5481         bsiz = l + 1; /* + 1 for the \0. */
5482         buf = (char*)safesysmalloc(bufsiz);
5483       }
5484       my_strlcpy(buf, *environ, l + 1);
5485       (void)unsetenv(buf);
5486     }
5487     (void)safesysfree(buf);
5488 #        else /* ! HAS_CLEARENV && ! HAS_UNSETENV */
5489     /* Just null environ and accept the leakage. */
5490     *environ = NULL;
5491 #        endif /* HAS_CLEARENV || HAS_UNSETENV */
5492 #      endif /* ! PERL_USE_SAFE_PUTENV */
5493     }
5494 #    endif /* USE_ENVIRON_ARRAY */
5495 #  endif /* PERL_IMPLICIT_SYS || WIN32 */
5496 #endif /* PERL_MICRO */
5497 }
5498
5499 #ifdef PERL_IMPLICIT_CONTEXT
5500
5501 /* implements the MY_CXT_INIT macro. The first time a module is loaded,
5502 the global PL_my_cxt_index is incremented, and that value is assigned to
5503 that module's static my_cxt_index (who's address is passed as an arg).
5504 Then, for each interpreter this function is called for, it makes sure a
5505 void* slot is available to hang the static data off, by allocating or
5506 extending the interpreter's PL_my_cxt_list array */
5507
5508 void *
5509 Perl_my_cxt_init(pTHX_ int *index, size_t size)
5510 {
5511     dVAR;
5512     void *p;
5513     if (*index == -1) {
5514         /* this module hasn't been allocated an index yet */
5515         MUTEX_LOCK(&PL_my_ctx_mutex);
5516         *index = PL_my_cxt_index++;
5517         MUTEX_UNLOCK(&PL_my_ctx_mutex);
5518     }
5519
5520     /* make sure the array is big enough */
5521     if (PL_my_cxt_size <= *index) {
5522         if (PL_my_cxt_size) {
5523             while (PL_my_cxt_size <= *index)
5524                 PL_my_cxt_size *= 2;
5525             Renew(PL_my_cxt_list, PL_my_cxt_size, void *);
5526         }
5527         else {
5528             PL_my_cxt_size = 16;
5529             Newx(PL_my_cxt_list, PL_my_cxt_size, void *);
5530         }
5531     }
5532     /* newSV() allocates one more than needed */
5533     p = (void*)SvPVX(newSV(size-1));
5534     PL_my_cxt_list[*index] = p;
5535     Zero(p, size, char);
5536     return p;
5537 }
5538 #endif
5539
5540 #ifndef HAS_STRLCAT
5541 Size_t
5542 Perl_my_strlcat(char *dst, const char *src, Size_t size)
5543 {
5544     Size_t used, length, copy;
5545
5546     used = strlen(dst);
5547     length = strlen(src);
5548     if (size > 0 && used < size - 1) {
5549         copy = (length >= size - used) ? size - used - 1 : length;
5550         memcpy(dst + used, src, copy);
5551         dst[used + copy] = '\0';
5552     }
5553     return used + length;
5554 }
5555 #endif
5556
5557 #ifndef HAS_STRLCPY
5558 Size_t
5559 Perl_my_strlcpy(char *dst, const char *src, Size_t size)
5560 {
5561     Size_t length, copy;
5562
5563     length = strlen(src);
5564     if (size > 0) {
5565         copy = (length >= size) ? size - 1 : length;
5566         memcpy(dst, src, copy);
5567         dst[copy] = '\0';
5568     }
5569     return length;
5570 }
5571 #endif
5572
5573 /*
5574  * Local variables:
5575  * c-indentation-style: bsd
5576  * c-basic-offset: 4
5577  * indent-tabs-mode: t
5578  * End:
5579  *
5580  * ex: set ts=8 sts=4 sw=4 noet:
5581  */