util.c

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