util.c

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