util.c

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