util.c

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